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