Mercurial > hg > CbC > CbC_gcc
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; |