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 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 09/01/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
:= 3) IS
51 FUNCTION CREATE
( B
: BOOLEAN;
57 X
: PARENT
-- TO RESOLVE OVERLOADING.
60 FUNCTION CON
( B
: BOOLEAN;
67 FUNCTION CON
( B
: BOOLEAN;
73 FUNCTION EQUAL
(X
, Y
: PARENT
) RETURN BOOLEAN;
75 PROCEDURE ASSIGN
(X
: OUT PARENT
; Y
: PARENT
);
79 TYPE PARENT
(B
: BOOLEAN := TRUE; L
: LENGTH
:= 3) IS
84 S
: STRING (1 .. L
) := (1 .. L
=> 'A');
95 TYPE T
IS NEW PARENT
(IDENT_BOOL
(TRUE), IDENT_INT
(3));
97 SUBTYPE SUBPARENT
IS PARENT
(TRUE, 3);
99 TYPE S
IS NEW SUBPARENT
;
119 RETURN (TRUE, L
, I
, S
, J
);
121 RETURN (FALSE, L
, I
, F
);
134 RETURN (TRUE, L
, I
, S
, J
);
145 RETURN (FALSE, L
, I
, F
);
148 FUNCTION EQUAL
(X
, Y
: PARENT
) RETURN BOOLEAN IS
153 PROCEDURE ASSIGN
(X
: OUT PARENT
; Y
: PARENT
) IS
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");
169 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
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");
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""");
183 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
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");
190 IF NOT X
'CONSTRAINED OR NOT Y
'CONSTRAINED THEN
191 FAILED
("INCORRECT 'CONSTRAINED");
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");
202 FAILED
("EXCEPTION RAISED BY OK ASSIGN CALL");
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))");
214 WHEN CONSTRAINT_ERROR
=>
217 FAILED
("WRONG EXCEPTION RAISED -- " &
218 "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
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))");
230 WHEN CONSTRAINT_ERROR
=>
233 FAILED
("WRONG EXCEPTION RAISED -- " &
234 "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
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))");
246 WHEN CONSTRAINT_ERROR
=>
249 FAILED
("WRONG EXCEPTION RAISED -- " &
250 "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
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))");
262 WHEN CONSTRAINT_ERROR
=>
265 FAILED
("WRONG EXCEPTION RAISED -- " &
266 "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");