Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c37213h.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 -- C37213H.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 -- OBJECTIVE:
26 -- CHECK, WHERE AN INDEX CONSTRAINT DEPENDS ON A RECORD
27 -- DISCRIMINANT WITH A DEFAULT VALUE AND THE RECORD TYPE IS NOT
28 -- EXPLICITLY CONSTRAINED, THAT THE NON-DISCRIMINANT EXPRESSIONS
29 -- IN THE INDEX CONSTRAINT ARE:
30 -- 1) EVALUATED WHEN THE RECORD COMPONENT SUBTYPE DEFINITION
31 -- IS ELABORATED,
32 -- 2) PROPERLY CHECKED FOR COMPATIBILITY ONLY IN AN ALLOCATION
33 -- OR OBJECT DECLARATION AND ONLY IF THE DISCRIMINANT-
34 -- DEPENDENT COMPONENT IS PRESENT IN THE SUBTYPE.
35
36 -- HISTORY:
37 -- JBG 10/17/86 CREATED ORIGINAL TEST.
38 -- VCL 10/23/87 MODIFIED THIS HEADER; MODIFIED THE CHECK OF
39 -- SUBTYPE 'SCONS', IN BOTH SUBPARTS OF THE TEST,
40 -- TO INDICATE FAILURE IF CONSTRAINT_ERROR IS RAISED
41 -- FOR THE SUBTYPE DECLARATION AND FAILURE IF
42 -- CONSTRAINT_ERROR IS NOT RAISED FOR AN OBJECT
43 -- DECLARATION OF THIS SUBTYPE; RELOCATED THE CALL TO
44 -- REPORT.TEST SO THAT IT COMES BEFORE ANY
45 -- DECLARATIONS; ADDED 'SEQUENCE_NUMBER' TO IDENTIFY
46 -- THE CURRENT SUBTEST (FOR EXCEPTIONS); CHANGE THE
47 -- TYPE OF THE DISCRIMINANT IN THE RECORD 'CONS'
48 -- TO AN INTEGER SUBTYPE.
49 -- VCL 03/30/88 MODIFIED HEADER AND MESSAGES OUTPUT BY REPORT
50 -- PACKAGE.
51
52 WITH REPORT; USE REPORT;
53 PROCEDURE C37213H IS
54 BEGIN
55 TEST ("C37213H", "THE NON-DISCRIMINANT EXPRESSIONS OF AN " &
56 "INDEX CONSTRAINT THAT DEPEND ON A " &
57 "DISCRIMINANT WITH A DEFAULT VALUE ARE " &
58 "PROPERLY EVALUATED AND CHECKED WHEN THE " &
59 "RECORD TYPE IS NOT EXPLICITLY CONSTRAINED AND " &
60 "THE COMPONENT IS AND IS NOT PRESENT IN THE " &
61 "SUBTYPE");
62
63 DECLARE
64 SEQUENCE_NUMBER : INTEGER;
65
66 SUBTYPE DISCR IS INTEGER RANGE -50..50;
67 SUBTYPE SM IS INTEGER RANGE 1..10;
68 TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
69
70 F1_CONS : INTEGER := 2;
71
72 FUNCTION CHK (
73 CONS : INTEGER;
74 VALUE : INTEGER;
75 MESSAGE : STRING) RETURN BOOLEAN IS
76 BEGIN
77 IF CONS /= VALUE THEN
78 FAILED (MESSAGE & ": F1_CONS IS " &
79 INTEGER'IMAGE(F1_CONS));
80 END IF;
81 RETURN TRUE;
82 END CHK;
83
84 FUNCTION F1 RETURN INTEGER IS
85 BEGIN
86 F1_CONS := F1_CONS - IDENT_INT(1);
87 RETURN F1_CONS;
88 END F1;
89 BEGIN
90
91
92 -- CASE 1: DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT.
93
94 SEQUENCE_NUMBER :=1;
95 DECLARE
96 TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS
97 RECORD
98 CASE D3 IS
99 WHEN -5..10 =>
100 C1 : MY_ARR(F1..D3); -- F1 EVALUATED.
101 WHEN OTHERS =>
102 C2 : INTEGER := IDENT_INT(0);
103 END CASE;
104 END RECORD;
105
106 CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
107
108 X : CONS; -- F1 NOT EVALUATED AGAIN.
109 Y : CONS; -- F1 NOT EVALUATED AGAIN.
110
111 CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
112 BEGIN
113 IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN
114 FAILED ("VALUES NOT CORRECT");
115 END IF;
116 END;
117
118
119 F1_CONS := 12;
120
121 SEQUENCE_NUMBER := 2;
122 DECLARE
123 TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS
124 RECORD
125 CASE D3 IS
126 WHEN -5..10 =>
127 C1 : MY_ARR(D3..F1);
128 WHEN OTHERS =>
129 C2 : INTEGER := IDENT_INT(0);
130 END CASE;
131 END RECORD;
132 BEGIN
133 BEGIN
134 DECLARE
135 X : CONS;
136 BEGIN
137 FAILED ("INDEX CHECK NOT PERFORMED - 1");
138 IF X /= (1, (1, 1)) THEN
139 COMMENT ("INCORRECT VALUES FOR X - 1");
140 END IF;
141 END;
142 EXCEPTION
143 WHEN CONSTRAINT_ERROR =>
144 NULL;
145 WHEN OTHERS =>
146 FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
147 END;
148
149 BEGIN
150 DECLARE
151 SUBTYPE SCONS IS CONS;
152 BEGIN
153 DECLARE
154 X : SCONS;
155 BEGIN
156 FAILED ("INDEX CHECK NOT PERFORMED - 2");
157 IF X /= (1, (1, 1)) THEN
158 COMMENT ("INCORRECT VALUES FOR X " &
159 "- 2");
160 END IF;
161 END;
162 EXCEPTION
163 WHEN CONSTRAINT_ERROR =>
164 NULL;
165 WHEN OTHERS =>
166 FAILED ("UNEXPECTED EXCEPTION RAISED " &
167 "- 2A");
168 END;
169 EXCEPTION
170 WHEN OTHERS =>
171 FAILED ("UNEXPECTED EXCEPTION RAISED - 2B");
172 END;
173
174 BEGIN
175 DECLARE
176 TYPE ARR IS ARRAY (1..5) OF CONS;
177 BEGIN
178 DECLARE
179 X : ARR;
180 BEGIN
181 FAILED ("INDEX CHECK NOT PERFORMED - 3");
182 IF X /= (1..5 => (1, (1, 1))) THEN
183 COMMENT ("INCORRECT VALUES FOR X " &
184 "- 3");
185 END IF;
186 END;
187 EXCEPTION
188 WHEN CONSTRAINT_ERROR =>
189 NULL;
190 WHEN OTHERS =>
191 FAILED ("UNEXPECTED EXCEPTION RAISED " &
192 "- 3A");
193 END;
194 EXCEPTION
195 WHEN OTHERS =>
196 FAILED ("UNEXPECTED EXCEPTION RAISED - 3B");
197 END;
198
199 BEGIN
200 DECLARE
201 TYPE NREC IS
202 RECORD
203 C1 : CONS;
204 END RECORD;
205 BEGIN
206 DECLARE
207 X : NREC;
208 BEGIN
209 FAILED ("INDEX CHECK NOT PERFORMED - 4");
210 IF X /= (C1 => (1, (1, 1))) THEN
211 COMMENT ("INCORRECT VALUES FOR X " &
212 "- 4");
213 END IF;
214 END;
215 EXCEPTION
216 WHEN CONSTRAINT_ERROR =>
217 NULL;
218 WHEN OTHERS =>
219 FAILED ("UNEXPECTED EXCEPTION RAISED " &
220 "- 4A");
221 END;
222 EXCEPTION
223 WHEN OTHERS =>
224 FAILED ("UNEXPECTED EXCEPTION RAISED - 4B");
225 END;
226
227 BEGIN
228 DECLARE
229 TYPE NREC IS NEW CONS;
230 BEGIN
231 DECLARE
232 X : NREC;
233 BEGIN
234 FAILED ("INDEX CHECK NOT PERFORMED - 5");
235 IF X /= (1, (1, 1)) THEN
236 COMMENT ("INCORRECT VALUES FOR X " &
237 "- 5");
238 END IF;
239 END;
240 EXCEPTION
241 WHEN CONSTRAINT_ERROR =>
242 NULL;
243 WHEN OTHERS =>
244 FAILED ("UNEXPECTED EXCEPTION RAISED " &
245 "- 5A");
246 END;
247 EXCEPTION
248 WHEN OTHERS =>
249 FAILED ("UNEXPECTED EXCEPTION RAISED - 5B");
250 END;
251
252 BEGIN
253 DECLARE
254 TYPE ACC_CONS IS ACCESS CONS;
255 BEGIN
256 DECLARE
257 X : ACC_CONS;
258 BEGIN
259 X := NEW CONS;
260 FAILED ("INDEX CHECK NOT PERFORMED - 6");
261 IF X.ALL /= (1, (1, 1)) THEN
262 COMMENT ("INCORRECT VALUES FOR X " &
263 "- 6");
264 END IF;
265 EXCEPTION
266 WHEN CONSTRAINT_ERROR =>
267 NULL;
268 WHEN OTHERS =>
269 COMMENT ("UNEXPECTED EXCEPTION " &
270 "RAISED - 6A");
271 END;
272 EXCEPTION
273 WHEN OTHERS =>
274 COMMENT ("UNEXPECTED EXCEPTION RAISED " &
275 "- 6B");
276 END;
277 EXCEPTION
278 WHEN OTHERS =>
279 FAILED ("UNEXPECTED EXCEPTION RAISED - 6C");
280 END;
281 END;
282
283
284 -- CASE D2: DISCRIMINANT-DEPENDENT COMPONENT IS ABSENT.
285
286 F1_CONS := 2;
287
288 SEQUENCE_NUMBER := 3;
289 DECLARE
290 TYPE CONS (D3 : DISCR := IDENT_INT(-6)) IS
291 RECORD
292 CASE D3 IS
293 WHEN -5..10 =>
294 C1 : MY_ARR(D3..F1); -- F1 EVALUATED.
295 WHEN OTHERS =>
296 C2 : INTEGER := IDENT_INT(0);
297 END CASE;
298 END RECORD;
299 CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
300
301 X : CONS; -- F1 NOT EVALUATED AGAIN.
302 Y : CONS; -- F1 NOT EVALUATED AGAIN.
303
304 CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
305 BEGIN
306 IF X /= (-6, 0) OR Y /= (-6, 0) THEN
307 FAILED ("VALUES NOT CORRECT");
308 END IF;
309 END;
310
311 F1_CONS := 12;
312
313 SEQUENCE_NUMBER := 4;
314 DECLARE
315 TYPE CONS (D3 : DISCR := IDENT_INT(11)) IS
316 RECORD
317 CASE D3 IS
318 WHEN -5..10 =>
319 C1 : MY_ARR(D3..F1);
320 WHEN OTHERS =>
321 C2 : INTEGER := IDENT_INT(0);
322 END CASE;
323 END RECORD;
324 BEGIN
325 BEGIN
326 DECLARE
327 X : CONS;
328 BEGIN
329 IF X /= (11, 0) THEN
330 FAILED ("X VALUE IS INCORRECT - 11");
331 END IF;
332 END;
333 EXCEPTION
334 WHEN OTHERS =>
335 FAILED ("UNEXPECTED EXCEPTION RAISED - 11");
336 END;
337
338 BEGIN
339 DECLARE
340 SUBTYPE SCONS IS CONS;
341 BEGIN
342 DECLARE
343 X : SCONS;
344 BEGIN
345 IF X /= (11, 0) THEN
346 FAILED ("X VALUE INCORRECT - 12");
347 END IF;
348 END;
349 EXCEPTION
350 WHEN OTHERS =>
351 FAILED ("UNEXPECTED EXCEPTION RAISED - " &
352 "12A");
353 END;
354 EXCEPTION
355 WHEN OTHERS =>
356 FAILED ("UNEXPECTED EXCEPTION RAISED - 12B");
357 END;
358
359 BEGIN
360 DECLARE
361 TYPE ARR IS ARRAY (1..5) OF CONS;
362 BEGIN
363 DECLARE
364 X : ARR;
365 BEGIN
366 IF X /= (1..5 => (11, 0)) THEN
367 FAILED ("X VALUE INCORRECT - 13");
368 END IF;
369 END;
370 EXCEPTION
371 WHEN OTHERS =>
372 FAILED ("UNEXPECTED EXCEPTION RAISED - " &
373 "13A");
374 END;
375 EXCEPTION
376 WHEN OTHERS =>
377 FAILED ("UNEXPECTED EXCEPTION RAISED - 13B");
378 END;
379
380 BEGIN
381 DECLARE
382 TYPE NREC IS
383 RECORD
384 C1 : CONS;
385 END RECORD;
386 BEGIN
387 DECLARE
388 X : NREC;
389 BEGIN
390 IF X /= (C1 => (11, 0)) THEN
391 FAILED ("X VALUE INCORRECT - 14");
392 END IF;
393 END;
394 EXCEPTION
395 WHEN OTHERS =>
396 FAILED ("UNEXPECTED EXCEPTION RAISED - " &
397 "14A");
398 END;
399 EXCEPTION
400 WHEN OTHERS =>
401 FAILED ("UNEXPECTED EXCEPTION RAISED - 14B");
402 END;
403
404 BEGIN
405 DECLARE
406 TYPE NREC IS NEW CONS;
407 BEGIN
408 DECLARE
409 X : NREC;
410 BEGIN
411 IF X /= (11, 0) THEN
412 FAILED ("X VALUE INCORRECT - 15");
413 END IF;
414 END;
415 EXCEPTION
416 WHEN CONSTRAINT_ERROR =>
417 NULL;
418 WHEN OTHERS =>
419 FAILED ("UNEXPECTED EXCEPTION RAISED - " &
420 "15A");
421 END;
422 EXCEPTION
423 WHEN OTHERS =>
424 FAILED ("UNEXPECTED EXCEPTION RAISED - 15B");
425 END;
426
427 BEGIN
428 DECLARE
429 TYPE ACC_CONS IS ACCESS CONS;
430 X : ACC_CONS;
431 BEGIN
432 X := NEW CONS;
433 IF X.ALL /= (11, 0) THEN
434 FAILED ("X VALUE INCORRECT - 17");
435 END IF;
436 EXCEPTION
437 WHEN OTHERS =>
438 FAILED ("UNEXPECTED EXCEPTION RAISED - " &
439 "17A");
440 END;
441 EXCEPTION
442 WHEN OTHERS =>
443 FAILED ("UNEXPECTED EXCEPTION RAISED - 17B");
444 END;
445 END;
446
447 EXCEPTION
448 WHEN CONSTRAINT_ERROR =>
449 FAILED ("INDEX VALUES IMPROPERLY CHECKED - " &
450 INTEGER'IMAGE (SEQUENCE_NUMBER));
451 WHEN OTHERS =>
452 FAILED ("UNEXPECTED EXCEPTION RAISED " &
453 INTEGER'IMAGE (SEQUENCE_NUMBER));
454 END;
455
456 RESULT;
457 END C37213H;