Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c8/c85005e.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 -- C85005E.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 A VARIABLE CREATED BY AN ALLOCATOR CAN BE RENAMED AND
27 -- HAS THE CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN
28 -- ASSIGNMENT STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR
29 -- ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC
30 -- 'IN OUT' PARAMETER, AND THAT WHEN THE VALUE OF THE RENAMED
31 -- VARIABLE IS CHANGED, THE NEW VALUE IS REFLECTED BY THE VALUE OF
32 -- THE NEW NAME.
33
34 -- HISTORY:
35 -- JET 03/15/88 CREATED ORIGINAL TEST.
36
37 WITH REPORT; USE REPORT;
38 PROCEDURE C85005E IS
39
40 TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
41 TYPE RECORD1 (D : INTEGER) IS
42 RECORD
43 FIELD1 : INTEGER := 1;
44 END RECORD;
45 TYPE POINTER1 IS ACCESS INTEGER;
46
47 PACKAGE PACK1 IS
48 TYPE PACKACC IS ACCESS INTEGER;
49 AK1 : PACKACC := NEW INTEGER'(0);
50 TYPE PRIVY IS PRIVATE;
51 ZERO : CONSTANT PRIVY;
52 ONE : CONSTANT PRIVY;
53 TWO : CONSTANT PRIVY;
54 THREE : CONSTANT PRIVY;
55 FOUR : CONSTANT PRIVY;
56 FIVE : CONSTANT PRIVY;
57 FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
58 FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
59 PRIVATE
60 TYPE PRIVY IS RANGE 0..127;
61 ZERO : CONSTANT PRIVY := 0;
62 ONE : CONSTANT PRIVY := 1;
63 TWO : CONSTANT PRIVY := 2;
64 THREE : CONSTANT PRIVY := 3;
65 FOUR : CONSTANT PRIVY := 4;
66 FIVE : CONSTANT PRIVY := 5;
67 END PACK1;
68
69 TASK TYPE TASK1 IS
70 ENTRY ASSIGN (J : IN INTEGER);
71 ENTRY VALU (J : OUT INTEGER);
72 ENTRY NEXT;
73 ENTRY STOP;
74 END TASK1;
75
76 GENERIC
77 GI1 : IN OUT INTEGER;
78 GA1 : IN OUT ARRAY1;
79 GR1 : IN OUT RECORD1;
80 GP1 : IN OUT POINTER1;
81 GV1 : IN OUT PACK1.PRIVY;
82 GT1 : IN OUT TASK1;
83 GK1 : IN OUT INTEGER;
84 PACKAGE GENERIC1 IS
85 END GENERIC1;
86
87 FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
88 BEGIN
89 IF EQUAL (3,3) THEN
90 RETURN P;
91 ELSE
92 RETURN NULL;
93 END IF;
94 END IDENT;
95
96 PACKAGE BODY PACK1 IS
97 FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
98 BEGIN
99 IF EQUAL(3,3) THEN
100 RETURN I;
101 ELSE
102 RETURN PRIVY'(0);
103 END IF;
104 END IDENT;
105
106 FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
107 BEGIN
108 RETURN I+1;
109 END NEXT;
110 END PACK1;
111
112 PACKAGE BODY GENERIC1 IS
113 BEGIN
114 GI1 := GI1 + 1;
115 GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
116 GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
117 GP1 := NEW INTEGER'(GP1.ALL + 1);
118 GV1 := PACK1.NEXT(GV1);
119 GT1.NEXT;
120 GK1 := GK1 + 1;
121 END GENERIC1;
122
123 TASK BODY TASK1 IS
124 TASK_VALUE : INTEGER := 0;
125 ACCEPTING_ENTRIES : BOOLEAN := TRUE;
126 BEGIN
127 WHILE ACCEPTING_ENTRIES LOOP
128 SELECT
129 ACCEPT ASSIGN (J : IN INTEGER) DO
130 TASK_VALUE := J;
131 END ASSIGN;
132 OR
133 ACCEPT VALU (J : OUT INTEGER) DO
134 J := TASK_VALUE;
135 END VALU;
136 OR
137 ACCEPT NEXT DO
138 TASK_VALUE := TASK_VALUE + 1;
139 END NEXT;
140 OR
141 ACCEPT STOP DO
142 ACCEPTING_ENTRIES := FALSE;
143 END STOP;
144 END SELECT;
145 END LOOP;
146 END TASK1;
147
148 BEGIN
149 TEST ("C85005E", "CHECK THAT A VARIABLE CREATED BY AN ALLOCATOR " &
150 "CAN BE RENAMED AND HAS THE CORRECT VALUE, AND " &
151 "THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT" &
152 " STATEMENT AND PASSED ON AS AN ACTUAL " &
153 "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " &
154 "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " &
155 "PARAMETER, AND THAT WHEN THE VALUE OF THE " &
156 "RENAMED VARIABLE IS CHANGED, THE NEW VALUE " &
157 "IS REFLECTED BY THE VALUE OF THE NEW NAME");
158
159 DECLARE
160 TYPE ACCINT IS ACCESS INTEGER;
161 TYPE ACCARR IS ACCESS ARRAY1;
162 TYPE ACCREC IS ACCESS RECORD1;
163 TYPE ACCPTR IS ACCESS POINTER1;
164 TYPE ACCPVT IS ACCESS PACK1.PRIVY;
165 TYPE ACCTSK IS ACCESS TASK1;
166
167 AI1 : ACCINT := NEW INTEGER'(0);
168 AA1 : ACCARR := NEW ARRAY1'(0, 0, 0);
169 AR1 : ACCREC := NEW RECORD1'(D => 1, FIELD1 => 0);
170 AP1 : ACCPTR := NEW POINTER1'(NEW INTEGER'(0));
171 AV1 : ACCPVT := NEW PACK1.PRIVY'(PACK1.ZERO);
172 AT1 : ACCTSK := NEW TASK1;
173
174 XAI1 : INTEGER RENAMES AI1.ALL;
175 XAA1 : ARRAY1 RENAMES AA1.ALL;
176 XAR1 : RECORD1 RENAMES AR1.ALL;
177 XAP1 : POINTER1 RENAMES AP1.ALL;
178 XAV1 : PACK1.PRIVY RENAMES AV1.ALL;
179 XAK1 : INTEGER RENAMES PACK1.AK1.ALL;
180 XAT1 : TASK1 RENAMES AT1.ALL;
181
182 TASK TYPE TASK2 IS
183 ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
184 TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
185 TV1 : IN OUT PACK1.PRIVY;
186 TT1 : IN OUT TASK1; TK1 : IN OUT INTEGER);
187 END TASK2;
188
189 I : INTEGER;
190 A_CHK_TASK : TASK2;
191
192 PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1;
193 PR1 : IN OUT RECORD1; PP1 : OUT POINTER1;
194 PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1;
195 PK1 : OUT INTEGER) IS
196
197 BEGIN
198 PI1 := PI1 + 1;
199 PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
200 PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
201 PP1 := NEW INTEGER'(AP1.ALL.ALL + 1);
202 PV1 := PACK1.NEXT(AV1.ALL);
203 PT1.NEXT;
204 PK1 := PACK1.AK1.ALL + 1;
205 END PROC1;
206
207 TASK BODY TASK2 IS
208 BEGIN
209 ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
210 TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
211 TV1 : IN OUT PACK1.PRIVY;
212 TT1 : IN OUT TASK1;
213 TK1 : IN OUT INTEGER) DO
214 TI1 := AI1.ALL + 1;
215 TA1 := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1);
216 TR1 := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1);
217 TP1 := NEW INTEGER'(TP1.ALL + 1);
218 TV1 := PACK1.NEXT(TV1);
219 TT1.NEXT;
220 TK1 := TK1 + 1;
221 END ENTRY1;
222 END TASK2;
223
224 PACKAGE GENPACK2 IS NEW
225 GENERIC1 (XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1);
226
227 BEGIN
228 IF XAI1 /= IDENT_INT(1) THEN
229 FAILED ("INCORRECT VALUE OF XAI1 (1)");
230 END IF;
231
232 IF XAA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
233 FAILED ("INCORRECT VALUE OF XAA1 (1)");
234 END IF;
235
236 IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
237 FAILED ("INCORRECT VALUE OF XAR1 (1)");
238 END IF;
239
240 IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(1) THEN
241 FAILED ("INCORRECT VALUE OF XAP1 (1)");
242 END IF;
243
244 IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.ONE)) THEN
245 FAILED ("INCORRECT VALUE OF XAV1 (1)");
246 END IF;
247
248 XAT1.VALU(I);
249 IF I /= IDENT_INT(1) THEN
250 FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (1)");
251 END IF;
252
253 IF XAK1 /= IDENT_INT(1) THEN
254 FAILED ("INCORRECT VALUE OF XAK1 (1)");
255 END IF;
256
257 PROC1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1);
258
259 IF XAI1 /= IDENT_INT(2) THEN
260 FAILED ("INCORRECT VALUE OF XAI1 (2)");
261 END IF;
262
263 IF XAA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
264 FAILED ("INCORRECT VALUE OF XAA1 (2)");
265 END IF;
266
267 IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
268 FAILED ("INCORRECT VALUE OF XAR1 (2)");
269 END IF;
270
271 IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(2) THEN
272 FAILED ("INCORRECT VALUE OF XAP1 (2)");
273 END IF;
274
275 IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.TWO)) THEN
276 FAILED ("INCORRECT VALUE OF XAV1 (2)");
277 END IF;
278
279 XAT1.VALU(I);
280 IF I /= IDENT_INT(2) THEN
281 FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (2)");
282 END IF;
283
284 IF XAK1 /= IDENT_INT(2) THEN
285 FAILED ("INCORRECT VALUE OF XAK1 (2)");
286 END IF;
287
288 A_CHK_TASK.ENTRY1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1);
289
290 IF XAI1 /= IDENT_INT(3) THEN
291 FAILED ("INCORRECT VALUE OF XAI1 (3)");
292 END IF;
293
294 IF XAA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
295 FAILED ("INCORRECT VALUE OF XAA1 (3)");
296 END IF;
297
298 IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
299 FAILED ("INCORRECT VALUE OF XAR1 (3)");
300 END IF;
301
302 IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(3) THEN
303 FAILED ("INCORRECT VALUE OF XAP1 (3)");
304 END IF;
305
306 IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.THREE)) THEN
307 FAILED ("INCORRECT VALUE OF XAV1 (3)");
308 END IF;
309
310 XAT1.VALU(I);
311 IF I /= IDENT_INT(3) THEN
312 FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (3)");
313 END IF;
314
315 IF XAK1 /= IDENT_INT(3) THEN
316 FAILED ("INCORRECT VALUE OF XAK1 (3)");
317 END IF;
318
319 XAI1 := XAI1 + 1;
320 XAA1 := (XAA1(1)+1, XAA1(2)+1, XAA1(3)+1);
321 XAR1 := (D => 1, FIELD1 => XAR1.FIELD1 + 1);
322 XAP1 := NEW INTEGER'(XAP1.ALL + 1);
323 XAV1 := PACK1.NEXT(XAV1);
324 XAT1.NEXT;
325 XAK1 := XAK1 + 1;
326
327 IF XAI1 /= IDENT_INT(4) THEN
328 FAILED ("INCORRECT VALUE OF XAI1 (4)");
329 END IF;
330
331 IF XAA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
332 FAILED ("INCORRECT VALUE OF XAA1 (4)");
333 END IF;
334
335 IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
336 FAILED ("INCORRECT VALUE OF XAR1 (4)");
337 END IF;
338
339 IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(4) THEN
340 FAILED ("INCORRECT VALUE OF XAP1 (4)");
341 END IF;
342
343 IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FOUR)) THEN
344 FAILED ("INCORRECT VALUE OF XAV1 (4)");
345 END IF;
346
347 XAT1.VALU(I);
348 IF I /= IDENT_INT(4) THEN
349 FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (4)");
350 END IF;
351
352 IF XAK1 /= IDENT_INT(4) THEN
353 FAILED ("INCORRECT VALUE OF XAK1 (4)");
354 END IF;
355
356 AI1.ALL := AI1.ALL + 1;
357 AA1.ALL := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1);
358 AR1.ALL := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1);
359 AP1.ALL := NEW INTEGER'(AP1.ALL.ALL + 1);
360 AV1.ALL := PACK1.NEXT(AV1.ALL);
361 AT1.NEXT;
362 PACK1.AK1.ALL := PACK1.AK1.ALL + 1;
363
364 IF XAI1 /= IDENT_INT(5) THEN
365 FAILED ("INCORRECT VALUE OF XAI1 (5)");
366 END IF;
367
368 IF XAA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
369 FAILED ("INCORRECT VALUE OF XAA1 (5)");
370 END IF;
371
372 IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
373 FAILED ("INCORRECT VALUE OF XAR1 (5)");
374 END IF;
375
376 IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(5) THEN
377 FAILED ("INCORRECT VALUE OF XAP1 (5)");
378 END IF;
379
380 IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FIVE)) THEN
381 FAILED ("INCORRECT VALUE OF XAV1 (5)");
382 END IF;
383
384 XAT1.VALU(I);
385 IF I /= IDENT_INT(5) THEN
386 FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (5)");
387 END IF;
388
389 IF XAK1 /= IDENT_INT(5) THEN
390 FAILED ("INCORRECT VALUE OF XAK1 (5)");
391 END IF;
392
393 AT1.STOP;
394 END;
395
396 RESULT;
397 END C85005E;