1-- C34006L.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--     FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH A LIMITED
27--     COMPONENT TYPE:
28
29--        CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
30--        FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
31--        IS CONSTRAINED.
32
33--        CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
34--        ALSO IMPOSED ON THE DERIVED SUBTYPE.
35
36-- HISTORY:
37--     JRK 08/26/87  CREATED ORIGINAL TEST.
38
39WITH REPORT; USE REPORT;
40
41PROCEDURE C34006L IS
42
43     PACKAGE PKG_L IS
44
45          TYPE LP IS LIMITED PRIVATE;
46
47          FUNCTION CREATE (X : INTEGER) RETURN LP;
48
49          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
50
51          PROCEDURE ASSIGN (X : OUT LP; Y : LP);
52
53          C2 : CONSTANT LP;
54          C4 : CONSTANT LP;
55          C5 : CONSTANT LP;
56          C6 : CONSTANT LP;
57
58     PRIVATE
59
60          TYPE LP IS NEW INTEGER;
61
62          C2 : CONSTANT LP := 2;
63          C4 : CONSTANT LP := 4;
64          C5 : CONSTANT LP := 5;
65          C6 : CONSTANT LP := 6;
66
67     END PKG_L;
68
69     USE PKG_L;
70
71     SUBTYPE COMPONENT IS LP;
72
73     PACKAGE PKG_P IS
74
75          MAX_LEN : CONSTANT := 10;
76
77          SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
78
79          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
80               RECORD
81                    I : INTEGER := 2;
82                    CASE B IS
83                         WHEN TRUE =>
84                              S : STRING (1 .. L) := (1 .. L => 'A');
85                              C : COMPONENT;
86                         WHEN FALSE =>
87                              F : FLOAT := 5.0;
88                    END CASE;
89               END RECORD;
90
91          FUNCTION CREATE ( B : BOOLEAN;
92                            L : LENGTH;
93                            I : INTEGER;
94                            S : STRING;
95                            C : COMPONENT;
96                            F : FLOAT;
97                            X : PARENT  -- TO RESOLVE OVERLOADING.
98                          ) RETURN PARENT;
99
100          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
101
102          FUNCTION AGGR ( B : BOOLEAN;
103                          L : LENGTH;
104                          I : INTEGER;
105                          S : STRING;
106                          C : COMPONENT
107                        ) RETURN PARENT;
108
109          FUNCTION AGGR ( B : BOOLEAN;
110                          L : LENGTH;
111                          I : INTEGER;
112                          F : FLOAT
113                        ) RETURN PARENT;
114
115     END PKG_P;
116
117     USE PKG_P;
118
119     TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
120
121     SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
122
123     TYPE S IS NEW SUBPARENT;
124
125     X : T;
126     Y : S;
127
128     PACKAGE BODY PKG_L IS
129
130          FUNCTION CREATE (X : INTEGER) RETURN LP IS
131          BEGIN
132               RETURN LP (IDENT_INT (X));
133          END CREATE;
134
135          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
136          BEGIN
137               RETURN X = Y;
138          END EQUAL;
139
140          PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
141          BEGIN
142               X := Y;
143          END ASSIGN;
144
145     END PKG_L;
146
147     PACKAGE BODY PKG_P IS
148
149          FUNCTION CREATE
150             ( B : BOOLEAN;
151               L : LENGTH;
152               I : INTEGER;
153               S : STRING;
154               C : COMPONENT;
155               F : FLOAT;
156               X : PARENT
157             ) RETURN PARENT
158          IS
159               A : PARENT (B, L);
160          BEGIN
161               A.I := I;
162               CASE B IS
163                    WHEN TRUE =>
164                         A.S := S;
165                         ASSIGN (A.C, C);
166                    WHEN FALSE =>
167                         A.F := F;
168               END CASE;
169               RETURN A;
170          END CREATE;
171
172          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
173          BEGIN
174               IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN
175                    RETURN FALSE;
176               END IF;
177               CASE X.B IS
178                    WHEN TRUE =>
179                         RETURN X.S = Y.S AND EQUAL (X.C, Y.C);
180                    WHEN FALSE =>
181                         RETURN X.F = Y.F;
182               END CASE;
183          END EQUAL;
184
185          FUNCTION AGGR
186             ( B : BOOLEAN;
187               L : LENGTH;
188               I : INTEGER;
189               S : STRING;
190               C : COMPONENT
191             ) RETURN PARENT
192          IS
193               RESULT : PARENT (B, L);
194          BEGIN
195               RESULT.I := I;
196               RESULT.S := S;
197               ASSIGN (RESULT.C, C);
198               RETURN RESULT;
199          END AGGR;
200
201          FUNCTION AGGR
202             ( B : BOOLEAN;
203               L : LENGTH;
204               I : INTEGER;
205               F : FLOAT
206             ) RETURN PARENT
207          IS
208               RESULT : PARENT (B, L);
209          BEGIN
210               RESULT.I := I;
211               RESULT.F := F;
212               RETURN RESULT;
213          END AGGR;
214
215     END PKG_P;
216
217     PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS
218     BEGIN
219          X.I := Y.I;
220          X.S := Y.S;
221          ASSIGN (X.C, Y.C);
222     END ASSIGN;
223
224     PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS
225     BEGIN
226          X.I := Y.I;
227          X.S := Y.S;
228          ASSIGN (X.C, Y.C);
229     END ASSIGN;
230
231BEGIN
232     TEST ("C34006L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
233                      "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
234                      "WHEN THE DERIVED TYPE DEFINITION IS " &
235                      "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
236                      "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
237                      "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
238                      "RECORD TYPES WITH DISCRIMINANTS AND WITH A " &
239                      "LIMITED COMPONENT TYPE");
240
241     ASSIGN (X.C, CREATE (2));
242     ASSIGN (Y.C, C2);
243
244     -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
245
246     IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X),
247                   AGGR (FALSE, 2, 3, 6.0)) OR
248        NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y),
249                   AGGR (FALSE, 2, 3, 6.0)) THEN
250          FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
251     END IF;
252
253     IF CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X) IN T OR
254        CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y) IN S THEN
255          FAILED ("INCORRECT ""IN""");
256     END IF;
257
258     -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
259
260     IF X.B /= TRUE OR X.L /= 3 OR
261        Y.B /= TRUE OR Y.L /= 3 THEN
262          FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
263     END IF;
264
265     IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
266          FAILED ("INCORRECT 'CONSTRAINED");
267     END IF;
268
269     BEGIN
270          ASSIGN (X, AGGR (TRUE, 3, 1, "ABC", C4));
271          ASSIGN (Y, AGGR (TRUE, 3, 1, "ABC", C4));
272          IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN  -- USE X AND Y.
273               FAILED ("INCORRECT CONVERSION TO PARENT");
274          END IF;
275     EXCEPTION
276          WHEN OTHERS =>
277               FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
278     END;
279
280     BEGIN
281          ASSIGN (X, AGGR (FALSE, 3, 2, 6.0));
282          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
283                  "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))");
284          IF EQUAL (X, AGGR (FALSE, 3, 2, 6.0)) THEN  -- USE X.
285               COMMENT ("X ALTERED -- " &
286                        "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))");
287          END IF;
288     EXCEPTION
289          WHEN CONSTRAINT_ERROR =>
290               NULL;
291          WHEN OTHERS =>
292               FAILED ("WRONG EXCEPTION RAISED -- " &
293                       "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))");
294     END;
295
296     BEGIN
297          ASSIGN (X, AGGR (TRUE, 4, 2, "ZZZZ", C6));
298          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
299                  "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
300          IF EQUAL (X, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN  -- USE X.
301               COMMENT ("X ALTERED -- " &
302                        "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
303          END IF;
304     EXCEPTION
305          WHEN CONSTRAINT_ERROR =>
306               NULL;
307          WHEN OTHERS =>
308               FAILED ("WRONG EXCEPTION RAISED -- " &
309                       "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
310     END;
311
312     BEGIN
313          ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0));
314          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
315                  "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))");
316          IF EQUAL (Y, AGGR (FALSE, 3, 2, 6.0)) THEN  -- USE Y.
317               COMMENT ("Y ALTERED -- " &
318                        "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))");
319          END IF;
320     EXCEPTION
321          WHEN CONSTRAINT_ERROR =>
322               NULL;
323          WHEN OTHERS =>
324               FAILED ("WRONG EXCEPTION RAISED -- " &
325                       "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))");
326     END;
327
328     BEGIN
329          ASSIGN (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6));
330          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
331                  "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
332          IF EQUAL (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN  -- USE Y.
333               COMMENT ("Y ALTERED -- " &
334                        "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
335          END IF;
336     EXCEPTION
337          WHEN CONSTRAINT_ERROR =>
338               NULL;
339          WHEN OTHERS =>
340               FAILED ("WRONG EXCEPTION RAISED -- " &
341                       "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
342     END;
343
344     RESULT;
345END C34006L;
346