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.
25 -- FOR DERIVED ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES:
27 -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
28 -- 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.
36 WITH REPORT
; USE REPORT
;
40 TYPE PARENT
IS (E1
, E2
, E3
, 'A', E4
, E5
, E6
);
42 TYPE T
IS NEW PARENT
RANGE
43 PARENT
'VAL (IDENT_INT
(PARENT
'POS (E3
))) ..
44 PARENT
'VAL (IDENT_INT
(PARENT
'POS (E4
)));
46 SUBTYPE SUBPARENT
IS PARENT
RANGE E3
.. E4
;
48 TYPE S
IS NEW SUBPARENT
;
54 TEST
("C34001C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
55 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
56 "WHEN THE DERIVED TYPE DEFINITION IS " &
57 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
58 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
59 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
60 "ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES");
62 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
64 IF T
'BASE'FIRST /= E1 OR T'BASE'LAST
/= E6
OR
65 S
'BASE'FIRST /= E1 OR S'BASE'LAST
/= E6
THEN
66 FAILED
("INCORRECT 'BASE'FIRST OR 'BASE'LAST");
69 IF T
'PRED (E2
) /= E1
OR T
'SUCC (E1
) /= E2
OR
70 S
'PRED (E2
) /= E1
OR S
'SUCC (E1
) /= E2
THEN
71 FAILED
("INCORRECT 'PRED OR 'SUCC");
74 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
76 IF T
'FIRST /= E3
OR T
'LAST /= E4
OR
77 S
'FIRST /= E3
OR S
'LAST /= E4
THEN
78 FAILED
("INCORRECT 'FIRST OR 'LAST");
84 IF PARENT
(X
) /= PARENT
(Y
) THEN -- USE X AND Y.
85 FAILED
("INCORRECT CONVERSION TO PARENT - 1");
89 IF PARENT
(X
) /= PARENT
(Y
) THEN -- USE X AND Y.
90 FAILED
("INCORRECT CONVERSION TO PARENT - 2");
94 FAILED
("EXCEPTION RAISED BY OK ASSIGNMENT");
99 FAILED
("CONSTRAINT_ERROR NOT RAISED -- X := E2");
100 IF X
= E2
THEN -- USE X.
101 COMMENT
("X ALTERED -- X := E2");
104 WHEN CONSTRAINT_ERROR
=>
107 FAILED
("WRONG EXCEPTION RAISED -- X := E2");
112 FAILED
("CONSTRAINT_ERROR NOT RAISED -- X := E5");
113 IF X
= E5
THEN -- USE X.
114 COMMENT
("X ALTERED -- X := E5");
117 WHEN CONSTRAINT_ERROR
=>
120 FAILED
("WRONG EXCEPTION RAISED -- X := E5");
125 FAILED
("CONSTRAINT_ERROR NOT RAISED -- Y := E2");
126 IF Y
= E2
THEN -- USE Y.
127 COMMENT
("Y ALTERED -- Y := E2");
130 WHEN CONSTRAINT_ERROR
=>
133 FAILED
("WRONG EXCEPTION RAISED -- Y := E2");
138 FAILED
("CONSTRAINT_ERROR NOT RAISED -- Y := E5");
139 IF Y
= E5
THEN -- USE Y.
140 COMMENT
("Y ALTERED -- Y := E5");
143 WHEN CONSTRAINT_ERROR
=>
146 FAILED
("WRONG EXCEPTION RAISED -- Y := E5");