111
|
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;
|