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
37WITH REPORT; USE REPORT;
38PROCEDURE 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
349BEGIN
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;
366END C85005B;
367