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 INTEGER 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 RANGE -100 .. 100;
42 TYPE T
IS NEW PARENT
RANGE
43 PARENT
'VAL (IDENT_INT
(-30)) ..
44 PARENT
'VAL (IDENT_INT
( 30));
46 SUBTYPE SUBPARENT
IS PARENT
RANGE -30 .. 30;
48 TYPE S
IS NEW SUBPARENT
;
54 TEST
("C34002C", "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 " &
62 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
64 IF T
'POS (T
'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST
) OR
65 S
'POS (S
'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST
) OR
66 T
'POS (T
'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST
) OR
67 S
'POS (S
'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST
) THEN
68 FAILED
("INCORRECT 'BASE'FIRST OR 'BASE'LAST");
71 IF T
'PRED (100) /= 99 OR T
'SUCC (99) /= 100 OR
72 S
'PRED (100) /= 99 OR S
'SUCC (99) /= 100 THEN
73 FAILED
("INCORRECT 'PRED OR 'SUCC");
76 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
78 IF T
'FIRST /= -30 OR T
'LAST /= 30 OR
79 S
'FIRST /= -30 OR S
'LAST /= 30 THEN
80 FAILED
("INCORRECT 'FIRST OR 'LAST");
86 IF PARENT
(X
) /= PARENT
(Y
) THEN -- USE X AND Y.
87 FAILED
("INCORRECT CONVERSION TO PARENT - 1");
91 IF PARENT
(X
) /= PARENT
(Y
) THEN -- USE X AND Y.
92 FAILED
("INCORRECT CONVERSION TO PARENT - 2");
96 FAILED
("EXCEPTION RAISED BY OK ASSIGNMENT");
101 FAILED
("CONSTRAINT_ERROR NOT RAISED -- X := -31");
102 IF X
= -31 THEN -- USE X.
103 COMMENT
("X ALTERED -- X := -31");
106 WHEN CONSTRAINT_ERROR
=>
109 FAILED
("WRONG EXCEPTION RAISED -- X := -31");
114 FAILED
("CONSTRAINT_ERROR NOT RAISED -- X := 31");
115 IF X
= 31 THEN -- USE X.
116 COMMENT
("X ALTERED -- X := 31");
119 WHEN CONSTRAINT_ERROR
=>
122 FAILED
("WRONG EXCEPTION RAISED -- X := 31");
127 FAILED
("CONSTRAINT_ERROR NOT RAISED -- Y := -31");
128 IF Y
= -31 THEN -- USE Y.
129 COMMENT
("Y ALTERED -- Y := -31");
132 WHEN CONSTRAINT_ERROR
=>
135 FAILED
("WRONG EXCEPTION RAISED -- Y := -31");
140 FAILED
("CONSTRAINT_ERROR NOT RAISED -- Y := 31");
141 IF Y
= 31 THEN -- USE Y.
142 COMMENT
("Y ALTERED -- Y := 31");
145 WHEN CONSTRAINT_ERROR
=>
148 FAILED
("WRONG EXCEPTION RAISED -- Y := 31");