3 -- Grant of Unlimited Rights
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
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.
26 -- FOR DERIVED NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS:
28 -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
29 -- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
32 -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
33 -- ALSO IMPOSED ON THE DERIVED SUBTYPE.
36 -- JRK 08/31/87 CREATED ORIGINAL TEST.
38 WITH REPORT
; USE REPORT
;
44 MAX_LEN
: CONSTANT := 10;
46 SUBTYPE LENGTH
IS NATURAL RANGE 0 .. MAX_LEN
;
48 TYPE PARENT
(B
: BOOLEAN := TRUE; L
: LENGTH
:= 1) IS PRIVATE;
50 FUNCTION CREATE
( B
: BOOLEAN;
56 X
: PARENT
-- TO RESOLVE OVERLOADING.
59 FUNCTION CON
( B
: BOOLEAN;
66 FUNCTION CON
( B
: BOOLEAN;
74 TYPE PARENT
(B
: BOOLEAN := TRUE; L
: LENGTH
:= 1) IS
90 TYPE T
IS NEW PARENT
(IDENT_BOOL
(TRUE), IDENT_INT
(3));
92 SUBTYPE SUBPARENT
IS PARENT
(TRUE, 3);
94 TYPE S
IS NEW SUBPARENT
;
114 RETURN (TRUE, L
, I
, S
, J
);
116 RETURN (FALSE, L
, I
, F
);
129 RETURN (TRUE, L
, I
, S
, J
);
140 RETURN (FALSE, L
, I
, F
);
146 TEST
("C34009F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
147 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
148 "WHEN THE DERIVED TYPE DEFINITION IS " &
149 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
150 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
151 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
152 "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
154 X
:= CON
(TRUE, 3, 2, "AAA", 2);
155 Y
:= CON
(TRUE, 3, 2, "AAA", 2);
157 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
159 IF CREATE
(FALSE, 2, 3, "ZZ", 5, 6.0, X
) /=
160 CON
(FALSE, 2, 3, 6.0) OR
161 CREATE
(FALSE, 2, 3, "ZZ", 5, 6.0, Y
) /=
162 CON
(FALSE, 2, 3, 6.0) THEN
163 FAILED
("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
166 IF CREATE
(FALSE, 2, 3, "ZZ", 5, 6.0, X
) IN T
OR
167 CREATE
(FALSE, 2, 3, "ZZ", 5, 6.0, Y
) IN S
THEN
168 FAILED
("INCORRECT ""IN""");
171 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
173 IF X
.B
/= TRUE OR X
.L
/= 3 OR
174 Y
.B
/= TRUE OR Y
.L
/= 3 THEN
175 FAILED
("INCORRECT SELECTION OF DISCRIMINANT VALUES");
178 IF NOT X
'CONSTRAINED OR NOT Y
'CONSTRAINED THEN
179 FAILED
("INCORRECT 'CONSTRAINED");
183 X
:= CON
(TRUE, 3, 1, "ABC", 4);
184 Y
:= CON
(TRUE, 3, 1, "ABC", 4);
185 IF PARENT
(X
) /= PARENT
(Y
) THEN -- USE X AND Y.
186 FAILED
("INCORRECT CONVERSION TO PARENT");
190 FAILED
("EXCEPTION RAISED BY OK ASSIGNMENT");
194 X
:= CON
(FALSE, 3, 2, 6.0);
195 FAILED
("CONSTRAINT_ERROR NOT RAISED -- " &
196 "X := CON (FALSE, 3, 2, 6.0)");
197 IF X
= CON
(FALSE, 3, 2, 6.0) THEN -- USE X.
198 COMMENT
("X ALTERED -- X := CON (FALSE, 3, 2, 6.0)");
201 WHEN CONSTRAINT_ERROR
=>
204 FAILED
("WRONG EXCEPTION RAISED -- " &
205 "X := CON (FALSE, 3, 2, 6.0)");
209 X
:= CON
(TRUE, 4, 2, "ZZZZ", 6);
210 FAILED
("CONSTRAINT_ERROR NOT RAISED -- " &
211 "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
212 IF X
= CON
(TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X.
213 COMMENT
("X ALTERED -- " &
214 "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
217 WHEN CONSTRAINT_ERROR
=>
220 FAILED
("WRONG EXCEPTION RAISED -- " &
221 "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
225 Y
:= CON
(FALSE, 3, 2, 6.0);
226 FAILED
("CONSTRAINT_ERROR NOT RAISED -- " &
227 "Y := CON (FALSE, 3, 2, 6.0)");
228 IF Y
= CON
(FALSE, 3, 2, 6.0) THEN -- USE Y.
229 COMMENT
("Y ALTERED -- Y := CON (FALSE, 3, 2, 6.0)");
232 WHEN CONSTRAINT_ERROR
=>
235 FAILED
("WRONG EXCEPTION RAISED -- " &
236 "Y := CON (FALSE, 3, 2, 6.0)");
240 Y
:= CON
(TRUE, 4, 2, "ZZZZ", 6);
241 FAILED
("CONSTRAINT_ERROR NOT RAISED -- " &
242 "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
243 IF Y
= CON
(TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y.
244 COMMENT
("Y ALTERED -- " &
245 "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
248 WHEN CONSTRAINT_ERROR
=>
251 FAILED
("WRONG EXCEPTION RAISED -- " &
252 "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");