Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c34005u.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 -- C34005U.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 -- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS
27 -- A LIMITED TYPE:
28
29 -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
30 -- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
31 -- IS CONSTRAINED.
32
33 -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
34 -- ALSO IMPOSED ON THE DERIVED SUBTYPE.
35
36 -- HISTORY:
37 -- JRK 08/21/87 CREATED ORIGINAL TEST.
38
39 WITH REPORT; USE REPORT;
40
41 PROCEDURE C34005U IS
42
43 PACKAGE PKG_L IS
44
45 TYPE LP IS LIMITED PRIVATE;
46
47 FUNCTION CREATE (X : INTEGER) RETURN LP;
48
49 FUNCTION VALUE (X : LP) RETURN INTEGER;
50
51 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
52
53 PROCEDURE ASSIGN (X : OUT LP; Y : LP);
54
55 C1 : CONSTANT LP;
56 C2 : CONSTANT LP;
57 C3 : CONSTANT LP;
58 C4 : CONSTANT LP;
59 C5 : CONSTANT LP;
60 C6 : CONSTANT LP;
61 C7 : CONSTANT LP;
62 C8 : CONSTANT LP;
63
64 PRIVATE
65
66 TYPE LP IS NEW INTEGER;
67
68 C1 : CONSTANT LP := 1;
69 C2 : CONSTANT LP := 2;
70 C3 : CONSTANT LP := 3;
71 C4 : CONSTANT LP := 4;
72 C5 : CONSTANT LP := 5;
73 C6 : CONSTANT LP := 6;
74 C7 : CONSTANT LP := 7;
75 C8 : CONSTANT LP := 8;
76
77 END PKG_L;
78
79 USE PKG_L;
80
81 SUBTYPE COMPONENT IS LP;
82
83 PACKAGE PKG_P IS
84
85 FIRST : CONSTANT := 0;
86 LAST : CONSTANT := 10;
87
88 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
89
90 TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
91 COMPONENT;
92
93 FUNCTION CREATE ( F1, L1 : INDEX;
94 F2, L2 : INDEX;
95 C : COMPONENT;
96 DUMMY : PARENT -- TO RESOLVE OVERLOADING.
97 ) RETURN PARENT;
98
99 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
100
101 FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
102 RETURN PARENT;
103
104 END PKG_P;
105
106 USE PKG_P;
107
108 TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
109 IDENT_INT (6) .. IDENT_INT (8));
110
111 SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8);
112
113 TYPE S IS NEW SUBPARENT;
114
115 X : T;
116 Y : S;
117
118 PACKAGE BODY PKG_L IS
119
120 FUNCTION CREATE (X : INTEGER) RETURN LP IS
121 BEGIN
122 RETURN LP (IDENT_INT (X));
123 END CREATE;
124
125 FUNCTION VALUE (X : LP) RETURN INTEGER IS
126 BEGIN
127 RETURN INTEGER (X);
128 END VALUE;
129
130 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
131 BEGIN
132 RETURN X = Y;
133 END EQUAL;
134
135 PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
136 BEGIN
137 X := Y;
138 END ASSIGN;
139
140 END PKG_L;
141
142 PACKAGE BODY PKG_P IS
143
144 FUNCTION CREATE
145 ( F1, L1 : INDEX;
146 F2, L2 : INDEX;
147 C : COMPONENT;
148 DUMMY : PARENT
149 ) RETURN PARENT
150 IS
151 A : PARENT (F1 .. L1, F2 .. L2);
152 B : COMPONENT;
153 BEGIN
154 ASSIGN (B, C);
155 FOR I IN F1 .. L1 LOOP
156 FOR J IN F2 .. L2 LOOP
157 ASSIGN (A (I, J), B);
158 ASSIGN (B, CREATE (VALUE (B) + 1));
159 END LOOP;
160 END LOOP;
161 RETURN A;
162 END CREATE;
163
164 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
165 BEGIN
166 IF X'LENGTH /= Y'LENGTH OR
167 X'LENGTH(2) /= Y'LENGTH(2) THEN
168 RETURN FALSE;
169 ELSE FOR I IN X'RANGE LOOP
170 FOR J IN X'RANGE(2) LOOP
171 IF NOT EQUAL (X (I, J),
172 Y (I - X'FIRST + Y'FIRST,
173 J - X'FIRST(2) +
174 Y'FIRST(2))) THEN
175 RETURN FALSE;
176 END IF;
177 END LOOP;
178 END LOOP;
179 END IF;
180 RETURN TRUE;
181 END EQUAL;
182
183 FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
184 RETURN PARENT IS
185 X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3,
186 INDEX'FIRST .. INDEX'FIRST + 1);
187 BEGIN
188 ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A);
189 ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B);
190 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C);
191 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D);
192 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E);
193 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F);
194 ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G);
195 ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H);
196 RETURN X;
197 END AGGR;
198
199 END PKG_P;
200
201 PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS
202 BEGIN
203 FOR I IN X'RANGE LOOP
204 FOR J IN X'RANGE(2) LOOP
205 ASSIGN (X (I, J), Y (I, J));
206 END LOOP;
207 END LOOP;
208 END ASSIGN;
209
210 PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS
211 BEGIN
212 FOR I IN X'RANGE LOOP
213 FOR J IN X'RANGE(2) LOOP
214 ASSIGN (X (I, J), Y (I, J));
215 END LOOP;
216 END LOOP;
217 END ASSIGN;
218
219 BEGIN
220 TEST ("C34005U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
221 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
222 "WHEN THE DERIVED TYPE DEFINITION IS " &
223 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
224 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
225 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
226 "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
227 "TYPE IS A LIMITED TYPE");
228
229 FOR I IN X'RANGE LOOP
230 FOR J IN X'RANGE(2) LOOP
231 ASSIGN (X (I, J), C2);
232 ASSIGN (Y (I, J), C2);
233 END LOOP;
234 END LOOP;
235
236 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
237 BEGIN
238 IF NOT EQUAL (CREATE (6, 9, 2, 3, C1, X),
239 AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) OR
240 NOT EQUAL (CREATE (6, 9, 2, 3, C1, Y),
241 AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) THEN
242 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
243 "SUBTYPE");
244 END IF;
245 EXCEPTION
246 WHEN CONSTRAINT_ERROR =>
247 FAILED ("CONSTRAINT_ERROR WHEN TRYING TO CREATE BASE " &
248 "TYPE VALUES OUTSIDE THE SUBTYPE");
249 WHEN OTHERS =>
250 FAILED ("EXCEPTION WHEN TRYING TO CREATE BASE TYPE " &
251 "VALUES OUTSIDE THE SUBTYPE");
252 END;
253
254 IF AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN T OR
255 AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN S THEN
256 FAILED ("INCORRECT ""IN""");
257 END IF;
258
259 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
260
261 IF T'FIRST /= 4 OR T'LAST /= 5 OR
262 S'FIRST /= 4 OR S'LAST /= 5 OR
263 T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR
264 S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN
265 FAILED ("INCORRECT 'FIRST OR 'LAST");
266 END IF;
267
268 BEGIN
269 ASSIGN (X, CREATE (4, 5, 6, 8, C1, X));
270 ASSIGN (Y, CREATE (4, 5, 6, 8, C1, Y));
271 IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y.
272 FAILED ("INCORRECT CONVERSION TO PARENT");
273 END IF;
274 EXCEPTION
275 WHEN OTHERS =>
276 FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
277 END;
278
279 BEGIN
280 ASSIGN (X, CREATE (4, 4, 6, 8, C1, X));
281 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
282 "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))");
283 IF EQUAL (X, CREATE (4, 4, 6, 8, C1, X)) THEN -- USE X.
284 COMMENT ("X ALTERED -- " &
285 "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))");
286 END IF;
287 EXCEPTION
288 WHEN CONSTRAINT_ERROR =>
289 NULL;
290 WHEN OTHERS =>
291 FAILED ("WRONG EXCEPTION RAISED -- " &
292 "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))");
293 END;
294
295 BEGIN
296 ASSIGN (X, CREATE (4, 6, 6, 8, C1, X));
297 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
298 "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))");
299 IF EQUAL (X, CREATE (4, 6, 6, 8, C1, X)) THEN -- USE X.
300 COMMENT ("X ALTERED -- " &
301 "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))");
302 END IF;
303 EXCEPTION
304 WHEN CONSTRAINT_ERROR =>
305 NULL;
306 WHEN OTHERS =>
307 FAILED ("WRONG EXCEPTION RAISED -- " &
308 "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))");
309 END;
310
311 BEGIN
312 ASSIGN (X, CREATE (4, 5, 6, 7, C1, X));
313 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
314 "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))");
315 IF EQUAL (X, CREATE (4, 5, 6, 7, C1, X)) THEN -- USE X.
316 COMMENT ("X ALTERED -- " &
317 "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))");
318 END IF;
319 EXCEPTION
320 WHEN CONSTRAINT_ERROR =>
321 NULL;
322 WHEN OTHERS =>
323 FAILED ("WRONG EXCEPTION RAISED -- " &
324 "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))");
325 END;
326
327 BEGIN
328 ASSIGN (X, CREATE (4, 5, 6, 9, C1, X));
329 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
330 "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))");
331 IF EQUAL (X, CREATE (4, 5, 6, 9, C1, X)) THEN -- USE X.
332 COMMENT ("X ALTERED -- " &
333 "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))");
334 END IF;
335 EXCEPTION
336 WHEN CONSTRAINT_ERROR =>
337 NULL;
338 WHEN OTHERS =>
339 FAILED ("WRONG EXCEPTION RAISED -- " &
340 "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))");
341 END;
342
343 BEGIN
344 ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y));
345 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
346 "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))");
347 IF EQUAL (Y, CREATE (4, 4, 6, 8, C1, Y)) THEN -- USE Y.
348 COMMENT ("Y ALTERED -- " &
349 "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))");
350 END IF;
351 EXCEPTION
352 WHEN CONSTRAINT_ERROR =>
353 NULL;
354 WHEN OTHERS =>
355 FAILED ("WRONG EXCEPTION RAISED -- " &
356 "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))");
357 END;
358
359 BEGIN
360 ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y));
361 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
362 "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))");
363 IF EQUAL (Y, CREATE (4, 6, 6, 8, C1, Y)) THEN -- USE Y.
364 COMMENT ("Y ALTERED -- " &
365 "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))");
366 END IF;
367 EXCEPTION
368 WHEN CONSTRAINT_ERROR =>
369 NULL;
370 WHEN OTHERS =>
371 FAILED ("WRONG EXCEPTION RAISED -- " &
372 "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))");
373 END;
374
375 BEGIN
376 ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y));
377 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
378 "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))");
379 IF EQUAL (Y, CREATE (4, 5, 6, 7, C1, Y)) THEN -- USE Y.
380 COMMENT ("Y ALTERED -- " &
381 "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))");
382 END IF;
383 EXCEPTION
384 WHEN CONSTRAINT_ERROR =>
385 NULL;
386 WHEN OTHERS =>
387 FAILED ("WRONG EXCEPTION RAISED -- " &
388 "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))");
389 END;
390
391 BEGIN
392 ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y));
393 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
394 "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))");
395 IF EQUAL (Y, CREATE (4, 5, 6, 9, C1, Y)) THEN -- USE Y.
396 COMMENT ("Y ALTERED -- " &
397 "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))");
398 END IF;
399 EXCEPTION
400 WHEN CONSTRAINT_ERROR =>
401 NULL;
402 WHEN OTHERS =>
403 FAILED ("WRONG EXCEPTION RAISED -- " &
404 "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))");
405 END;
406
407 RESULT;
408 END C34005U;