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 -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO AN
26 -- ACCESS SUBTYPE IF THE OPERAND VALUE IS NOT NULL AND THE
27 -- DISCRIMINANTS OR INDEX BOUNDS OF THE DESIGNATED OBJECT DO NOT
28 -- MATCH THOSE OF THE TARGET TYPE.
32 WITH REPORT
; USE REPORT
;
36 TEST
( "C46054A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
37 "CONVERSION TO AN ACCESS SUBTYPE IF THE " &
38 "OPERAND VALUE IS NOT NULL AND THE " &
39 "DISCRIMINANTS OR INDEX BOUNDS OF THE " &
40 "DESIGNATED OBJECT DO NOT MATCH THOSE OF " &
44 TYPE REC
(D
: INTEGER) IS
49 TYPE ACREC
IS ACCESS REC
;
50 A
: ACREC
(IDENT_INT
(0)) := NEW REC
(IDENT_INT
(0));
52 SUBTYPE ACREC3
IS ACREC
(IDENT_INT
(3));
54 PROCEDURE PROC
(A
: ACREC
) IS
62 FAILED
( "NO EXCEPTION RAISED FOR 'ACREC3 (A)'" );
64 WHEN CONSTRAINT_ERROR
=>
67 FAILED
( "WRONG EXCEPTION RAISED FOR 'ACREC3 (A)'" );
71 TYPE REC
(D1
, D2
: INTEGER) IS
76 TYPE ACREC
IS ACCESS REC
;
78 A
: ACREC
(IDENT_INT
(3), IDENT_INT
(1)) :=
79 NEW REC
(IDENT_INT
(3), IDENT_INT
(1));
81 SUBTYPE ACREC13
IS ACREC
(IDENT_INT
(1), IDENT_INT
(3));
83 PROCEDURE PROC
(A
: ACREC
) IS
86 I
:= IDENT_INT
(A
.D1
);
91 FAILED
( "NO EXCEPTION RAISED FOR 'ACREC13 (A)'" );
93 WHEN CONSTRAINT_ERROR
=>
96 FAILED
( "WRONG EXCEPTION RAISED FOR 'ACREC13 (A)'" );
100 TYPE ARR
IS ARRAY (INTEGER RANGE <>) OF INTEGER;
102 TYPE ACARR
IS ACCESS ARR
;
103 A
: ACARR
(IDENT_INT
(0) .. IDENT_INT
(1)) :=
104 NEW ARR
'(IDENT_INT (0) .. IDENT_INT (1) => 0);
106 SUBTYPE ACARR02 IS ACARR (IDENT_INT (0) .. IDENT_INT (2));
108 PROCEDURE PROC (A : ACARR) IS
111 I := IDENT_INT (A'LAST);
116 FAILED ( "NO EXCEPTION RAISED FOR 'ACARR02
(A
)'" );
118 WHEN CONSTRAINT_ERROR =>
121 FAILED ( "WRONG EXCEPTION RAISED FOR 'ACARR02
(A
)'" );
125 TYPE ARR IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
128 TYPE ACARR IS ACCESS ARR;
129 A : ACARR (IDENT_INT (1) .. IDENT_INT (0),
130 IDENT_INT (4) .. IDENT_INT (5)) :=
131 NEW ARR'(IDENT_INT
(1) .. IDENT_INT
(0) =>
132 (IDENT_INT
(4) .. IDENT_INT
(5) => 0));
134 SUBTYPE NACARR
IS ACARR
(IDENT_INT
(0) .. IDENT_INT
(1),
135 IDENT_INT
(5) .. IDENT_INT
(4));
137 PROCEDURE PROC
(A
: NACARR
) IS
140 I
:= IDENT_INT
(A
'LAST (1));
145 FAILED
( "NO EXCEPTION RAISED FOR 'NACARR (A)'" );
147 WHEN CONSTRAINT_ERROR
=>
150 FAILED
( "WRONG EXCEPTION RAISED FOR 'NACARR (A)'" );
155 TYPE PRIV
(D
: INTEGER) IS PRIVATE;
156 TYPE ACPRV
IS ACCESS PRIV
;
157 SUBTYPE ACPRV3
IS ACPRV
(IDENT_INT
(3));
160 TYPE PRIV
(D
: INTEGER) IS
169 A
: ACPRV
(IDENT_INT
(0)) := NEW PRIV
(IDENT_INT
(0));
174 PROCEDURE PROC
(A
: ACPRV
) IS
177 I
:= IDENT_INT
(A
.D
);
182 FAILED
( "NO EXCEPTION RAISED FOR 'ACPRV3 (A)'" );
184 WHEN CONSTRAINT_ERROR
=>
187 FAILED
( "WRONG EXCEPTION RAISED FOR 'ACPRV3 (A)'" );