1-- C371002.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 until
29--      an object of the subtype is created.  Check for cases of records.
30--
31-- TEST DESCRIPTION:
32--      This transition test defines record types with discriminant components
33--      which depend on the discriminants.  The discriminants are calculated
34--      by function calls.  The test verifies that Constraint_Error is raised
35--      during the object creations when values of discriminants are
36--      incompatible with the subtypes.
37--
38--      Inspired by C37213A.ADA, C37213C.ADA, C37215A.ADA and C37215C.ADA.
39--
40--
41-- CHANGE HISTORY:
42--      05 Apr 96   SAIC    Initial version for ACVC 2.1.
43--
44--!
45
46with Report;
47
48procedure C371002 is
49
50   subtype Small_Int is Integer range 1..10;
51
52   type Rec_W_Disc (Disc1, Disc2 : Small_Int) is
53     record
54        Str1 : String (1 .. Disc1) := (others => '*');
55        Str2 : String (1 .. Disc2) := (others => '*');
56     end record;
57
58   type My_Array is array (Small_Int range <>) of Integer;
59
60   Func1_Cons : Integer := 0;
61
62   ---------------------------------------------------------
63   function Chk (Cons    : Integer;
64                 Value   : Integer;
65                 Message : String) return Boolean is
66   begin
67      if Cons /= Value then
68         Report.Failed (Message & ": Func1_Cons is " &
69                        Integer'Image(Func1_Cons));
70      end if;
71      return True;
72   end Chk;
73
74   ---------------------------------------------------------
75   function Func1 return Integer is
76   begin
77      Func1_Cons := Func1_Cons + Report.Ident_Int(1);
78      return Func1_Cons;
79   end Func1;
80
81begin
82   Report.Test ("C371002", "Check that if a discriminant constraint " &
83                "depends on a discriminant, the evaluation of the "   &
84                "expressions in the constraint is deferred until "    &
85                "object declarations");
86
87   ---------------------------------------------------------
88   declare
89      type Rec1 (D3 : Integer) is
90        record
91           C1 : Rec_W_Disc (D3, Func1);      -- Func1 evaluated, value 1.
92        end record;
93
94      Chk1 : Boolean := Chk (Func1_Cons, 1,
95                             "Func1 not evaluated for Rec1");
96
97      Obj1 : Rec1 (1);                       -- Func1 not evaluated again.
98      Obj2 : Rec1 (2);                       -- Func1 not evaluated again.
99
100      Chk2 : Boolean := Chk (Func1_Cons, 1,
101                             "Func1 evaluated too many times");
102   begin
103      if Obj1 /= (D3 => 1,
104                  C1 => (Disc1   => 1,
105                         Disc2   => 1,
106                         Str1    => (others => '*'),
107                         Str2    => (others => '*'))) or
108         Obj2 /= (D3 => 2,
109                  C1 => (Disc1   => 2,
110                         Disc2   => 1,
111                         Str1    => (others => '*'),
112                         Str2    => (others => '*'))) then
113           Report.Failed ("Obj1 & Obj2 - Discriminant values not correct");
114      end if;
115   end;
116
117   ---------------------------------------------------------
118   Func1_Cons := -11;
119
120   declare
121      type Rec_Of_Rec_01 (D3 : Integer) is
122        record
123           C1 : Rec_W_Disc (D3, Func1);      -- Func1 evaluated, value -10.
124        end record;                          -- Constraint_Error not raised.
125
126      type Rec_Of_MyArr_01 (D3 : Integer) is
127        record
128           C1 : My_Array (Func1 .. D3);      -- Func1 evaluated, value -9.
129        end record;                          -- Constraint_Error not raised.
130
131      type Rec_Of_Rec_02 (D3 : Integer) is
132        record
133           C1 : Rec_W_Disc (D3, 1);
134        end record;
135
136      type Rec_Of_MyArr_02 (D3 : Integer) is
137        record
138           C1 : My_Array (D3 .. 1);
139        end record;
140
141   begin
142
143      ---------------------------------------------------------
144      begin
145         declare
146            Obj3 : Rec_Of_Rec_01(1);         -- Constraint_Error raised.
147         begin
148            Report.Failed ("Obj3 - Constraint_Error should be raised");
149            if Obj3 /= (1, (1, 1, others => (others => '*'))) then
150               Report.Comment ("Obj3 - Shouldn't get here");
151            end if;
152         end;
153
154      exception
155         when Constraint_Error =>            -- Exception expected.
156              null;
157         when others           =>
158              Report.Failed ("Obj3 - others exception raised");
159      end;
160
161      ---------------------------------------------------------
162      begin
163         declare
164            subtype Subtype_Rec is Rec_Of_Rec_01(1);
165                                             -- No Constraint_Error raised.
166         begin
167            declare
168               Obj4 : Subtype_Rec;           -- Constraint_Error raised.
169            begin
170               Report.Failed ("Obj4 - Constraint_Error should be raised");
171               if Obj4 /= (D3 => 1,
172                           C1 => (Disc1   => 1,
173                                  Disc2   => 1,
174                                  Str1    => (others => '*'),
175                                  Str2    => (others => '*'))) then
176                  Report.Comment ("Obj4 - Shouldn't get here");
177               end if;
178            end;
179
180         exception
181            when Constraint_Error =>         -- Exception expected.
182                null;
183            when others =>
184                Report.Failed ("Obj4 - others exception raised");
185         end;
186
187      exception
188         when Constraint_Error =>
189              Report.Failed ("Subtype_Rec - Constraint_Error raised");
190         when others =>
191              Report.Failed ("Subtype_Rec - others exception raised");
192      end;
193
194      ---------------------------------------------------------
195      begin
196         declare
197            type Arr is array (1..5)         -- No Constraint_Error raised.
198              of Rec_Of_Rec_01(1);
199
200         begin
201            declare
202               Obj5 : Arr;                   -- Constraint_Error raised.
203            begin
204               Report.Failed ("Obj5 - Constraint_Error should be raised");
205               if Obj5 /= (1..5 => (1, (1, 1, others => (others => '*')))) then
206                  Report.Comment ("Obj5 - Shouldn't get here");
207               end if;
208            end;
209
210         exception
211            when Constraint_Error =>         -- Exception expected.
212                null;
213            when others =>
214                Report.Failed ("Obj5 - others exception raised");
215         end;
216
217      exception
218         when Constraint_Error =>
219              Report.Failed ("Arr - Constraint_Error raised");
220         when others =>
221              Report.Failed ("Arr - others exception raised");
222      end;
223
224      ---------------------------------------------------------
225      begin
226         declare
227            type Rec_Of_Rec_Of_MyArr is
228              record
229                 C1 : Rec_Of_MyArr_01(1);    -- No Constraint_Error raised.
230              end record;
231         begin
232            declare
233               Obj6 : Rec_Of_Rec_Of_MyArr;   -- Constraint_Error raised.
234            begin
235               Report.Failed ("Obj6 - Constraint_Error should be raised");
236               if Obj6 /= (C1 => (1, (1, 1))) then
237                  Report.Comment ("Obj6 - Shouldn't get here");
238               end if;
239            end;
240
241         exception
242            when Constraint_Error =>         -- Exception expected.
243                null;
244            when others =>
245                Report.Failed ("Obj6 - others exception raised");
246         end;
247
248      exception
249         when Constraint_Error =>
250              Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised");
251         when others =>
252              Report.Failed ("Rec_Of_Rec_Of_MyArr - others exception raised");
253      end;
254
255      ---------------------------------------------------------
256      begin
257         declare
258            type New_Rec is
259              new Rec_Of_MyArr_01(1);        -- No Constraint_Error raised.
260
261         begin
262            declare
263               Obj7 : New_Rec;               -- Constraint_Error raised.
264            begin
265               Report.Failed ("Obj7 - Constraint_Error should be raised");
266               if Obj7 /= (1, (1, 1)) then
267                  Report.Comment ("Obj7 - Shouldn't get here");
268               end if;
269            end;
270
271         exception
272            when Constraint_Error =>         -- Exception expected.
273                null;
274            when others =>
275                Report.Failed ("Obj7 - others exception raised");
276         end;
277
278      exception
279         when Constraint_Error =>
280              Report.Failed ("New_Rec - Constraint_Error raised");
281         when others =>
282              Report.Failed ("New_Rec - others exception raised");
283      end;
284
285      ---------------------------------------------------------
286      begin
287         declare
288            type Acc_Rec is
289              access Rec_Of_Rec_02 (Report.Ident_Int(0));
290                                             -- No Constraint_Error raised.
291         begin
292            declare
293               Obj8 : Acc_Rec;               -- No Constraint_Error raised.
294
295            begin
296               Obj8 := new Rec_Of_Rec_02 (Report.Ident_Int(0));
297                                             -- Constraint_Error raised.
298
299               Report.Failed ("Obj8 - Constraint_Error should be raised");
300               if Obj8.all /= (D3 => 1,
301                               C1 => (Disc1   => 1,
302                                      Disc2   => 1,
303                                      Str1    => (others => '*'),
304                                      Str2    => (others => '*'))) then
305                  Report.Comment ("Obj8 - Shouldn't get here");
306               end if;
307            end;
308
309         exception
310            when Constraint_Error =>         -- Exception expected.
311                null;
312            when others =>
313                Report.Failed ("Obj8 - others exception raised");
314         end;
315
316      exception
317         when Constraint_Error =>
318              Report.Failed ("Acc_Rec - Constraint_Error raised");
319         when others =>
320              Report.Failed ("Acc_Rec - others exception raised");
321      end;
322
323      ---------------------------------------------------------
324      begin
325         declare
326            type Acc_Rec_MyArr is access
327              Rec_Of_MyArr_02;               -- No Constraint_Error
328                                             -- raised for either
329            Obj9 : Acc_Rec_MyArr;            -- declaration.
330
331         begin
332            Obj9 := new Rec_Of_MyArr_02 (Report.Ident_Int(0));
333                                             -- Constraint_Error raised.
334
335            Report.Failed ("Obj9 - Constraint_Error should be raised");
336
337            if Obj9.all /= (1, (1, 1)) then
338               Report.Comment ("Obj9 - Shouldn't get here");
339            end if;
340
341         exception
342            when Constraint_Error =>         -- Exception expected.
343                null;
344            when others =>
345                Report.Failed ("Obj9 - others exception raised");
346         end;
347
348      exception
349         when Constraint_Error =>
350              Report.Failed ("Acc_Rec_MyArr - Constraint_Error raised");
351         when others =>
352              Report.Failed ("Acc_Rec_MyArr - others exception raised");
353      end;
354
355   end;
356
357   Report.Result;
358
359exception
360     when others =>
361          Report.Failed ("Discriminant value checked too soon");
362          Report.Result;
363
364end C371002;
365