1-- C460009.A
2--
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7--     unlimited rights in the software and documentation contained herein.
8--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9--     this public release, the Government intends to confer upon all
10--     recipients unlimited rights  equal to those held by the Government.
11--     These rights include rights to use, duplicate, release or disclose the
12--     released technical data and computer software in whole or in part, in
13--     any manner and for any purpose whatsoever, and to have or permit others
14--     to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25--
26-- OBJECTIVE:
27--     Check that Constraint_Error is raised in cases of null arrays when:
28--     1.  an assignment is made to a null array if the length of each
29--         dimension of the operand does not match the length of
30--         the corresponding dimension of the target subtype.
31--     2.  an array actual parameter does not match the length of
32--         corresponding dimensions of the formal in out parameter where
33--         the actual parameter has the form of a type conversion.
34--     3.  an array actual parameter does not match the length of
35--         corresponding dimensions of the formal out parameter where
36--         the actual parameter has the form of a type conversion.
37--
38-- TEST DESCRIPTION:
39--      This transition test creates examples where array of null ranges
40--      raises Constraint_Error if any of the lengths mismatch.
41--
42--      Inspired by C52103S.ADA, C64105E.ADA, and C64105F.ADA.
43--
44--
45-- CHANGE HISTORY:
46--      21 Mar 96   SAIC    Initial version for ACVC 2.1.
47--      21 Sep 96   SAIC    ACVC 2.1: Added new case.
48--
49--!
50
51with Report;
52
53procedure C460009 is
54
55   subtype Int is Integer range 1 .. 3;
56
57begin
58
59   Report.Test("C460009","Check that Constraint_Error is raised in "  &
60               "cases of null arrays if any of the lengths mismatch " &
61               "in assignments and parameter passing");
62
63   ---------------------------------------------------------------------------
64   declare
65
66      type Arr_Int1 is array (Int range <>) of Integer;
67      Arr_Obj1 : Arr_Int1 (2 .. Report.Ident_Int(1));     -- null array object
68
69   begin
70
71      -- Same lengths, no Constraint_Error raised.
72      Arr_Obj1 := (Report.Ident_Int(3) .. 2 => Report.Ident_Int(1));
73
74      Report.Comment ("Dead assignment prevention in Arr_Obj1 => " &
75                       Integer'Image (Arr_Obj1'Last));
76
77   exception
78
79      when Constraint_Error =>
80        Report.Failed ("Arr_Obj1 - Constraint_Error exception raised");
81      when others           =>
82        Report.Failed ("Arr_Obj1 - others exception raised");
83
84   end;
85
86   ---------------------------------------------------------------------------
87   declare
88
89      type Arr_Int2 is array (Int range <>, Int range <>) of Integer;
90      Arr_Obj2 : Arr_Int2 (1 .. Report.Ident_Int(2),
91                           Report.Ident_Int(3) .. Report.Ident_Int(2));
92                                                           -- null array object
93   begin
94
95      -- Same lengths, no Constraint_Error raised.
96      Arr_Obj2 := Arr_Int2'(Report.Ident_Int(2) .. 3 =>
97                  (Report.Ident_Int(2) .. Report.Ident_Int(1) =>
98                   Report.Ident_Int(1)));
99
100      Report.Comment ("Dead assignment prevention in Arr_Obj2 => " &
101                       Integer'Image (Arr_Obj2'Last));
102
103   exception
104
105      when Constraint_Error =>
106        Report.Failed ("Arr_Obj2 - Constraint_Error exception raised");
107      when others           =>
108        Report.Failed ("Arr_Obj2 - others exception raised");
109
110   end;
111
112   ---------------------------------------------------------------------------
113   declare
114
115      type Arr_Int3 is array (Int range <>, Int range <>) of Integer;
116      Arr_Obj3 : Arr_Int3 (1 .. Report.Ident_Int(2),
117                           Report.Ident_Int(3) .. Report.Ident_Int(2));
118                                                           -- null array object
119
120   begin
121
122      -- Lengths mismatch, Constraint_Error raised.
123      Arr_Obj3 := Arr_Int3'(Report.Ident_Int(3) .. 2 =>
124                  (Report.Ident_Int(1) .. Report.Ident_Int(3) =>
125                   Report.Ident_Int(1)));
126
127      Report.Comment ("Dead assignment prevention in Arr_Obj3 => " &
128                       Integer'Image (Arr_Obj3'Last));
129
130      Report.Failed ("Constraint_Error not raised in Arr_Obj3");
131
132   exception
133
134      when Constraint_Error => null;      -- exception expected.
135      when others           =>
136        Report.Failed ("Arr_Obj3 - others exception raised");
137
138   end;
139
140   ---------------------------------------------------------------------------
141   declare
142
143      type Arr_Int4 is array (Int range <>, Int range <>, Int range <>) of
144        Integer;
145      Arr_Obj4 : Arr_Int4 (1 .. Report.Ident_Int(2),
146                           Report.Ident_Int(1) .. Report.Ident_Int(3),
147                           Report.Ident_Int(3) .. Report.Ident_Int(2));
148                                                           -- null array object
149   begin
150
151      -- Lengths mismatch, Constraint_Error raised.
152      Arr_Obj4 := Arr_Int4'(Report.Ident_Int(1) .. 3 =>
153                  (Report.Ident_Int(1) .. Report.Ident_Int(2) =>
154                   (Report.Ident_Int(3) .. Report.Ident_Int(2) =>
155                   Report.Ident_Int(1))));
156
157      Report.Comment ("Dead assignment prevention in Arr_Obj4 => " &
158                       Integer'Image (Arr_Obj4'Last));
159
160      Report.Failed ("Constraint_Error not raised in Arr_Obj4");
161
162   exception
163
164      when Constraint_Error => null;      -- exception expected.
165      when others           =>
166        Report.Failed ("Arr_Obj4 - others exception raised");
167
168   end;
169
170   ---------------------------------------------------------------------------
171   declare
172
173      type Arr_Int5 is array (Int range <>) of Integer;
174      Arr_Obj5 : Arr_Int5 (2 .. Report.Ident_Int(1));     -- null array object
175
176   begin
177
178      -- Only lengths of two null ranges are different, no Constraint_Error
179      -- raised.
180      Arr_Obj5 := (Report.Ident_Int(3) .. 1 => Report.Ident_Int(1));
181
182      Report.Comment ("Dead assignment prevention in Arr_Obj5 => " &
183                       Integer'Image (Arr_Obj5'Last));
184
185   exception
186
187      when Constraint_Error =>
188        Report.Failed ("Arr_Obj5 - Constraint_Error exception raised");
189      when others           =>
190        Report.Failed ("Arr_Obj5 - others exception raised");
191
192   end;
193
194   ---------------------------------------------------------------------------
195   declare
196      subtype Str is String (Report.Ident_Int(5) .. 4);
197                                                            -- null string
198      Str_Obj : Str;
199
200   begin
201
202      -- Same lengths, no Constraint_Error raised.
203      Str_Obj := (Report.Ident_Int(1) .. 0 => 'Z');
204      Str_Obj(2 .. 1) := "";
205      Str_Obj(4 .. 2) := (others => 'X');
206      Str_Obj(Report.Ident_Int(6) .. 3) := "";
207      Str_Obj(Report.Ident_Int(0) .. Report.Ident_Int(-1)) := (others => 'Y');
208
209   exception
210
211      when Constraint_Error =>
212        Report.Failed ("Str_Obj - Constraint_Error exception raised");
213      when others           =>
214        Report.Failed ("Str_Obj - others exception raised");
215
216   end;
217
218   ---------------------------------------------------------------------------
219   declare
220
221      type Arr_Char5 is array (Int range <>, Int range <>) of Character;
222      subtype Formal is Arr_Char5
223        (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3));
224      Arr_Obj5 : Arr_Char5 (Report.Ident_Int(2) .. Report.Ident_Int(1),
225                            Report.Ident_Int(1) .. Report.Ident_Int(2))
226               := (Report.Ident_Int(2) .. Report.Ident_Int(1) =>
227                  (Report.Ident_Int(1) .. Report.Ident_Int(2) => ' '));
228
229      procedure Proc5 (P : in out Formal) is
230      begin
231         Report.Failed ("No exception raised in Proc5");
232
233      exception
234
235         when Constraint_Error =>
236           Report.Failed ("Constraint_Error exception raised in Proc5");
237         when others           =>
238           Report.Failed ("Others exception raised in Proc5");
239      end;
240
241   begin
242
243      -- Lengths mismatch in the type conversion, Constraint_Error raised.
244      Proc5 (Formal(Arr_Obj5));
245
246      Report.Failed ("Constraint_Error not raised in the call Proc5");
247
248   exception
249
250      when Constraint_Error => null;      -- exception expected.
251      when others           =>
252        Report.Failed ("Arr_Obj5 - others exception raised");
253
254   end;
255
256   ---------------------------------------------------------------------------
257   declare
258
259      type Formal is array
260        (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character;
261
262      type Actual is array
263        (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character;
264
265      Arr_Obj6 : Actual := (5 .. 3 => (3 .. 5 => ' '));
266
267      procedure Proc6 (P : in out Formal) is
268      begin
269         Report.Failed ("No exception raised in Proc6");
270
271      exception
272
273         when Constraint_Error =>
274           Report.Failed ("Constraint_Error exception raised in Proc6");
275         when others           =>
276           Report.Failed ("Others exception raised in Proc6");
277      end;
278
279   begin
280
281      -- Lengths mismatch in the type conversion, Constraint_Error raised.
282      Proc6 (Formal(Arr_Obj6));
283
284      Report.Failed ("Constraint_Error not raised in the call Proc6");
285
286   exception
287
288      when Constraint_Error => null;      -- exception expected.
289      when others           =>
290        Report.Failed ("Arr_Obj6 - others exception raised");
291
292   end;
293
294   ---------------------------------------------------------------------------
295   declare
296
297      type Formal is array (Int range <>, Int range <>) of Character;
298      type Actual is array (Positive range 5 .. 2,
299                            Positive range 1 .. 3) of Character;
300
301      Arr_Obj7 : Actual := (5 .. 2 => (1 .. 3 => ' '));
302
303      procedure Proc7 (P : in out Formal) is
304      begin
305         if P'Last /= 2 and P'Last(2) /= 3 then
306            Report.Failed ("Wrong bounds passed for Arr_Obj7");
307         end if;
308
309         -- Lengths mismatch, Constraint_Error raised.
310         P := (1 .. 3 => (3 .. 0 => ' '));
311
312         Report.Comment ("Dead assignment prevention in Proc7 => " &
313                          Integer'Image (P'Last));
314
315         Report.Failed ("No exception raised in Proc7");
316
317      exception
318
319         when Constraint_Error => null;      -- exception expected.
320         when others           =>
321           Report.Failed ("Others exception raised in Proc7");
322      end;
323
324   begin
325
326      -- Same lengths, no Constraint_Error raised.
327      Proc7 (Formal(Arr_Obj7));
328
329      if Arr_Obj7'Last /= 2 and Arr_Obj7'Last(2) /= 3 then
330         Report.Failed ("Bounds changed for Arr_Obj7");
331      end if;
332
333   exception
334
335      when Constraint_Error =>
336        Report.Failed ("Constraint_Error exception raised after call Proc7");
337      when others           =>
338        Report.Failed ("Arr_Obj7 - others exception raised");
339
340   end;
341
342   ---------------------------------------------------------------------------
343   declare
344
345      type Arr_Char8 is array (Int range <>, Int range <>) of Character;
346      subtype Formal is Arr_Char8
347        (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3));
348      Arr_Obj8 : Arr_Char8 (Report.Ident_Int(2) .. Report.Ident_Int(1),
349                            Report.Ident_Int(1) .. Report.Ident_Int(2));
350
351      procedure Proc8 (P : out Formal) is
352      begin
353         Report.Failed ("No exception raised in Proc8");
354
355      exception
356
357         when Constraint_Error =>
358           Report.Failed ("Constraint_Error exception raised in Proc8");
359         when others           =>
360           Report.Failed ("Others exception raised in Proc8");
361      end;
362
363   begin
364
365      -- Lengths mismatch in the type conversion, Constraint_Error raised.
366      Proc8 (Formal(Arr_Obj8));
367
368      Report.Failed ("Constraint_Error not raised in the call Proc8");
369
370   exception
371
372      when Constraint_Error => null;      -- exception expected.
373      when others           =>
374        Report.Failed ("Arr_Obj8 - others exception raised");
375
376   end;
377
378   ---------------------------------------------------------------------------
379   declare
380
381      type Formal is array
382        (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character;
383
384      type Actual is array
385        (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character;
386
387      Arr_Obj9 : Actual;
388
389      procedure Proc9 (P : out Formal) is
390      begin
391         Report.Failed ("No exception raised in Proc9");
392
393      exception
394
395         when Constraint_Error =>
396           Report.Failed ("Constraint_Error exception raised in Proc9");
397         when others           =>
398           Report.Failed ("Others exception raised in Proc9");
399      end;
400
401   begin
402
403      -- Lengths mismatch in the type conversion, Constraint_Error raised.
404      Proc9 (Formal(Arr_Obj9));
405
406      Report.Failed ("Constraint_Error not raised in the call Proc9");
407
408   exception
409
410      when Constraint_Error => null;      -- exception expected.
411      when others           =>
412        Report.Failed ("Arr_Obj9 - others exception raised");
413
414   end;
415
416   ---------------------------------------------------------------------------
417   declare
418
419      type Formal is array (Int range <>, Int range <>) of Character;
420      type Actual is array (Positive range 5 .. 2,
421                            Positive range 1 .. 3) of Character;
422
423      Arr_Obj10 : Actual;
424
425      procedure Proc10 (P : out Formal) is
426      begin
427         if P'Last /= 2 and P'Last(2) /= 3 then
428            Report.Failed ("Wrong bounds passed for Arr_Obj10");
429         end if;
430
431         -- Lengths mismatch, Constraint_Error raised.
432         P := (1 .. 3 => (3 .. 1 => ' '));
433
434         Report.Comment ("Dead assignment prevention in Proc10 => " &
435                          Integer'Image (P'Last));
436
437         Report.Failed ("No exception raised in Proc10");
438
439      exception
440
441         when Constraint_Error => null;      -- exception expected.
442         when others           =>
443           Report.Failed ("Others exception raised in Proc10");
444      end;
445
446   begin
447
448      -- Same lengths, no Constraint_Error raised.
449      Proc10 (Formal(Arr_Obj10));
450
451      if Arr_Obj10'Last /= 2 and Arr_Obj10'Last(2) /= 3 then
452         Report.Failed ("Bounds changed for Arr_Obj10");
453      end if;
454
455   exception
456
457      when Constraint_Error =>
458        Report.Failed ("Constraint_Error exception raised after call Proc10");
459      when others           =>
460        Report.Failed ("Arr_Obj10 - others exception raised");
461
462   end;
463
464   ---------------------------------------------------------------------------
465   Report.Result;
466
467end C460009;
468