1-- C34009L.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 LIMITED PRIVATE TYPES WITH DISCRIMINANTS:
27
28--        CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
29--        FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
30--        IS CONSTRAINED.
31
32--        CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
33--        ALSO IMPOSED ON THE DERIVED SUBTYPE.
34
35-- HISTORY:
36--     JRK 09/01/87  CREATED ORIGINAL TEST.
37
38WITH REPORT; USE REPORT;
39
40PROCEDURE C34009L IS
41
42     PACKAGE PKG IS
43
44          MAX_LEN : CONSTANT := 10;
45
46          SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
47
48          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
49                      LIMITED PRIVATE;
50
51          FUNCTION CREATE ( B : BOOLEAN;
52                            L : LENGTH;
53                            I : INTEGER;
54                            S : STRING;
55                            J : INTEGER;
56                            F : FLOAT;
57                            X : PARENT  -- TO RESOLVE OVERLOADING.
58                          ) RETURN PARENT;
59
60          FUNCTION CON ( B : BOOLEAN;
61                         L : LENGTH;
62                         I : INTEGER;
63                         S : STRING;
64                         J : INTEGER
65                       ) RETURN PARENT;
66
67          FUNCTION CON ( B : BOOLEAN;
68                         L : LENGTH;
69                         I : INTEGER;
70                         F : FLOAT
71                       ) RETURN PARENT;
72
73          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
74
75          PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT);
76
77     PRIVATE
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                              J : INTEGER := 2;
86                         WHEN FALSE =>
87                              F : FLOAT := 5.0;
88                    END CASE;
89               END RECORD;
90
91     END PKG;
92
93     USE PKG;
94
95     TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
96
97     SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
98
99     TYPE S IS NEW SUBPARENT;
100
101     X : T;
102     Y : S;
103
104     PACKAGE BODY PKG IS
105
106          FUNCTION CREATE
107             ( B : BOOLEAN;
108               L : LENGTH;
109               I : INTEGER;
110               S : STRING;
111               J : INTEGER;
112               F : FLOAT;
113               X : PARENT
114             ) RETURN PARENT
115          IS
116          BEGIN
117               CASE B IS
118                    WHEN TRUE =>
119                         RETURN (TRUE, L, I, S, J);
120                    WHEN FALSE =>
121                         RETURN (FALSE, L, I, F);
122               END CASE;
123          END CREATE;
124
125          FUNCTION CON
126             ( B : BOOLEAN;
127               L : LENGTH;
128               I : INTEGER;
129               S : STRING;
130               J : INTEGER
131             ) RETURN PARENT
132          IS
133          BEGIN
134               RETURN (TRUE, L, I, S, J);
135          END CON;
136
137          FUNCTION CON
138             ( B : BOOLEAN;
139               L : LENGTH;
140               I : INTEGER;
141               F : FLOAT
142             ) RETURN PARENT
143          IS
144          BEGIN
145               RETURN (FALSE, L, I, F);
146          END CON;
147
148          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
149          BEGIN
150               RETURN X = Y;
151          END EQUAL;
152
153          PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS
154          BEGIN
155               X := Y;
156          END ASSIGN;
157
158     END PKG;
159
160BEGIN
161     TEST ("C34009L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
162                      "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
163                      "WHEN THE DERIVED TYPE DEFINITION IS " &
164                      "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
165                      "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
166                      "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
167                      "LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
168
169     -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
170
171     IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X),
172                   CON (FALSE, 2, 3, 6.0)) OR
173        NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y),
174                   CON (FALSE, 2, 3, 6.0)) THEN
175          FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
176     END IF;
177
178     IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
179        CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
180          FAILED ("INCORRECT ""IN""");
181     END IF;
182
183     -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
184
185     IF X.B /= TRUE OR X.L /= 3 OR
186        Y.B /= TRUE OR Y.L /= 3 THEN
187          FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
188     END IF;
189
190     IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
191          FAILED ("INCORRECT 'CONSTRAINED");
192     END IF;
193
194     BEGIN
195          ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4));
196          ASSIGN (Y, CON (TRUE, 3, 1, "ABC", 4));
197          IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN  -- USE X AND Y.
198               FAILED ("INCORRECT CONVERSION TO PARENT");
199          END IF;
200     EXCEPTION
201          WHEN OTHERS =>
202               FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
203     END;
204
205     BEGIN
206          ASSIGN (X, CON (FALSE, 3, 2, 6.0));
207          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
208                  "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
209          IF EQUAL (X, CON (FALSE, 3, 2, 6.0)) THEN  -- USE X.
210               COMMENT ("X ALTERED -- " &
211                        "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
212          END IF;
213     EXCEPTION
214          WHEN CONSTRAINT_ERROR =>
215               NULL;
216          WHEN OTHERS =>
217               FAILED ("WRONG EXCEPTION RAISED -- " &
218                       "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
219     END;
220
221     BEGIN
222          ASSIGN (X, CON (TRUE, 4, 2, "ZZZZ", 6));
223          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
224                  "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
225          IF EQUAL (X, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN  -- USE X.
226               COMMENT ("X ALTERED -- " &
227                        "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
228          END IF;
229     EXCEPTION
230          WHEN CONSTRAINT_ERROR =>
231               NULL;
232          WHEN OTHERS =>
233               FAILED ("WRONG EXCEPTION RAISED -- " &
234                       "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
235     END;
236
237     BEGIN
238          ASSIGN (Y, CON (FALSE, 3, 2, 6.0));
239          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
240                  "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
241          IF EQUAL (Y, CON (FALSE, 3, 2, 6.0)) THEN  -- USE Y.
242               COMMENT ("Y ALTERED -- " &
243                        "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
244          END IF;
245     EXCEPTION
246          WHEN CONSTRAINT_ERROR =>
247               NULL;
248          WHEN OTHERS =>
249               FAILED ("WRONG EXCEPTION RAISED -- " &
250                       "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
251     END;
252
253     BEGIN
254          ASSIGN (Y, CON (TRUE, 4, 2, "ZZZZ", 6));
255          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
256                  "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
257          IF EQUAL (Y, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN  -- USE Y.
258               COMMENT ("Y ALTERED -- " &
259                        "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
260          END IF;
261     EXCEPTION
262          WHEN CONSTRAINT_ERROR =>
263               NULL;
264          WHEN OTHERS =>
265               FAILED ("WRONG EXCEPTION RAISED -- " &
266                       "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
267     END;
268
269     RESULT;
270END C34009L;
271