1-- C34005V.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 MULTI-DIMENSIONAL ARRAY TYPES WHOSE
28--     COMPONENT TYPE IS A LIMITED TYPE.  THIS TEST IS PART 2 OF 2
29--     TESTS WHICH COVER THE OBJECTIVE.  THE FIRST PART IS IN TEST
30--     C34005S.
31
32-- HISTORY:
33--     BCB 04/12/90  CREATED ORIGINAL TEST FROM SPLIT OF C34005S.ADA.
34--     RLB 10/03/02  REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND
35--                   SUPPORTING CODE.
36
37WITH SYSTEM; USE SYSTEM;
38WITH REPORT; USE REPORT;
39
40PROCEDURE C34005V IS
41
42     PACKAGE PKG_L IS
43
44          TYPE LP IS LIMITED PRIVATE;
45
46          FUNCTION CREATE (X : INTEGER) RETURN LP;
47
48          FUNCTION VALUE (X : LP) RETURN INTEGER;
49
50          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
51
52          PROCEDURE ASSIGN (X : OUT LP; Y : LP);
53
54          C1  : CONSTANT LP;
55          C2  : CONSTANT LP;
56          C3  : CONSTANT LP;
57          C4  : CONSTANT LP;
58          C5  : CONSTANT LP;
59          C6  : CONSTANT LP;
60          C7  : CONSTANT LP;
61          C8  : CONSTANT LP;
62          C9  : CONSTANT LP;
63          C10 : CONSTANT LP;
64          C11 : CONSTANT LP;
65          C12 : CONSTANT LP;
66          C13 : CONSTANT LP;
67          C14 : CONSTANT LP;
68
69     PRIVATE
70
71          TYPE LP IS NEW INTEGER;
72
73          C1  : CONSTANT LP :=  1;
74          C2  : CONSTANT LP :=  2;
75          C3  : CONSTANT LP :=  3;
76          C4  : CONSTANT LP :=  4;
77          C5  : CONSTANT LP :=  5;
78          C6  : CONSTANT LP :=  6;
79          C7  : CONSTANT LP :=  7;
80          C8  : CONSTANT LP :=  8;
81          C9  : CONSTANT LP :=  9;
82          C10 : CONSTANT LP := 10;
83          C11 : CONSTANT LP := 11;
84          C12 : CONSTANT LP := 12;
85          C13 : CONSTANT LP := 13;
86          C14 : CONSTANT LP := 14;
87
88     END PKG_L;
89
90     USE PKG_L;
91
92     SUBTYPE COMPONENT IS LP;
93
94     PACKAGE PKG_P IS
95
96          FIRST : CONSTANT := 0;
97          LAST  : CONSTANT := 10;
98
99          SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
100
101          TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
102                               COMPONENT;
103
104          FUNCTION CREATE ( F1, L1 : INDEX;
105                            F2, L2 : INDEX;
106                            C      : COMPONENT;
107                            DUMMY  : PARENT   -- TO RESOLVE OVERLOADING.
108                          ) RETURN PARENT;
109
110          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
111
112          FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT;
113
114          FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT;
115
116          FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
117                        RETURN PARENT;
118
119          FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT)
120                        RETURN PARENT;
121
122     END PKG_P;
123
124     USE PKG_P;
125
126     TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
127                           IDENT_INT (6) .. IDENT_INT (8));
128
129     X : T;
130     W : PARENT (4 .. 5, 6 .. 8);
131     C : COMPONENT;
132     B : BOOLEAN := FALSE;
133     N : CONSTANT := 2;
134
135     PROCEDURE A (X : ADDRESS) IS
136     BEGIN
137          B := IDENT_BOOL (TRUE);
138     END A;
139
140     FUNCTION V RETURN T IS
141          RESULT : T;
142     BEGIN
143          FOR I IN RESULT'RANGE LOOP
144               FOR J IN RESULT'RANGE(2) LOOP
145                    ASSIGN (RESULT (I, J), C);
146               END LOOP;
147          END LOOP;
148          RETURN RESULT;
149     END V;
150
151     PACKAGE BODY PKG_L IS
152
153          FUNCTION CREATE (X : INTEGER) RETURN LP IS
154          BEGIN
155               RETURN LP (IDENT_INT (X));
156          END CREATE;
157
158          FUNCTION VALUE (X : LP) RETURN INTEGER IS
159          BEGIN
160               RETURN INTEGER (X);
161          END VALUE;
162
163          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
164          BEGIN
165               RETURN X = Y;
166          END EQUAL;
167
168          PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
169          BEGIN
170               X := Y;
171          END ASSIGN;
172
173     END PKG_L;
174
175     PACKAGE BODY PKG_P IS
176
177          FUNCTION CREATE
178             ( F1, L1 : INDEX;
179               F2, L2 : INDEX;
180               C      : COMPONENT;
181               DUMMY  : PARENT
182             ) RETURN PARENT
183          IS
184               A : PARENT (F1 .. L1, F2 .. L2);
185               B : COMPONENT;
186          BEGIN
187               ASSIGN (B, C);
188               FOR I IN F1 .. L1 LOOP
189                    FOR J IN F2 .. L2 LOOP
190                         ASSIGN (A (I, J), B);
191                         ASSIGN (B, CREATE (VALUE (B) + 1));
192                    END LOOP;
193               END LOOP;
194               RETURN A;
195          END CREATE;
196
197          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
198          BEGIN
199               IF X'LENGTH /= Y'LENGTH OR
200                  X'LENGTH(2) /= Y'LENGTH(2) THEN
201                    RETURN FALSE;
202               ELSE FOR I IN X'RANGE LOOP
203                         FOR J IN X'RANGE(2) LOOP
204                              IF NOT EQUAL (X (I, J),
205                                            Y (I - X'FIRST + Y'FIRST,
206                                               J - X'FIRST(2) +
207                                                   Y'FIRST(2))) THEN
208                                   RETURN FALSE;
209                              END IF;
210                         END LOOP;
211                    END LOOP;
212               END IF;
213               RETURN TRUE;
214          END EQUAL;
215
216          FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT IS
217               X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1,
218                           INDEX'FIRST .. INDEX'FIRST + 1);
219          BEGIN
220               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST    ), A);
221               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 1), B);
222               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST    ), C);
223               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D);
224               RETURN X;
225          END AGGR;
226
227          FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT IS
228               X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1,
229                           INDEX'FIRST .. INDEX'FIRST + 2);
230          BEGIN
231               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST    ), A);
232               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 1), B);
233               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 2), C);
234               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST    ), D);
235               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E);
236               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F);
237               RETURN X;
238          END AGGR;
239
240          FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
241                        RETURN PARENT IS
242               X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3,
243                           INDEX'FIRST .. INDEX'FIRST + 1);
244          BEGIN
245               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST    ), A);
246               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 1), B);
247               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST    ), C);
248               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D);
249               ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST    ), E);
250               ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F);
251               ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST    ), G);
252               ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H);
253               RETURN X;
254          END AGGR;
255
256          FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT)
257                        RETURN PARENT IS
258               X : PARENT (INDEX'FIRST .. INDEX'FIRST + 2,
259                           INDEX'FIRST .. INDEX'FIRST + 2);
260          BEGIN
261               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST    ), A);
262               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 1), B);
263               ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 2), C);
264               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST    ), D);
265               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E);
266               ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F);
267               ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST    ), G);
268               ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), H);
269               ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 2), I);
270               RETURN X;
271          END AGGR;
272
273     END PKG_P;
274
275BEGIN
276     TEST ("C34005V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
277                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
278                      "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
279                      "TYPE IS A LIMITED TYPE.  THIS TEST IS PART 2 " &
280                      "OF 2 TESTS WHICH COVER THE OBJECTIVE.  THE " &
281                      "FIRST PART IS IN TEST C34005S");
282
283     ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1));
284     ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2));
285     ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3));
286     ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4));
287     ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5));
288     ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6));
289
290     ASSIGN (W (4, 6), CREATE (1));
291     ASSIGN (W (4, 7), CREATE (2));
292     ASSIGN (W (4, 8), CREATE (3));
293     ASSIGN (W (5, 6), CREATE (4));
294     ASSIGN (W (5, 7), CREATE (5));
295     ASSIGN (W (5, 8), CREATE (6));
296
297     ASSIGN (C, CREATE (2));
298
299     IF NOT EQUAL (T'(X), AGGR (C1, C2, C3, C4, C5, C6)) THEN
300          FAILED ("INCORRECT QUALIFICATION");
301     END IF;
302
303     IF NOT EQUAL (T (X), AGGR (C1, C2, C3, C4, C5, C6)) THEN
304          FAILED ("INCORRECT SELF CONVERSION");
305     END IF;
306
307     IF NOT EQUAL (T (W), AGGR (C1, C2, C3, C4, C5, C6)) THEN
308          FAILED ("INCORRECT CONVERSION FROM PARENT");
309     END IF;
310
311     BEGIN
312          IF NOT EQUAL (PARENT (X), AGGR (C1, C2, C3, C4, C5, C6)) OR
313             NOT EQUAL (PARENT (CREATE (6, 9, 2, 3, C4, X)),
314                        AGGR (C4, C5, C6, C7, C8, C9, C10, C11)) THEN
315               FAILED ("INCORRECT CONVERSION TO PARENT");
316          END IF;
317     EXCEPTION
318          WHEN CONSTRAINT_ERROR =>
319               FAILED ("CONSTRAINT_ERROR WHEN PREPARING TO CONVERT " &
320                       "TO PARENT");
321          WHEN OTHERS =>
322               FAILED ("EXCEPTION WHEN PREPARING TO CONVERT " &
323                       "TO PARENT");
324     END;
325
326     IF NOT (X IN T) OR AGGR (C1, C2, C3, C4) IN T THEN
327          FAILED ("INCORRECT ""IN""");
328     END IF;
329
330     IF X NOT IN T OR
331        NOT (AGGR (C1, C2, C3, C4, C5, C6, C7, C8, C9) NOT IN T) THEN
332          FAILED ("INCORRECT ""NOT IN""");
333     END IF;
334
335     RESULT;
336END C34005V;
337