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 RECORD TYPES WITH DISCRIMINANTS AND WITH NON-LIMITED
28 -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
29 -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
31 -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
32 -- IMPOSED ON THE DERIVED SUBTYPE.
35 -- JRK 9/22/86 CREATED ORIGINAL TEST.
37 WITH REPORT
; USE REPORT
;
41 SUBTYPE COMPONENT
IS INTEGER;
45 MAX_LEN
: CONSTANT := 10;
47 SUBTYPE LENGTH
IS NATURAL RANGE 0 .. MAX_LEN
;
49 TYPE PARENT
(B
: BOOLEAN := TRUE; L
: LENGTH
:= 1) IS
61 FUNCTION CREATE
( B
: BOOLEAN;
67 X
: PARENT
-- TO RESOLVE OVERLOADING.
74 TYPE T
IS NEW PARENT
(IDENT_BOOL
(TRUE), IDENT_INT
(3));
76 SUBTYPE SUBPARENT
IS PARENT
(TRUE, 3);
78 TYPE S
IS NEW SUBPARENT
;
80 X
: T
:= (TRUE, 3, 2, "AAA", 2);
81 Y
: S
:= (TRUE, 3, 2, "AAA", 2);
98 RETURN (TRUE, L
, I
, S
, C
);
100 RETURN (FALSE, L
, I
, F
);
107 TEST
("C34006F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
108 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
109 "WHEN THE DERIVED TYPE DEFINITION IS " &
110 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
111 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
112 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
113 "RECORD TYPES WITH DISCRIMINANTS AND WITH " &
114 "NON-LIMITED COMPONENT TYPES");
116 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
119 IF CREATE
(FALSE, 2, 3, "ZZ", 5, 6.0, X
) /=
120 (FALSE, 2, 3, 6.0) OR
121 CREATE
(FALSE, 2, 3, "ZZ", 5, 6.0, Y
) /=
122 (FALSE, 2, 3, 6.0) THEN
123 FAILED
("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
127 WHEN CONSTRAINT_ERROR
=>
128 FAILED
("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
130 FAILED
("CALL TO CREATE RAISED EXCEPTION - 1");
134 IF CREATE
(FALSE, 2, 3, "ZZ", 5, 6.0, X
) IN T
OR
135 CREATE
(FALSE, 2, 3, "ZZ", 5, 6.0, Y
) IN S
THEN
136 FAILED
("INCORRECT ""IN""");
139 WHEN CONSTRAINT_ERROR
=>
140 FAILED
("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
142 FAILED
("CALL TO CREATE RAISED EXCEPTION - 2");
145 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
147 IF X
.B
/= TRUE OR X
.L
/= 3 OR
148 Y
.B
/= TRUE OR Y
.L
/= 3 THEN
149 FAILED
("INCORRECT SELECTION OF DISCRIMINANT VALUES");
152 IF NOT X
'CONSTRAINED OR NOT Y
'CONSTRAINED THEN
153 FAILED
("INCORRECT 'CONSTRAINED");
157 X
:= (TRUE, 3, 1, "ABC", 4);
158 Y
:= (TRUE, 3, 1, "ABC", 4);
159 IF PARENT
(X
) /= PARENT
(Y
) THEN -- USE X AND Y.
160 FAILED
("INCORRECT CONVERSION TO PARENT");
164 FAILED
("EXCEPTION RAISED BY OK ASSIGNMENT");
168 X
:= (FALSE, 3, 2, 6.0);
169 FAILED
("CONSTRAINT_ERROR NOT RAISED -- " &
170 "X := (FALSE, 3, 2, 6.0)");
171 IF X
= (FALSE, 3, 2, 6.0) THEN -- USE X.
172 COMMENT
("X ALTERED -- X := (FALSE, 3, 2, 6.0)");
175 WHEN CONSTRAINT_ERROR
=>
178 FAILED
("WRONG EXCEPTION RAISED -- " &
179 "X := (FALSE, 3, 2, 6.0)");
183 X
:= (TRUE, 4, 2, "ZZZZ", 6);
184 FAILED
("CONSTRAINT_ERROR NOT RAISED -- " &
185 "X := (TRUE, 4, 2, ""ZZZZ"", 6)");
186 IF X
= (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X.
187 COMMENT
("X ALTERED -- X := (TRUE, 4, 2, ""ZZZZ"", 6)");
190 WHEN CONSTRAINT_ERROR
=>
193 FAILED
("WRONG EXCEPTION RAISED -- " &
194 "X := (TRUE, 4, 2, ""ZZZZ"", 6)");
198 Y
:= (FALSE, 3, 2, 6.0);
199 FAILED
("CONSTRAINT_ERROR NOT RAISED -- " &
200 "Y := (FALSE, 3, 2, 6.0)");
201 IF Y
= (FALSE, 3, 2, 6.0) THEN -- USE Y.
202 COMMENT
("Y ALTERED -- Y := (FALSE, 3, 2, 6.0)");
205 WHEN CONSTRAINT_ERROR
=>
208 FAILED
("WRONG EXCEPTION RAISED -- " &
209 "Y := (FALSE, 3, 2, 6.0)");
213 Y
:= (TRUE, 4, 2, "ZZZZ", 6);
214 FAILED
("CONSTRAINT_ERROR NOT RAISED -- " &
215 "Y := (TRUE, 4, 2, ""ZZZZ"", 6)");
216 IF Y
= (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y.
217 COMMENT
("Y ALTERED -- Y := (TRUE, 4, 2, ""ZZZZ"", 6)");
220 WHEN CONSTRAINT_ERROR
=>
223 FAILED
("WRONG EXCEPTION RAISED -- " &
224 "Y := (TRUE, 4, 2, ""ZZZZ"", 6)");