Mercurial > hg > CbC > CbC_gcc

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 -- C37211B.ADA
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 -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT
26 -- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE
27 -- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE
28 -- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED
29 -- PRIVATE TYPE, AND THE DISCRIMINANT CONSTRAINT OCCURS AFTER THE FULL
30 -- DECLARATION OF THE TYPE.
31
32 -- R.WILLIAMS 8/28/86
33 -- EDS 7/14/98 AVOID OPTIMIZATION
34
35 WITH REPORT; USE REPORT;
36 PROCEDURE C37211B IS
37
38 SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE;
39
40 PACKAGE PKG IS
41 TYPE PRIV (L : LIES) IS PRIVATE;
42 TYPE LIM (L : LIES) IS LIMITED PRIVATE;
43
44 PRIVATE
45 TYPE PRIV (L : LIES) IS
46 RECORD
47 NULL;
48 END RECORD;
49
50 TYPE LIM (L : LIES) IS
51 RECORD
52 NULL;
53 END RECORD;
54 END PKG;
55
56 USE PKG;
57
58 BEGIN
59 TEST ( "C37211B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
60 "A DISCRIMINANT CONSTRAINT IF A VALUE " &
61 "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " &
62 "IN THE RANGE OF THE DISCRIMINANT WHERE THE " &
63 "TYPE MARK DENOTES A PRIVATE OR LIMITED " &
64 "PRIVATE TYPE, AND THE DISCRIMINANT " &
65 "CONSTRAINT OCCURS AFTER THE FULL " &
66 "DECLARATION OF THE TYPE" );
67
68 BEGIN
69 DECLARE
70 SUBTYPE SUBPRIV IS PRIV (IDENT_BOOL (TRUE));
71 BEGIN
72 DECLARE
73 SP : SUBPRIV;
74 BEGIN
75 FAILED ( "NO EXCEPTION RAISED AT THE " &
76 "ELABORATION OF SUBTYPE SUBPRIV " &
77 BOOLEAN'IMAGE(SP.L));
78 END;
79 EXCEPTION
80 WHEN OTHERS =>
81 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
82 "OBJECT SP" );
83 END;
84
85 EXCEPTION
86 WHEN CONSTRAINT_ERROR =>
87 NULL;
88 WHEN OTHERS =>
89 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
90 "SUBTYPE SUBPRIV" );
91 END;
92
93 BEGIN
94 DECLARE
95 SUBTYPE SUBLIM IS LIM (IDENT_BOOL (TRUE));
96 BEGIN
97 DECLARE
98 SL : SUBLIM;
99 BEGIN
100 FAILED ( "NO EXCEPTION RAISED AT THE " &
101 "ELABORATION OF SUBTYPE SUBLIM" &
102 BOOLEAN'IMAGE(SL.L));
103 END;
104 EXCEPTION
105 WHEN OTHERS =>
106 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
107 "OBJECT SL " );
108 END;
109
110 EXCEPTION
111 WHEN CONSTRAINT_ERROR =>
112 NULL;
113 WHEN OTHERS =>
114 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
115 "SUBTYPE SUBLIM" );
116 END;
117
118 BEGIN
119 DECLARE
120 TYPE PARR IS ARRAY (1 .. 5) OF PRIV (IDENT_BOOL (TRUE));
121 BEGIN
122 DECLARE
123 PAR : PARR;
124 BEGIN
125 FAILED ( "NO EXCEPTION RAISED AT THE " &
126 "ELABORATION OF TYPE PARR " &
127 BOOLEAN'IMAGE(PAR(1).L));
128 END;
129 EXCEPTION
130 WHEN OTHERS =>
131 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
132 "OBJECT PAR" );
133 END;
134
135 EXCEPTION
136 WHEN CONSTRAINT_ERROR =>
137 NULL;
138 WHEN OTHERS =>
139 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
140 "TYPE PARR" );
141 END;
142
143 BEGIN
144 DECLARE
145 TYPE LARR IS ARRAY (1 .. 10) OF LIM (IDENT_BOOL (TRUE));
146 BEGIN
147 DECLARE
148 LAR : LARR;
149 BEGIN
150 FAILED ( "NO EXCEPTION RAISED AT THE " &
151 "ELABORATION OF TYPE LARR " &
152 BOOLEAN'IMAGE(LAR(1).L));
153 END;
154 EXCEPTION
155 WHEN OTHERS =>
156 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
157 "OBJECT LAR" );
158 END;
159
160 EXCEPTION
161 WHEN CONSTRAINT_ERROR =>
162 NULL;
163 WHEN OTHERS =>
164 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
165 "TYPE LARR" );
166 END;
167
168 BEGIN
169 DECLARE
170 TYPE PRIV1 IS
171 RECORD
172 X : PRIV (IDENT_BOOL (TRUE));
173 END RECORD;
174
175 BEGIN
176 DECLARE
177 P1 : PRIV1;
178 BEGIN
179 FAILED ( "NO EXCEPTION RAISED AT THE " &
180 "ELABORATION OF TYPE PRIV1 " &
181 BOOLEAN'IMAGE(P1.X.L));
182 END;
183 EXCEPTION
184 WHEN OTHERS =>
185 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
186 "OBJECT P1" );
187 END;
188
189 EXCEPTION
190 WHEN CONSTRAINT_ERROR =>
191 NULL;
192 WHEN OTHERS =>
193 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
194 "TYPE PRIV1" );
195 END;
196
197 BEGIN
198 DECLARE
199 TYPE LIM1 IS
200 RECORD
201 X : LIM (IDENT_BOOL (TRUE));
202 END RECORD;
203
204 BEGIN
205 DECLARE
206 L1 : LIM1;
207 BEGIN
208 FAILED ( "NO EXCEPTION RAISED AT THE " &
209 "ELABORATION OF TYPE LIM1 " &
210 BOOLEAN'IMAGE(L1.X.L));
211 END;
212 EXCEPTION
213 WHEN OTHERS =>
214 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
215 "OBJECT L1" );
216 END;
217
218 EXCEPTION
219 WHEN CONSTRAINT_ERROR =>
220 NULL;
221 WHEN OTHERS =>
222 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
223 "TYPE LIM1" );
224 END;
225
226 BEGIN
227 DECLARE
228 TYPE ACCPRIV IS ACCESS PRIV (IDENT_BOOL (TRUE));
229 BEGIN
230 DECLARE
231 ACP : ACCPRIV;
232 BEGIN
233 FAILED ( "NO EXCEPTION RAISED AT THE " &
234 "ELABORATION OF TYPE ACCPRIV " &
235 BOOLEAN'IMAGE(ACP.L));
236 END;
237 EXCEPTION
238 WHEN OTHERS =>
239 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
240 "OBJECT ACP" );
241 END;
242
243 EXCEPTION
244 WHEN CONSTRAINT_ERROR =>
245 NULL;
246 WHEN OTHERS =>
247 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
248 "TYPE ACCPRIV" );
249 END;
250
251 BEGIN
252 DECLARE
253 TYPE ACCLIM IS ACCESS LIM (IDENT_BOOL (TRUE));
254 BEGIN
255 DECLARE
256 ACL : ACCLIM;
257 BEGIN
258 FAILED ( "NO EXCEPTION RAISED AT THE " &
259 "ELABORATION OF TYPE ACCLIM " &
260 BOOLEAN'IMAGE(ACL.L));
261 END;
262 EXCEPTION
263 WHEN OTHERS =>
264 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
265 "OBJECT ACL" );
266 END;
267
268 EXCEPTION
269 WHEN CONSTRAINT_ERROR =>
270 NULL;
271 WHEN OTHERS =>
272 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
273 "TYPE ACCLIM" );
274 END;
275
276 BEGIN
277 DECLARE
278 TYPE NEWPRIV IS NEW PRIV (IDENT_BOOL (TRUE));
279 BEGIN
280 DECLARE
281 NP : NEWPRIV;
282 BEGIN
283 FAILED ( "NO EXCEPTION RAISED AT THE " &
284 "ELABORATION OF TYPE NEWPRIV " &
285 BOOLEAN'IMAGE(NP.L));
286 END;
287 EXCEPTION
288 WHEN OTHERS =>
289 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
290 "OBJECT NP" );
291 END;
292
293 EXCEPTION
294 WHEN CONSTRAINT_ERROR =>
295 NULL;
296 WHEN OTHERS =>
297 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
298 "TYPE NEWPRIV" );
299 END;
300
301 BEGIN
302 DECLARE
303 TYPE NEWLIM IS NEW LIM (IDENT_BOOL (TRUE));
304 BEGIN
305 DECLARE
306 NL : NEWLIM;
307 BEGIN
308 FAILED ( "NO EXCEPTION RAISED AT THE " &
309 "ELABORATION OF TYPE NEWLIM " &
310 BOOLEAN'IMAGE(NL.L));
311 END;
312 EXCEPTION
313 WHEN OTHERS =>
314 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
315 "OBJECT NL" );
316 END;
317
318 EXCEPTION
319 WHEN CONSTRAINT_ERROR =>
320 NULL;
321 WHEN OTHERS =>
322 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
323 "TYPE NEWLIM" );
324 END;
325
326 BEGIN
327 DECLARE
328 P : PRIV (IDENT_BOOL (TRUE));
329 BEGIN
330 FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " &
331 "P " & BOOLEAN'IMAGE(P.L));
332 EXCEPTION
333 WHEN OTHERS =>
334 FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
335 "CONTAINING P" );
336 END;
337
338 EXCEPTION
339 WHEN CONSTRAINT_ERROR =>
340 NULL;
341 WHEN OTHERS =>
342 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " &
343 "P" );
344 END;
345
346 BEGIN
347 DECLARE
348 L : LIM (IDENT_BOOL (TRUE));
349 BEGIN
350 FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " &
351 "L " & BOOLEAN'IMAGE(L.L));
352 EXCEPTION
353 WHEN OTHERS =>
354 FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
355 "CONTAINING L" );
356 END;
357
358 EXCEPTION
359 WHEN CONSTRAINT_ERROR =>
360 NULL;
361 WHEN OTHERS =>
362 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " &
363 "L" );
364 END;
365
366 BEGIN
367 DECLARE
368 TYPE PRIV_NAME IS ACCESS PRIV;
369 BEGIN
370 DECLARE
371 PN : PRIV_NAME := NEW PRIV (IDENT_BOOL (TRUE));
372 BEGIN
373 FAILED ( "NO EXCEPTION RAISED AT THE " &
374 "DECLARATION OF OBJECT PN " &
375 BOOLEAN'IMAGE(PN.L));
376 EXCEPTION
377 WHEN OTHERS =>
378 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
379 END;
380 EXCEPTION
381 WHEN CONSTRAINT_ERROR =>
382 NULL;
383 WHEN OTHERS =>
384 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
385 "OF OBJECT PN" );
386 END;
387 EXCEPTION
388 WHEN OTHERS =>
389 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
390 "PRIV_NAME" );
391 END;
392
393 BEGIN
394 DECLARE
395 TYPE LIM_NAME IS ACCESS LIM;
396 BEGIN
397 DECLARE
398 LN : LIM_NAME := NEW LIM (IDENT_BOOL (TRUE));
399 BEGIN
400 FAILED ( "NO EXCEPTION RAISED AT THE " &
401 "DECLARATION OF OBJECT LN " &
402 BOOLEAN'IMAGE(LN.L));
403 EXCEPTION
404 WHEN OTHERS =>
405 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
406 END;
407 EXCEPTION
408 WHEN CONSTRAINT_ERROR =>
409 NULL;
410 WHEN OTHERS =>
411 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
412 "OF OBJECT LN" );
413 END;
414 EXCEPTION
415 WHEN OTHERS =>
416 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
417 "LIM_NAME" );
418 END;
419
420 BEGIN
421 DECLARE
422 PACKAGE PP IS
423 TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS
424 PRIVATE;
425 PRIVATE
426 TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS
427 RECORD
428 NULL;
429 END RECORD;
430 END PP;
431
432 USE PP;
433 BEGIN
434 DECLARE
435 BP : BAD_PRIV;
436 BEGIN
437 FAILED ( "NO EXCEPTION RAISED AT THE " &
438 "DECLARATION OF OBJECT BP " &
439 BOOLEAN'IMAGE(BP.D));
440 EXCEPTION
441 WHEN OTHERS =>
442 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
443 END;
444 EXCEPTION
445 WHEN CONSTRAINT_ERROR =>
446 NULL;
447 WHEN OTHERS =>
448 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
449 "OF OBJECT BP" );
450 END;
451 EXCEPTION
452 WHEN OTHERS =>
453 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
454 "BAD_PRIV" );
455 END;
456
457 BEGIN
458 DECLARE
459 PACKAGE PL IS
460 TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS
461 LIMITED PRIVATE;
462 PRIVATE
463 TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS
464 RECORD
465 NULL;
466 END RECORD;
467 END PL;
468
469 USE PL;
470 BEGIN
471 DECLARE
472 BL : BAD_LIM;
473 BEGIN
474 FAILED ( "NO EXCEPTION RAISED AT THE " &
475 "DECLARATION OF OBJECT BL " &
476 BOOLEAN'IMAGE(BL.D));
477 EXCEPTION
478 WHEN OTHERS =>
479 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
480 END;
481 EXCEPTION
482 WHEN CONSTRAINT_ERROR =>
483 NULL;
484 WHEN OTHERS =>
485 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
486 "OF OBJECT BL" );
487 END;
488 EXCEPTION
489 WHEN OTHERS =>
490 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
491 "BAD_LIM" );
492 END;
493
494 RESULT;
495 END C37211B;