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