comparison gcc/testsuite/ada/acats/tests/c3/c371002.a @ 111:04ced10e8804

gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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
46 with Report;
47
48 procedure 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
81 begin
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
359 exception
360 when others =>
361 Report.Failed ("Discriminant value checked too soon");
362 Report.Result;
363
364 end C371002;