Mercurial > hg > CbC > CbC_gcc

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