1-- C85005D.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 GENERIC 'IN OUT' FORMAL
27--     PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND
28--     THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND
29--     PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT'
30--     PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER,
31--     AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED,
32--     THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME.
33
34-- HISTORY:
35--     JET 03/15/88  CREATED ORIGINAL TEST.
36
37WITH REPORT; USE REPORT;
38PROCEDURE C85005D 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          XGI1 : INTEGER RENAMES GI1;
120          XGA1 : ARRAY1 RENAMES GA1;
121          XGR1 : RECORD1 RENAMES GR1;
122          XGP1 : POINTER1 RENAMES GP1;
123          XGV1 : PACK1.PRIVY RENAMES GV1;
124          XGT1 : TASK1 RENAMES GT1;
125
126          TASK TYPE TASK2 IS
127               ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
128                             TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
129                             TV1 : IN OUT PACK1.PRIVY;
130                             TT1 : IN OUT TASK1);
131          END TASK2;
132
133          G_CHK_TASK : TASK2;
134
135          GENERIC
136               GGI1 : IN OUT INTEGER;
137               GGA1 : IN OUT ARRAY1;
138               GGR1 : IN OUT RECORD1;
139               GGP1 : IN OUT POINTER1;
140               GGV1 : IN OUT PACK1.PRIVY;
141               GGT1 : IN OUT TASK1;
142          PACKAGE GENERIC2 IS
143          END GENERIC2;
144
145          PACKAGE BODY GENERIC2 IS
146          BEGIN
147               GGI1 := GGI1 + 1;
148               GGA1 := (GGA1(1)+1, GGA1(2)+1, GGA1(3)+1);
149               GGR1 := (D => 1, FIELD1 => GGR1.FIELD1 + 1);
150               GGP1 := NEW INTEGER'(GGP1.ALL + 1);
151               GGV1 := PACK1.NEXT(GGV1);
152               GGT1.NEXT;
153          END GENERIC2;
154
155          TASK BODY TASK2 IS
156          BEGIN
157               ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
158                              TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
159                              TV1 : IN OUT PACK1.PRIVY;
160                              TT1 : IN OUT TASK1)
161               DO
162                    TI1 := GI1 + 1;
163                    TA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
164                    TR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
165                    TP1 := NEW INTEGER'(TP1.ALL + 1);
166                    TV1 := PACK1.NEXT(TV1);
167                    TT1.NEXT;
168               END ENTRY1;
169          END TASK2;
170
171          PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1;
172                           PR1 : IN OUT RECORD1; PP1 : OUT POINTER1;
173                           PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS
174          BEGIN
175               PI1 := PI1 + 1;
176               PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
177               PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
178               PP1 := NEW INTEGER'(GP1.ALL + 1);
179               PV1 := PACK1.NEXT(GV1);
180               PT1.NEXT;
181          END PROC1;
182
183          PACKAGE GENPACK2 IS NEW GENERIC2
184               (XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
185
186     BEGIN
187          IF XGI1 /= IDENT_INT(1) THEN
188               FAILED ("INCORRECT VALUE OF XGI1 (1)");
189          END IF;
190
191          IF XGA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
192               FAILED ("INCORRECT VALUE OF XGA1 (1)");
193          END IF;
194
195          IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
196               FAILED ("INCORRECT VALUE OF XGR1 (1)");
197          END IF;
198
199          IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(1) THEN
200               FAILED ("INCORRECT VALUE OF XGP1 (1)");
201          END IF;
202
203          IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.ONE)) THEN
204               FAILED ("INCORRECT VALUE OF XGV1 (1)");
205          END IF;
206
207          XGT1.VALU(I);
208          IF I /= IDENT_INT(1) THEN
209               FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (1)");
210          END IF;
211
212          PROC1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
213
214          IF XGI1 /= IDENT_INT(2) THEN
215               FAILED ("INCORRECT VALUE OF XGI1 (2)");
216          END IF;
217
218          IF XGA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
219               FAILED ("INCORRECT VALUE OF XGA1 (2)");
220          END IF;
221
222          IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
223               FAILED ("INCORRECT VALUE OF XGR1 (2)");
224          END IF;
225
226          IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(2) THEN
227               FAILED ("INCORRECT VALUE OF XGP1 (2)");
228          END IF;
229
230          IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.TWO)) THEN
231               FAILED ("INCORRECT VALUE OF XGV1 (2)");
232          END IF;
233
234          XGT1.VALU(I);
235          IF I /= IDENT_INT(2) THEN
236               FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (2)");
237          END IF;
238
239          G_CHK_TASK.ENTRY1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
240
241          IF XGI1 /= IDENT_INT(3) THEN
242               FAILED ("INCORRECT VALUE OF XGI1 (3)");
243          END IF;
244
245          IF XGA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
246               FAILED ("INCORRECT VALUE OF XGA1 (3)");
247          END IF;
248
249          IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
250               FAILED ("INCORRECT VALUE OF XGR1 (3)");
251          END IF;
252
253          IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(3) THEN
254               FAILED ("INCORRECT VALUE OF XGP1 (3)");
255          END IF;
256
257          IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.THREE)) THEN
258               FAILED ("INCORRECT VALUE OF XGV1 (3)");
259          END IF;
260
261          XGT1.VALU(I);
262          IF I /= IDENT_INT(3) THEN
263               FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (3)");
264          END IF;
265
266          XGI1 := XGI1 + 1;
267          XGA1 := (XGA1(1)+1, XGA1(2)+1, XGA1(3)+1);
268          XGR1 := (D => 1, FIELD1 => XGR1.FIELD1 + 1);
269          XGP1 := NEW INTEGER'(XGP1.ALL + 1);
270          XGV1 := PACK1.NEXT(XGV1);
271          XGT1.NEXT;
272
273          IF XGI1 /= IDENT_INT(4) THEN
274               FAILED ("INCORRECT VALUE OF XGI1 (4)");
275          END IF;
276
277          IF XGA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
278               FAILED ("INCORRECT VALUE OF XGA1 (4)");
279          END IF;
280
281          IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
282               FAILED ("INCORRECT VALUE OF XGR1 (4)");
283          END IF;
284
285          IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(4) THEN
286               FAILED ("INCORRECT VALUE OF XGP1 (4)");
287          END IF;
288
289          IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FOUR)) THEN
290               FAILED ("INCORRECT VALUE OF XGV1 (4)");
291          END IF;
292
293          XGT1.VALU(I);
294          IF I /= IDENT_INT(4) THEN
295               FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (4)");
296          END IF;
297
298          GI1 := GI1 + 1;
299          GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
300          GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
301          GP1 := NEW INTEGER'(GP1.ALL + 1);
302          GV1 := PACK1.NEXT(GV1);
303          GT1.NEXT;
304
305          IF XGI1 /= IDENT_INT(5) THEN
306               FAILED ("INCORRECT VALUE OF XGI1 (5)");
307          END IF;
308
309          IF XGA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
310               FAILED ("INCORRECT VALUE OF XGA1 (5)");
311          END IF;
312
313          IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
314               FAILED ("INCORRECT VALUE OF XGR1 (5)");
315          END IF;
316
317          IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(5) THEN
318               FAILED ("INCORRECT VALUE OF XGP1 (5)");
319          END IF;
320
321          IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FIVE)) THEN
322               FAILED ("INCORRECT VALUE OF XGV1 (5)");
323          END IF;
324
325          XGT1.VALU(I);
326          IF I /= IDENT_INT(5) THEN
327               FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (5)");
328          END IF;
329     END GENERIC1;
330
331     TASK BODY TASK1 IS
332          TASK_VALUE : INTEGER := 0;
333          ACCEPTING_ENTRIES : BOOLEAN := TRUE;
334     BEGIN
335          WHILE ACCEPTING_ENTRIES LOOP
336               SELECT
337                    ACCEPT ASSIGN (J : IN INTEGER) DO
338                         TASK_VALUE := J;
339                    END ASSIGN;
340               OR
341                    ACCEPT VALU (J : OUT INTEGER) DO
342                         J := TASK_VALUE;
343                    END VALU;
344               OR
345                    ACCEPT NEXT DO
346                         TASK_VALUE := TASK_VALUE + 1;
347                    END NEXT;
348               OR
349                    ACCEPT STOP DO
350                         ACCEPTING_ENTRIES := FALSE;
351                    END STOP;
352               END SELECT;
353          END LOOP;
354     END TASK1;
355
356BEGIN
357     TEST ("C85005D", "CHECK THAT A VARIABLE CREATED BY A GENERIC " &
358                      "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " &
359                      "AND HAS THE CORRECT VALUE, AND THAT THE NEW " &
360                      "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " &
361                      "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " &
362                      "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " &
363                      "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " &
364                      "WHEN THE VALUE OF THE RENAMED VARIABLE IS " &
365                      "CHANGED, THE NEW VALUE IS REFLECTED BY THE " &
366                      "VALUE OF THE NEW NAME");
367
368     DECLARE
369          PACKAGE GENPACK1 IS NEW
370               GENERIC1 (DI1, DA1, DR1, DP1, DV1, DT1);
371     BEGIN
372          NULL;
373     END;
374
375     DT1.STOP;
376
377     RESULT;
378END C85005D;
379