Mercurial > hg > CbC > CbC_gcc

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