Mercurial > hg > CbC > CbC_gcc

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