1-- C34006J.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 RECORD TYPES WITH DISCRIMINANTS AND WITH
28--     A LIMITED COMPONENT TYPE.
29
30-- HISTORY:
31--     JRK 08/25/87  CREATED ORIGINAL TEST.
32--     VCL 06/28/88  MODIFIED THE STATEMENTS INVOLVING THE 'SIZE
33--                   ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE
34--                   SIZES.
35--     PWN 11/30/94  REMOVED 'BASE USE ILLEGAL IN ADA 9X.
36
37WITH SYSTEM; USE SYSTEM;
38WITH REPORT; USE REPORT;
39
40PROCEDURE C34006J 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 EQUAL (X, Y : LP) RETURN BOOLEAN;
49
50          PROCEDURE ASSIGN (X : OUT LP; Y : LP);
51
52          C4 : CONSTANT LP;
53          C5 : CONSTANT LP;
54
55     PRIVATE
56
57          TYPE LP IS NEW INTEGER;
58
59          C4 : CONSTANT LP := 4;
60          C5 : CONSTANT LP := 5;
61
62     END PKG_L;
63
64     USE PKG_L;
65
66     SUBTYPE COMPONENT IS LP;
67
68     PACKAGE PKG_P IS
69
70          MAX_LEN : CONSTANT := 10;
71
72          SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
73
74          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
75               RECORD
76                    I : INTEGER := 2;
77                    CASE B IS
78                         WHEN TRUE =>
79                              S : STRING (1 .. L) := (1 .. L => 'A');
80                              C : COMPONENT;
81                         WHEN FALSE =>
82                              F : FLOAT := 5.0;
83                    END CASE;
84               END RECORD;
85
86          FUNCTION CREATE ( B : BOOLEAN;
87                            L : LENGTH;
88                            I : INTEGER;
89                            S : STRING;
90                            C : COMPONENT;
91                            F : FLOAT;
92                            X : PARENT  -- TO RESOLVE OVERLOADING.
93                          ) RETURN PARENT;
94
95          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
96
97          FUNCTION AGGR ( B : BOOLEAN;
98                          L : LENGTH;
99                          I : INTEGER;
100                          S : STRING;
101                          C : COMPONENT
102                        ) RETURN PARENT;
103
104          FUNCTION AGGR ( B : BOOLEAN;
105                          L : LENGTH;
106                          I : INTEGER;
107                          F : FLOAT
108                        ) RETURN PARENT;
109
110     END PKG_P;
111
112     USE PKG_P;
113
114     TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
115
116     X : T;
117     W : PARENT;
118     B : BOOLEAN := FALSE;
119
120     PROCEDURE A (X : ADDRESS) IS
121     BEGIN
122          B := IDENT_BOOL (TRUE);
123     END A;
124
125     PACKAGE BODY PKG_L IS
126
127          FUNCTION CREATE (X : INTEGER) RETURN LP IS
128          BEGIN
129               RETURN LP (IDENT_INT (X));
130          END CREATE;
131
132          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
133          BEGIN
134               RETURN X = Y;
135          END EQUAL;
136
137          PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
138          BEGIN
139               X := Y;
140          END ASSIGN;
141
142     END PKG_L;
143
144     PACKAGE BODY PKG_P IS
145
146          FUNCTION CREATE
147             ( B : BOOLEAN;
148               L : LENGTH;
149               I : INTEGER;
150               S : STRING;
151               C : COMPONENT;
152               F : FLOAT;
153               X : PARENT
154             ) RETURN PARENT
155          IS
156               A : PARENT (B, L);
157          BEGIN
158               A.I := I;
159               CASE B IS
160                    WHEN TRUE =>
161                         A.S := S;
162                         ASSIGN (A.C, C);
163                    WHEN FALSE =>
164                         A.F := F;
165               END CASE;
166               RETURN A;
167          END CREATE;
168
169          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
170          BEGIN
171               IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN
172                    RETURN FALSE;
173               END IF;
174               CASE X.B IS
175                    WHEN TRUE =>
176                         RETURN X.S = Y.S AND EQUAL (X.C, Y.C);
177                    WHEN FALSE =>
178                         RETURN X.F = Y.F;
179               END CASE;
180          END EQUAL;
181
182          FUNCTION AGGR
183             ( B : BOOLEAN;
184               L : LENGTH;
185               I : INTEGER;
186               S : STRING;
187               C : COMPONENT
188             ) RETURN PARENT
189          IS
190               RESULT : PARENT (B, L);
191          BEGIN
192               RESULT.I := I;
193               RESULT.S := S;
194               ASSIGN (RESULT.C, C);
195               RETURN RESULT;
196          END AGGR;
197
198          FUNCTION AGGR
199             ( B : BOOLEAN;
200               L : LENGTH;
201               I : INTEGER;
202               F : FLOAT
203             ) RETURN PARENT
204          IS
205               RESULT : PARENT (B, L);
206          BEGIN
207               RESULT.I := I;
208               RESULT.F := F;
209               RETURN RESULT;
210          END AGGR;
211
212     END PKG_P;
213
214BEGIN
215     TEST ("C34006J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
216                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
217                      "RECORD TYPES WITH DISCRIMINANTS AND WITH A " &
218                      "LIMITED COMPONENT TYPE");
219
220     X.I := IDENT_INT (1);
221     X.S := IDENT_STR ("ABC");
222     ASSIGN (X.C, CREATE (4));
223
224     W.I := IDENT_INT (1);
225     W.S := IDENT_STR ("ABC");
226     ASSIGN (W.C, CREATE (4));
227
228     IF NOT EQUAL (T'(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
229          FAILED ("INCORRECT QUALIFICATION");
230     END IF;
231
232     IF NOT EQUAL (T(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
233          FAILED ("INCORRECT SELF CONVERSION");
234     END IF;
235
236     IF NOT EQUAL (T(W), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
237          FAILED ("INCORRECT CONVERSION FROM PARENT");
238     END IF;
239
240     IF NOT EQUAL (PARENT(X), AGGR (TRUE, 3, 1, "ABC", C4))   OR
241        NOT EQUAL (PARENT(CREATE (FALSE, 2, 3, "XX", C5, 6.0, X)),
242                   AGGR (FALSE, 2, 3, 6.0))   THEN
243          FAILED ("INCORRECT CONVERSION TO PARENT");
244     END IF;
245
246     IF X.B /= TRUE OR X.L /= 3 OR
247        CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).B /= FALSE OR
248        CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).L /= 2 THEN
249          FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
250     END IF;
251
252     IF X.I /= 1 OR X.S /= "ABC" OR NOT EQUAL (X.C, C4) OR
253        CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).I /= 3 OR
254        CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).F /= 6.0 THEN
255          FAILED ("INCORRECT SELECTION (VALUE)");
256     END IF;
257
258     X.I := IDENT_INT (7);
259     X.S := IDENT_STR ("XYZ");
260     IF NOT EQUAL (X, AGGR (TRUE, 3, 7, "XYZ", C4)) THEN
261          FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
262     END IF;
263
264     X.I := IDENT_INT (1);
265     X.S := IDENT_STR ("ABC");
266     IF NOT (X IN T) OR AGGR (FALSE, 2, 3, 6.0) IN T THEN
267          FAILED ("INCORRECT ""IN""");
268     END IF;
269
270     IF X NOT IN T OR NOT (AGGR (FALSE, 2, 3, 6.0) NOT IN T) THEN
271          FAILED ("INCORRECT ""NOT IN""");
272     END IF;
273
274     B := FALSE;
275     A (X'ADDRESS);
276     IF NOT B THEN
277          FAILED ("INCORRECT 'ADDRESS");
278     END IF;
279
280     IF NOT X'CONSTRAINED THEN
281          FAILED ("INCORRECT 'CONSTRAINED");
282     END IF;
283
284     IF X.C'FIRST_BIT < 0 THEN
285          FAILED ("INCORRECT 'FIRST_BIT");
286     END IF;
287
288     IF X.C'LAST_BIT < 0 OR
289        X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
290          FAILED ("INCORRECT 'LAST_BIT");
291     END IF;
292
293     IF X.C'POSITION < 0 THEN
294          FAILED ("INCORRECT 'POSITION");
295     END IF;
296
297     IF X'SIZE < T'SIZE THEN
298          COMMENT ("X'SIZE < T'SIZE");
299     ELSIF X'SIZE = T'SIZE THEN
300          COMMENT ("X'SIZE = T'SIZE");
301     ELSE
302          COMMENT ("X'SIZE > T'SIZE");
303     END IF;
304
305     RESULT;
306EXCEPTION
307     WHEN OTHERS =>
308          FAILED ("UNEXPECTED EXCEPTION RAISED WHILE CHECKING BASIC " &
309                  "OPERATIONS");
310          RESULT;
311END C34006J;
312