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
37WITH REPORT; USE REPORT;
38PROCEDURE 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
148BEGIN
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;
397END C85005E;
398