1-- C34007G.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 IS A
28--     MULTI-DIMENSIONAL ARRAY TYPE.
29
30-- HISTORY:
31--     JRK 09/25/86  CREATED ORIGINAL TEST.
32--     BCB 10/21/87  CHANGED HEADER TO STANDARD FORMAT.  REVISED TEST SO
33--                   T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
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 C34007G IS
43
44     SUBTYPE COMPONENT IS INTEGER;
45
46     TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF
47                              COMPONENT;
48
49     SUBTYPE SUBDESIGNATED IS DESIGNATED
50                                   (IDENT_INT (4) .. IDENT_INT (5),
51                                    IDENT_INT (6) .. IDENT_INT (8));
52
53     PACKAGE PKG IS
54
55          TYPE PARENT IS ACCESS DESIGNATED;
56
57          FUNCTION CREATE ( F1, L1 : NATURAL;
58                            F2, L2 : NATURAL;
59                            C      : COMPONENT;
60                            DUMMY  : PARENT   -- TO RESOLVE OVERLOADING.
61                          ) RETURN PARENT;
62
63     END PKG;
64
65     USE PKG;
66
67     TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
68                           IDENT_INT (6) .. IDENT_INT (8));
69
70     X : T         := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
71     Y : T         := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
72     W : PARENT    := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
73     C : COMPONENT := 1;
74     N : CONSTANT  := 2;
75
76     PROCEDURE A (X : ADDRESS) IS
77     BEGIN
78          NULL;
79     END A;
80
81     FUNCTION V RETURN T IS
82     BEGIN
83          RETURN NEW SUBDESIGNATED'(OTHERS => (OTHERS => C));
84     END V;
85
86     PACKAGE BODY PKG IS
87
88          FUNCTION CREATE
89             ( F1, L1 : NATURAL;
90               F2, L2 : NATURAL;
91               C      : COMPONENT;
92               DUMMY  : PARENT
93             ) RETURN PARENT
94          IS
95               A : PARENT    := NEW DESIGNATED (F1 .. L1, F2 .. L2);
96               B : COMPONENT := C;
97          BEGIN
98               FOR I IN F1 .. L1 LOOP
99                    FOR J IN F2 .. L2 LOOP
100                         A (I, J) := B;
101                         B := B + 1;
102                    END LOOP;
103               END LOOP;
104               RETURN A;
105          END CREATE;
106
107     END PKG;
108
109     FUNCTION IDENT (X : T) RETURN T IS
110     BEGIN
111          IF X = NULL OR ELSE
112             EQUAL (X'LENGTH, X'LENGTH) THEN
113               RETURN X;                          -- ALWAYS EXECUTED.
114          END IF;
115          RETURN NEW SUBDESIGNATED;
116     END IDENT;
117
118BEGIN
119     TEST ("C34007G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
120                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
121                      "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
122                      "MULTI-DIMENSIONAL ARRAY TYPE");
123
124     IF Y = NULL OR ELSE Y.ALL /= ((1, 2, 3), (4, 5, 6)) THEN
125          FAILED ("INCORRECT INITIALIZATION");
126     END IF;
127
128     X := IDENT (Y);
129     IF X /= Y THEN
130          FAILED ("INCORRECT :=");
131     END IF;
132
133     IF T'(X) /= Y THEN
134          FAILED ("INCORRECT QUALIFICATION");
135     END IF;
136
137     IF T (X) /= Y THEN
138          FAILED ("INCORRECT SELF CONVERSION");
139     END IF;
140
141     IF EQUAL (3, 3) THEN
142          W := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
143     END IF;
144     X := T (W);
145     IF X = NULL OR ELSE X = Y OR ELSE
146        X.ALL /= ((1, 2, 3), (4, 5, 6)) THEN
147          FAILED ("INCORRECT CONVERSION FROM PARENT");
148     END IF;
149
150     X := IDENT (Y);
151     W := PARENT (X);
152     IF W = NULL OR ELSE W.ALL /= ((1, 2, 3), (4, 5, 6)) OR ELSE
153        T (W) /= Y THEN
154          FAILED ("INCORRECT CONVERSION TO PARENT - 1");
155     END IF;
156
157     W := PARENT (CREATE (6, 9, 2, 3, 4, X));
158     IF W = NULL OR ELSE
159        W.ALL /= ((4, 5), (6, 7), (8, 9), (10, 11)) THEN
160          FAILED ("INCORRECT CONVERSION TO PARENT - 2");
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 SUBDESIGNATED'((1, 2, 3), (4, 5, 6)));
168     IF (X = NULL OR ELSE X = Y OR ELSE
169         X.ALL /= ((1, 2, 3), (4, 5, 6))) OR
170        X = NEW DESIGNATED'((1, 2), (3, 4), (5, 6)) THEN
171          FAILED ("INCORRECT ALLOCATOR");
172     END IF;
173
174     X := IDENT (Y);
175     IF X.ALL /= ((1, 2, 3), (4, 5, 6)) OR
176        CREATE (6, 9, 2, 3, 4, X) . ALL /=
177        ((4, 5), (6, 7), (8, 9), (10, 11)) THEN
178          FAILED ("INCORRECT .ALL (VALUE)");
179     END IF;
180
181     X.ALL := ((10, 11, 12), (13, 14, 15));
182     IF X /= Y OR Y.ALL /= ((10, 11, 12), (13, 14, 15)) THEN
183          FAILED ("INCORRECT .ALL (ASSIGNMENT)");
184     END IF;
185
186     Y.ALL := ((1, 2, 3), (4, 5, 6));
187     BEGIN
188          CREATE (6, 9, 2, 3, 4, X) . ALL :=
189               ((20, 21), (22, 23), (24, 25), (26, 27));
190     EXCEPTION
191          WHEN OTHERS =>
192               FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)");
193     END;
194
195     X := IDENT (NULL);
196     BEGIN
197          IF X.ALL = ((0, 0, 0), (0, 0, 0)) THEN
198               FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
199          ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
200          END IF;
201     EXCEPTION
202          WHEN CONSTRAINT_ERROR =>
203               NULL;
204          WHEN OTHERS =>
205               FAILED ("WRONG EXCEPTION FOR NULL.ALL");
206     END;
207
208     X := IDENT (Y);
209     IF X (IDENT_INT (4), IDENT_INT (6)) /= 1 OR
210        CREATE (6, 9, 2, 3, 4, X) (9, 3) /= 11 THEN
211          FAILED ("INCORRECT INDEX (VALUE)");
212     END IF;
213
214     X (IDENT_INT (5), IDENT_INT (8)) := 7;
215     IF X /= Y OR Y.ALL /= ((1, 2, 3), (4, 5, 7)) THEN
216          FAILED ("INCORRECT INDEX (ASSIGNMENT)");
217     END IF;
218
219     Y.ALL := ((1, 2, 3), (4, 5, 6));
220     X := IDENT (Y);
221     BEGIN
222          CREATE (6, 9, 2, 3, 4, X) (6, 2) := 15;
223     EXCEPTION
224          WHEN OTHERS =>
225               FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)");
226     END;
227
228     IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR
229        X = CREATE (6, 9, 2, 3, 4, X) THEN
230          FAILED ("INCORRECT =");
231     END IF;
232
233     IF X /= Y OR NOT (X /= NULL) OR
234        NOT (X /= CREATE (7, 9, 2, 4, 1, X)) THEN
235          FAILED ("INCORRECT /=");
236     END IF;
237
238     IF NOT (X IN T) OR CREATE (2, 3, 4, 5, 1, X) IN T THEN
239          FAILED ("INCORRECT ""IN""");
240     END IF;
241
242     IF X NOT IN T OR NOT (CREATE (7, 9, 2, 4, 1, X) NOT IN T) THEN
243          FAILED ("INCORRECT ""NOT IN""");
244     END IF;
245
246     A (X'ADDRESS);
247
248     IF X'FIRST /= 4 THEN
249          FAILED ("INCORRECT OBJECT'FIRST");
250     END IF;
251
252     IF V'FIRST /= 4 THEN
253          FAILED ("INCORRECT VALUE'FIRST");
254     END IF;
255
256     IF X'FIRST (N) /= 6 THEN
257          FAILED ("INCORRECT OBJECT'FIRST (N)");
258     END IF;
259
260     IF V'FIRST (N) /= 6 THEN
261          FAILED ("INCORRECT VALUE'FIRST (N)");
262     END IF;
263
264     IF X'LAST /= 5 THEN
265          FAILED ("INCORRECT OBJECT'LAST");
266     END IF;
267
268     IF V'LAST /= 5 THEN
269          FAILED ("INCORRECT VALUE'LAST");
270     END IF;
271
272     IF X'LAST (N) /= 8 THEN
273          FAILED ("INCORRECT OBJECT'LAST (N)");
274     END IF;
275
276     IF V'LAST (N) /= 8 THEN
277          FAILED ("INCORRECT VALUE'LAST (N)");
278     END IF;
279
280     IF X'LENGTH /= 2 THEN
281          FAILED ("INCORRECT OBJECT'LENGTH");
282     END IF;
283
284     IF V'LENGTH /= 2 THEN
285          FAILED ("INCORRECT VALUE'LENGTH");
286     END IF;
287
288     IF X'LENGTH (N) /= 3 THEN
289          FAILED ("INCORRECT OBJECT'LENGTH (N)");
290     END IF;
291
292     IF V'LENGTH (N) /= 3 THEN
293          FAILED ("INCORRECT VALUE'LENGTH (N)");
294     END IF;
295
296     DECLARE
297          Y : DESIGNATED (X'RANGE, 1 .. 3);
298     BEGIN
299          IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
300               FAILED ("INCORRECT OBJECT'RANGE");
301          END IF;
302     END;
303
304     DECLARE
305          Y : DESIGNATED (V'RANGE, 1 .. 3);
306     BEGIN
307          IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
308               FAILED ("INCORRECT VALUE'RANGE");
309          END IF;
310     END;
311
312     DECLARE
313          Y : DESIGNATED (1 .. 2, X'RANGE (N));
314     BEGIN
315          IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
316               FAILED ("INCORRECT OBJECT'RANGE (N)");
317          END IF;
318     END;
319
320     DECLARE
321          Y : DESIGNATED (1 .. 2, V'RANGE (N));
322     BEGIN
323          IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
324               FAILED ("INCORRECT VALUE'RANGE (N)");
325          END IF;
326     END;
327
328     IF T'SIZE < 1 THEN
329          FAILED ("INCORRECT TYPE'SIZE");
330     END IF;
331
332     IF X'SIZE < T'SIZE THEN
333          FAILED ("INCORRECT OBJECT'SIZE");
334     END IF;
335
336     BEGIN
337          IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
338               FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
339                       "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
340          END IF;
341     EXCEPTION
342          WHEN PROGRAM_ERROR =>
343               COMMENT ("PROGRAM_ERROR RAISED FOR " &
344                        "UNDEFINED STORAGE_SIZE (AI-00608)");
345          WHEN OTHERS =>
346               FAILED ("UNEXPECTED EXCEPTION RAISED");
347     END;
348
349     RESULT;
350END C34007G;
351