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 ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT
27 -- CONSTRAINT_ERROR IS RAISED IF T IS A CONSTRAINED ACCESS
28 -- TYPE AND THE OBJECT DESIGNATED BY X DOES NOT HAVE DISCRIMINANTS
29 -- OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING VALUES FOR T.
32 -- EG 08/30/84 CREATED ORIGINAL TEST.
33 -- JET 01/05/87 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT
43 TYPE G_TYPE
IS PRIVATE;
44 FUNCTION EQUAL_G
(X
: G_TYPE
; Y
: G_TYPE
) RETURN BOOLEAN;
46 FUNCTION EQUAL_G
(X
: G_TYPE
; Y
: G_TYPE
) RETURN BOOLEAN IS
48 IF (IDENT_INT
(3) = 3) AND (X
= Y
) THEN
57 TEST
("C48009G","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
58 "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
59 "APPROPRIATE - CONSTRAINED ACCESS TYPE");
63 TYPE INT
IS RANGE 1 .. 5;
69 TYPE UA
IS ARRAY(INT
RANGE <>) OF INTEGER;
72 TYPE UP
(A
, B
: INT
) IS PRIVATE;
73 TYPE UL
(A
, B
: INT
) IS LIMITED PRIVATE;
74 CONS_UP
: CONSTANT UP
;
76 TYPE UP
(A
, B
: INT
) IS
80 TYPE UL
(A
, B
: INT
) IS
84 CONS_UP
: CONSTANT UP
:= (2, 2, (IDENT_INT
(3)));
87 TYPE A_UR
IS ACCESS UR
;
88 TYPE A_UA
IS ACCESS UA
;
89 TYPE A_UP
IS ACCESS P
.UP
;
90 TYPE A_UL
IS ACCESS P
.UL
;
92 SUBTYPE CA_UR
IS A_UR
(2);
93 SUBTYPE CA_UA
IS A_UA
(2 .. 3);
94 SUBTYPE CA_UP
IS A_UP
(3, 2);
95 SUBTYPE CA_UL
IS A_UL
(2, 4);
97 TYPE A_CA_UR
IS ACCESS CA_UR
;
98 TYPE A_CA_UA
IS ACCESS CA_UA
;
99 TYPE A_CA_UP
IS ACCESS CA_UP
;
100 TYPE A_CA_UL
IS ACCESS CA_UL
;
107 FUNCTION EQUAL
IS NEW EQUAL_G
(A_CA_UR
);
108 FUNCTION EQUAL
IS NEW EQUAL_G
(A_CA_UA
);
109 FUNCTION EQUAL
IS NEW EQUAL_G
(A_CA_UP
);
110 FUNCTION EQUAL
IS NEW EQUAL_G
(A_CA_UL
);
115 V_A_CA_UR
:= NEW CA_UR
'(NEW UR'(1,(IDENT_INT
(2))));
117 IF EQUAL
(V_A_CA_UR
, V_A_CA_UR
) THEN
118 FAILED
("NO EXCEPTION RAISED - UR");
122 WHEN CONSTRAINT_ERROR
=>
125 FAILED
("WRONG EXCEPTION RAISED - UR");
129 V_A_CA_UA
:= NEW CA_UA
'(NEW UA'(1 => 2,
132 IF EQUAL
(V_A_CA_UA
, V_A_CA_UA
) THEN
133 FAILED
("NO EXCEPTION RAISED - UA");
137 WHEN CONSTRAINT_ERROR
=>
140 FAILED
("WRONG EXCEPTION RAISED - UA");
144 V_A_CA_UP
:= NEW CA_UP
'(NEW P.UP'(P
.CONS_UP
));
146 IF EQUAL
(V_A_CA_UP
, V_A_CA_UP
) THEN
147 FAILED
("NO EXCEPTION RAISED - UP");
151 WHEN CONSTRAINT_ERROR
=>
154 FAILED
("WRONG EXCEPTION RAISED - UP");
158 V_A_CA_UR
:= NEW CA_UR
'(NULL);
160 IF NOT EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
161 COMMENT ("NO EXCEPTION RAISED - UR");
166 FAILED ("EXCEPTION RAISED - UR");
170 V_A_CA_UA := NEW CA_UA'(NULL);
172 IF NOT EQUAL
(V_A_CA_UA
, V_A_CA_UA
) THEN
173 COMMENT
("NO EXCEPTION RAISED - UA");
178 FAILED
("EXCEPTION RAISED - UA");
182 V_A_CA_UP
:= NEW CA_UP
'(NULL);
184 IF NOT EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
185 COMMENT ("NO EXCEPTION RAISED - UP");
190 FAILED ("EXCEPTION RAISED - UP");
194 V_A_CA_UL := NEW CA_UL'(NULL);
196 IF NOT EQUAL
(V_A_CA_UL
, V_A_CA_UL
) THEN
197 COMMENT
("NO EXCEPTION RAISED - UL");
202 FAILED
("EXCEPTION RAISED - UL");