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 FLOATING POINT 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.
35 -- GJD 11/15/95 REMOVED USES OF OBSOLETE ADA 83 ATTRIBUTE (SAFE_LARGE).
37 WITH REPORT
; USE REPORT
;
41 TYPE PARENT
IS DIGITS 5;
43 TYPE T
IS NEW PARENT
DIGITS 4 RANGE
44 PARENT
(IDENT_INT
(-30)) ..
45 PARENT
(IDENT_INT
( 30));
47 SUBTYPE SUBPARENT
IS PARENT
DIGITS 4 RANGE -30.0 .. 30.0;
49 TYPE S
IS NEW SUBPARENT
;
55 TEST
("C34003C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
56 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
57 "WHEN THE DERIVED TYPE DEFINITION IS " &
58 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
59 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
60 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
61 "FLOATING POINT TYPES");
63 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
65 IF T
'BASE'DIGITS < 5 OR S'BASE'DIGITS < 5 THEN
66 FAILED
("INCORRECT 'BASE'DIGITS");
69 IF 12344.0 + T
'(1.0) + 1.0 /= 12346.0 OR
70 12344.0 + S'(1.0) + 1.0 /= 12346.0 OR
71 -12344.0 - T
'(1.0) - 1.0 /= -12346.0 OR
72 -12344.0 - S'(1.0) - 1.0 /= -12346.0 THEN
73 FAILED
("INCORRECT + OR -");
76 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
78 IF T
'DIGITS /= 4 OR S
'DIGITS /= 4 THEN
79 FAILED
("INCORRECT 'DIGITS");
82 IF T
'FIRST /= -30.0 OR T
'LAST /= 30.0 OR
83 S
'FIRST /= -30.0 OR S
'LAST /= 30.0 THEN
84 FAILED
("INCORRECT 'FIRST OR 'LAST");
90 IF PARENT
(X
) /= PARENT
(Y
) THEN -- USE X AND Y.
91 FAILED
("INCORRECT CONVERSION TO PARENT - 1");
95 IF PARENT
(X
) /= PARENT
(Y
) THEN -- USE X AND Y.
96 FAILED
("INCORRECT CONVERSION TO PARENT - 2");
100 FAILED
("EXCEPTION RAISED BY OK ASSIGNMENT");
105 FAILED
("CONSTRAINT_ERROR NOT RAISED -- X := -31.0");
106 IF X
= -31.0 THEN -- USE X.
107 COMMENT
("X ALTERED -- X := -31.0");
110 WHEN CONSTRAINT_ERROR
=>
113 FAILED
("WRONG EXCEPTION RAISED -- X := -31.0");
118 FAILED
("CONSTRAINT_ERROR NOT RAISED -- X := 31.0");
119 IF X
= 31.0 THEN -- USE X.
120 COMMENT
("X ALTERED -- X := 31.0");
123 WHEN CONSTRAINT_ERROR
=>
126 FAILED
("WRONG EXCEPTION RAISED -- X := 31.0");
131 FAILED
("CONSTRAINT_ERROR NOT RAISED -- Y := -31.0");
132 IF Y
= -31.0 THEN -- USE Y.
133 COMMENT
("Y ALTERED -- Y := -31.0");
136 WHEN CONSTRAINT_ERROR
=>
139 FAILED
("WRONG EXCEPTION RAISED -- Y := -31.0");
144 FAILED
("CONSTRAINT_ERROR NOT RAISED -- Y := 31.0");
145 IF Y
= 31.0 THEN -- USE Y.
146 COMMENT
("Y ALTERED -- Y := 31.0");
149 WHEN CONSTRAINT_ERROR
=>
152 FAILED
("WRONG EXCEPTION RAISED -- Y := 31.0");