1-- C34007J.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
27--     (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE
28--     IS A TASK TYPE.
29
30-- HISTORY:
31--     JRK 09/26/86  CREATED ORIGINAL TEST.
32--     JLH 09/25/87  REFORMATTED HEADER.
33--     BCB 09/26/88  REMOVED COMPARISION INVOLVING OBJECT SIZE.
34--     BCB 03/07/90  PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
35--     THS 09/18/90  REMOVED DECLARATION OF B, MADE THE BODY OF
36--                   PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
37--     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
38
39WITH SYSTEM; USE SYSTEM;
40WITH REPORT; USE REPORT;
41
42PROCEDURE C34007J IS
43
44     TASK TYPE DESIGNATED IS
45          ENTRY E (I : IN OUT INTEGER);
46          ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER);
47          ENTRY R (I : OUT INTEGER);
48          ENTRY W (I : INTEGER);
49     END DESIGNATED;
50
51     TYPE PARENT IS ACCESS DESIGNATED;
52
53     TYPE T IS NEW PARENT;
54
55     X : T;
56     K : INTEGER := X'SIZE;
57     Y : T;
58     W : PARENT;
59     I : INTEGER := 0;
60     J : INTEGER := 0;
61
62     PROCEDURE A (X : ADDRESS) IS
63     BEGIN
64          NULL;
65     END A;
66
67     FUNCTION V RETURN T IS
68     BEGIN
69          RETURN NEW DESIGNATED;
70     END V;
71
72     FUNCTION IDENT (X : T) RETURN T IS
73     BEGIN
74          IF (X = NULL OR ELSE X'CALLABLE) OR IDENT_BOOL (TRUE) THEN
75               RETURN X;                          -- ALWAYS EXECUTED.
76          END IF;
77          RETURN NEW DESIGNATED;
78     END IDENT;
79
80     TASK BODY DESIGNATED IS
81          N : INTEGER := 1;
82     BEGIN
83          LOOP
84               SELECT
85                    ACCEPT E (I : IN OUT INTEGER) DO
86                         I := I + N;
87                    END E;
88               OR
89                    ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO
90                         J := I + N;
91                    END F;
92               OR
93                    ACCEPT R (I : OUT INTEGER) DO
94                         I := N;
95                    END R;
96               OR
97                    ACCEPT W (I : INTEGER) DO
98                         N := I;
99                    END W;
100               OR
101                    TERMINATE;
102               END SELECT;
103          END LOOP;
104     END DESIGNATED;
105
106BEGIN
107     TEST ("C34007J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
108                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
109                      "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
110                      "TASK TYPE");
111
112     X := NEW DESIGNATED;
113     Y := NEW DESIGNATED;
114     W := NEW DESIGNATED;
115
116     IF Y = NULL THEN
117          FAILED ("INCORRECT INITIALIZATION - 1");
118     ELSE Y.W (2);
119          Y.R (I);
120          IF I /= 2 THEN
121               FAILED ("INCORRECT INITIALIZATION - 2");
122          END IF;
123     END IF;
124
125     X := IDENT (Y);
126     IF X /= Y THEN
127          FAILED ("INCORRECT :=");
128     END IF;
129
130     IF T'(X) /= Y THEN
131          FAILED ("INCORRECT QUALIFICATION");
132     END IF;
133
134     IF T (X) /= Y THEN
135          FAILED ("INCORRECT SELF CONVERSION");
136     END IF;
137
138     IF EQUAL (3, 3) THEN
139          W := NEW DESIGNATED;
140          W.W (3);
141     END IF;
142     X := T (W);
143     IF X = NULL OR X = Y THEN
144          FAILED ("INCORRECT CONVERSION FROM PARENT - 1");
145     ELSE I := 5;
146          X.E (I);
147          IF I /= 8 THEN
148               FAILED ("INCORRECT CONVERSION FROM PARENT - 2");
149          END IF;
150     END IF;
151
152     X := IDENT (Y);
153     W := PARENT (X);
154     IF W = NULL OR T (W) /= Y THEN
155          FAILED ("INCORRECT CONVERSION TO PARENT - 1");
156     ELSE I := 5;
157          W.E (I);
158          IF I /= 7 THEN
159               FAILED ("INCORRECT CONVERSION TO PARENT - 2");
160          END IF;
161     END IF;
162
163     IF IDENT (NULL) /= NULL OR X = NULL THEN
164          FAILED ("INCORRECT NULL");
165     END IF;
166
167     X := IDENT (NEW DESIGNATED);
168     IF X = NULL OR X = Y THEN
169          FAILED ("INCORRECT ALLOCATOR - 1");
170     ELSE I := 5;
171          X.E (I);
172          IF I /= 6 THEN
173               FAILED ("INCORRECT ALLOCATOR - 2");
174          END IF;
175     END IF;
176
177     X := IDENT (Y);
178     I := 5;
179     X.E (I);
180     IF I /= 7 THEN
181          FAILED ("INCORRECT SELECTION (ENTRY)");
182     END IF;
183
184     I := 5;
185     X.F (IDENT_INT (2)) (I, J);
186     IF J /= 7 THEN
187          FAILED ("INCORRECT SELECTION (FAMILY)");
188     END IF;
189
190     I := 5;
191     X.ALL.E (I);
192     IF I /= 7 THEN
193          FAILED ("INCORRECT .ALL");
194     END IF;
195
196     X := IDENT (NULL);
197     BEGIN
198          IF X.ALL'CALLABLE THEN
199               FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
200          ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
201          END IF;
202     EXCEPTION
203          WHEN CONSTRAINT_ERROR =>
204               NULL;
205          WHEN OTHERS =>
206               FAILED ("WRONG EXCEPTION FOR NULL.ALL");
207     END;
208
209     X := IDENT (Y);
210     IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN
211          FAILED ("INCORRECT =");
212     END IF;
213
214     IF X /= Y OR NOT (X /= NULL) THEN
215          FAILED ("INCORRECT /=");
216     END IF;
217
218     IF NOT (X IN T) THEN
219          FAILED ("INCORRECT ""IN""");
220     END IF;
221
222     IF X NOT IN T THEN
223          FAILED ("INCORRECT ""NOT IN""");
224     END IF;
225
226     A (X'ADDRESS);
227
228     IF NOT X'CALLABLE THEN
229          FAILED ("INCORRECT OBJECT'CALLABLE");
230     END IF;
231
232     IF NOT V'CALLABLE THEN
233          FAILED ("INCORRECT VALUE'CALLABLE");
234     END IF;
235
236     BEGIN
237          IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
238               FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
239                       "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
240          END IF;
241     EXCEPTION
242          WHEN PROGRAM_ERROR =>
243               COMMENT ("PROGRAM_ERROR RAISED FOR " &
244                        "UNDEFINED STORAGE_SIZE (AI-00608)");
245          WHEN OTHERS =>
246               FAILED ("UNEXPECTED EXCEPTION RAISED");
247     END;
248
249     IF X'TERMINATED THEN
250          FAILED ("INCORRECT OBJECT'TERMINATED");
251     END IF;
252
253     IF V'TERMINATED THEN
254          FAILED ("INCORRECT VALUE'TERMINATED");
255     END IF;
256
257     RESULT;
258END C34007J;
259