1-- C371003.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 if a discriminant constraint depends on a discriminant,
28--      the evaluation of the expressions in the constraint is deferred
29--      until an object of the subtype is created.  Check for cases of
30--      records where the component containing the constraint is present
31--      in the subtype.
32--
33-- TEST DESCRIPTION:
34--      This transition test defines record types with discriminant components
35--      which depend on the discriminants.  The discriminants are calculated
36--      by function calls.  The test verifies that Constraint_Error is raised
37--      during the object creations when values of discriminants are
38--      incompatible with the subtypes.  Also check for cases, where the
39--      component is absent.
40--
41--      Inspired by C37213E.ADA, C37213G.ADA, C37215E.ADA, and C37215G.ADA.
42--
43--
44-- CHANGE HISTORY:
45--      10 Apr 96   SAIC    Initial version for ACVC 2.1.
46--      14 Jul 96   SAIC    Modified test description.  Added exception handler
47--                          for VObj_10 assignment.
48--      26 Oct 96   SAIC    Added LM references.
49--
50--!
51
52with Report;
53
54procedure C371003 is
55
56   subtype Small_Int is Integer range 1..10;
57
58   type Rec_W_Disc (Disc1, Disc2 : Small_Int) is
59     record
60        Str1 : String (1 .. Disc1) := (others => '*');
61        Str2 : String (1 .. Disc2) := (others => '*');
62     end record;
63
64   type My_Array is array (Small_Int range <>) of Integer;
65
66   Func1_Cons : Integer := 0;
67
68   ---------------------------------------------------------
69   function Chk (Cons    : Integer;
70                 Value   : Integer;
71                 Message : String) return Boolean is
72   begin
73      if Cons /= Value then
74         Report.Failed (Message & ": Func1_Cons is " &
75                        Integer'Image(Func1_Cons));
76      end if;
77      return True;
78   end Chk;
79
80   ---------------------------------------------------------
81   function Func1 return Integer is
82   begin
83      Func1_Cons := Func1_Cons + Report.Ident_Int(1);
84      return Func1_Cons;
85   end Func1;
86
87
88begin
89   Report.Test ("C371003", "Check that if a discriminant constraint " &
90                "depends on a discriminant, the evaluation of the "   &
91                "expressions in the constraint is deferred until "    &
92                "object declarations");
93
94   ---------------------------------------------------------
95   declare
96      type VRec_01 (D3 : Integer) is
97        record
98           case D3 is
99              when -5..10 =>
100                 C1 : Rec_W_Disc (D3, Func1);    -- Func1 evaluated, value 1.
101              when others =>
102                 C2 : Integer := Report.Ident_Int(0);
103           end case;
104        end record;
105
106        Chk1 : Boolean := Chk (Func1_Cons, 1,
107                               "Func1 not evaluated for VRec_01");
108
109        VObj_1 : VRec_01(1);                     -- Func1 not evaluated again
110        VObj_2 : VRec_01(2);                     -- Func1 not evaluated again
111
112        Chk2 : Boolean := Chk (Func1_Cons, 1,
113                               "Func1 evaluated too many times");
114
115   begin
116      if VObj_1 /= (D3 => 1,
117                    C1 => (Disc1   => 1,
118                           Disc2   => 1,
119                           Str1    => (others => '*'),
120                           Str2    => (others => '*'))) or
121         VObj_2 /= (D3 => 2,
122                    C1 => (Disc1   => 2,
123                           Disc2   => 1,
124                           Str1    => (others => '*'),
125                           Str2    => (others => '*'))) then
126         Report.Failed ("VObj_1 & VObj_2 - Discriminant values not correct");
127      end if;
128   end;
129
130   ---------------------------------------------------------
131   Func1_Cons := -11;
132
133   declare
134      type VRec_Of_VRec_01 (D3 : Integer) is
135        record
136           case D3 is
137              when -5..10 =>
138                 C1 : Rec_W_Disc (Func1, D3);   -- Func1 evaluated, value -10.
139              when others =>                    -- Constraint_Error not raised.
140                 C2 : Integer := Report.Ident_Int(0);
141           end case;
142        end record;
143
144      type VRec_Of_VRec_02 (D3 : Integer) is
145        record
146           case D3 is
147              when -5..10 =>
148                 C1 : Rec_W_Disc (1, D3);
149              when others =>
150                 C2 : Integer := Report.Ident_Int(0);
151           end case;
152        end record;
153
154      type VRec_Of_MyArr_01 (D3 : Integer) is
155        record
156           case D3 is
157              when -5..10 =>
158                 C1 : My_Array  (Func1..D3);    -- Func1 evaluated, value -9.
159              when others =>                    -- Constraint_Error not raised.
160                 C2 : Integer := Report.Ident_Int(0);
161           end case;
162        end record;
163
164      type VRec_Of_MyArr_02 (D3 : Integer) is
165        record
166           case D3 is
167              when -5..10 =>
168                 C1 : My_Array  (D3..1);
169              when others =>
170                 C2 : Integer := Report.Ident_Int(0);
171           end case;
172        end record;
173
174   begin
175
176      ---------------------------------------------------------
177      -- Component containing the constraint is present.
178      begin
179         declare
180            VObj_3 : VRec_Of_VRec_01(1);        -- Constraint_Error raised.
181         begin
182            Report.Failed ("VObj_3 - Constraint_Error should be raised");
183            if VObj_3 /= (1, (1, 1, others => (others => '*'))) then
184                Report.Comment ("VObj_3 - Shouldn't get here");
185            end if;
186         end;
187
188      exception
189         when Constraint_Error =>               -- Exception expected.
190              null;
191         when others           =>
192              Report.Failed ("VObj_3 - unexpected exception raised");
193      end;
194
195      ---------------------------------------------------------
196      -- Component containing the constraint is present.
197      begin
198         declare
199            subtype Subtype_VRec is             -- No Constraint_Error raised.
200              VRec_Of_VRec_01(Report.Ident_Int(1));
201         begin
202            declare
203               VObj_4 : Subtype_VRec;           -- Constraint_Error raised.
204            begin
205               Report.Failed ("VObj_4 - Constraint_Error should be raised");
206               if VObj_4 /= (D3 => 1,
207                             C1 => (Disc1   => 1,
208                                    Disc2   => 1,
209                                    Str1    => (others => '*'),
210                                    Str2    => (others => '*'))) then
211                  Report.Comment ("VObj_4 - Shouldn't get here");
212               end if;
213            end;
214
215         exception
216            when Constraint_Error =>            -- Exception expected.
217                null;
218            when others =>
219                Report.Failed ("VObj_4 - unexpected exception raised");
220         end;
221
222      exception
223         when Constraint_Error =>
224              Report.Failed ("Subtype_VRec - Constraint_Error raised");
225         when others =>
226              Report.Failed ("Subtype_VRec - unexpected exception raised");
227      end;
228
229      ---------------------------------------------------------
230      -- Component containing the constraint is absent.
231      begin
232         declare
233            type Arr is array (1..5) of
234              VRec_Of_VRec_01(Report.Ident_Int(-6)); -- No Constraint_Error
235            VObj_5 : Arr;                            -- for either declaration.
236
237         begin
238            if VObj_5 /= (1 .. 5 => (-6, 0)) then
239               Report.Comment ("VObj_5 - wrong values");
240            end if;
241         end;
242
243      exception
244         when others =>
245              Report.Failed ("Arr - unexpected exception raised");
246      end;
247
248      ---------------------------------------------------------
249      -- Component containing the constraint is present.
250      begin
251         declare
252            type Rec_Of_Rec_Of_MyArr is
253              record
254                 C1 : VRec_Of_MyArr_01(1);    -- No Constraint_Error raised.
255              end record;
256         begin
257            declare
258               Obj_6 : Rec_Of_Rec_Of_MyArr;   -- Constraint_Error raised.
259            begin
260               Report.Failed ("Obj_6 - Constraint_Error should be raised");
261               if Obj_6 /= (C1 => (1, (1, 1))) then
262                  Report.Comment ("Obj_6 - Shouldn't get here");
263               end if;
264            end;
265
266         exception
267            when Constraint_Error =>         -- Exception expected.
268                null;
269            when others =>
270                Report.Failed ("Obj_6 - unexpected exception raised");
271         end;
272
273      exception
274         when Constraint_Error =>
275              Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised");
276         when others =>
277              Report.Failed ("Rec_Of_Rec_Of_MyArr - unexpected exception " &
278                             "raised");
279      end;
280
281      ---------------------------------------------------------
282      -- Component containing the constraint is absent.
283      begin
284         declare
285            type New_VRec_Arr is
286              new VRec_Of_MyArr_01(11);       -- No Constraint_Error raised
287            Obj_7 : New_VRec_Arr;             -- for either declaration.
288
289         begin
290            if Obj_7 /= (11, 0) then
291               Report.Failed ("Obj_7 - value incorrect");
292            end if;
293         end;
294
295      exception
296         when others =>
297              Report.Failed ("New_VRec_Arr - unexpected exception raised");
298      end;
299
300      ---------------------------------------------------------
301      -- Component containing the constraint is present.
302      begin
303         declare
304            type New_VRec is new
305              VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error
306                                                    -- raised.
307         begin
308            declare
309                VObj_8 : New_VRec;                  -- Constraint_Error raised.
310            begin
311               Report.Failed ("VObj_8 - Constraint_Error should be raised");
312               if VObj_8 /= (1, (1, 1, others => (others => '*'))) then
313                  Report.Comment ("VObj_8 - Shouldn't get here");
314               end if;
315            end;
316
317         exception
318            when Constraint_Error =>               -- Exception expected.
319                null;
320            when others =>
321                Report.Failed ("VObj_8 - unexpected exception raised");
322         end;
323
324      exception
325         when Constraint_Error =>
326              Report.Failed ("New_VRec - Constraint_Error raised");
327         when others =>
328              Report.Failed ("New_VRec - unexpected exception raised");
329      end;
330
331      ---------------------------------------------------------
332      -- Component containing the constraint is absent.
333      begin
334         declare
335            subtype Sub_VRec is
336              VRec_Of_VRec_02(Report.Ident_Int(11)); -- No Constraint_Error
337            VObj_9 : Sub_VRec;                       -- raised for either
338                                                     -- declaration.
339         begin
340            if VObj_9 /= (11, 0) then
341               Report.Comment ("VObj_9 - wrong values");
342            end if;
343         end;
344
345      exception
346         when others =>
347              Report.Failed ("Sub_VRec - unexpected exception raised");
348      end;
349
350      ---------------------------------------------------------
351      -- Component containing the constraint is present.
352      begin
353         declare
354            type Acc_VRec_01 is access
355              VRec_Of_VRec_02(Report.Ident_Int(0));  -- No Constraint_Error
356                                                     -- raised.
357         begin
358            declare
359               VObj_10 : Acc_VRec_01;                -- No Constraint_Error
360                                                     -- raised.
361            begin
362               VObj_10 := new VRec_Of_VRec_02
363                            (Report.Ident_Int(0));   -- Constraint_Error
364                                                     -- raised.
365               Report.Failed ("VObj_10 - Constraint_Error should be raised");
366               if VObj_10.all /= (1, (1, 1, others => (others => '*'))) then
367                  Report.Comment ("VObj_10 - Shouldn't get here");
368               end if;
369
370            exception
371               when Constraint_Error =>              -- Exception expected.
372                   null;
373               when others =>
374                   Report.Failed ("VObj_10 - unexpected exception raised");
375            end;
376
377         exception
378            when Constraint_Error =>
379                Report.Failed ("VObj_10 - Constraint_Error exception raised");
380            when others =>
381                Report.Failed ("VObj_10 - unexpected exception raised at " &
382                               "declaration");
383         end;
384
385      exception
386         when Constraint_Error =>
387              Report.Failed ("Acc_VRec_01 - Constraint_Error raised");
388         when others =>
389              Report.Failed ("Acc_VRec_01 - unexpected exception raised");
390      end;
391
392      ---------------------------------------------------------
393      -- Component containing the constraint is absent.
394      begin
395         declare
396            type Acc_VRec_02 is access
397              VRec_Of_VRec_02(11);                  -- No Constraint_Error
398                                                    -- raised for either
399            VObj_11 :  Acc_VRec_02;                 -- declaration.
400
401         begin
402            VObj_11 := new VRec_Of_VRec_02(11);
403            if VObj_11.all /= (11, 0) then
404               Report.Comment ("VObj_11 - wrong values");
405            end if;
406         end;
407
408      exception
409         when others =>
410              Report.Failed ("Acc_VRec_02 - unexpected exception raised");
411      end;
412
413      ---------------------------------------------------------
414      -- Component containing the constraint is present.
415      begin
416         declare
417            type Acc_VRec_03 is access
418              VRec_Of_MyArr_02;                    -- No Constraint_Error
419                                                   -- raised for either
420            VObj_12 : Acc_VRec_03;                 -- declaration.
421         begin
422            VObj_12 := new VRec_Of_MyArr_02
423                           (Report.Ident_Int(0)); -- Constraint_Error raised.
424
425            Report.Failed ("VObj_12 - Constraint_Error should be raised");
426            if VObj_12.all /= (1, (1, 1)) then
427               Report.Comment ("VObj_12 - Shouldn't get here");
428            end if;
429
430         exception
431            when Constraint_Error =>              -- Exception expected.
432                null;
433            when others =>
434                Report.Failed ("VObj_12 - unexpected exception raised");
435         end;
436
437      exception
438         when Constraint_Error =>
439              Report.Failed ("Acc_VRec_03 - Constraint_Error raised");
440         when others =>
441              Report.Failed ("Acc_VRec_03 - unexpected exception raised");
442      end;
443
444      ---------------------------------------------------------
445      -- Component containing the constraint is absent.
446      begin
447         declare
448            type Acc_VRec_04 is access
449              VRec_Of_MyArr_02(11);                 -- No Constraint_Error
450                                                    -- raised for either
451            VObj_13 :  Acc_VRec_04;                 -- declaration.
452
453         begin
454            VObj_13 := new VRec_Of_MyArr_02(11);
455            if VObj_13.all /= (11, 0) then
456               Report.Comment ("VObj_13 - wrong values");
457            end if;
458         end;
459
460      exception
461         when others =>
462              Report.Failed ("Acc_VRec_04 - unexpected exception raised");
463      end;
464
465   end;
466
467   Report.Result;
468
469exception
470     when others =>
471          Report.Failed ("Discriminant value checked too soon");
472          Report.Result;
473
474end C371003;
475