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 -- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN
27 -- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE
28 -- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE A
29 -- DERIVED OR AN ACCESS TYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS
30 -- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY:
31 -- 1) ONLY IN AN OBJECT DECLARATION OR ALLOCATOR, AND
32 -- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT
36 -- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J.
37 -- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY
38 -- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL
39 -- PARAMETERS TO THE GENERIC UNITS AND THE
40 -- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE
41 -- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE
42 -- ARE TOGETHER; REWROTE ONE OF THE GENERIC
43 -- PACKAGES AS A GENERIC PROCEDURE TO BROADEN
46 WITH REPORT
; USE REPORT
;
49 TEST
("C37213L", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " &
50 "OR AN INDEX CONSTRAINT THAT DEPEND ON A " &
51 "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " &
52 "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " &
53 "USED AS THE ACTUAL PARAMETER TO A GENERIC " &
54 "FORMAL TYPE USED TO DECLARE A DERIVED OR AN " &
58 SUBTYPE SM
IS INTEGER RANGE 1..10;
59 TYPE REC
(D1
, D2
: SM
) IS
60 RECORD NULL; END RECORD;
61 TYPE MY_ARR
IS ARRAY (SM
RANGE <>) OF INTEGER;
63 SEQUENCE_NUMBER
: INTEGER;
69 PACKAGE DER_CHK
IS END DER_CHK
;
71 PACKAGE BODY DER_CHK
IS
74 TYPE DREC
IS NEW CONS
;
79 FUNCTION VALUE
RETURN DREC
IS
89 FAILED
("NO CHECK DURING DECLARATION " &
90 "OF OBJECT OF TYPE DREC - " &
93 FAILED
("INCORRECT VALUE FOR OBJECT OF " &
94 "TYPE DREC - " & TAG
);
98 WHEN CONSTRAINT_ERROR
=>
100 FAILED
("IMPROPER CONSTRAINT CHECKED " &
101 "DURING DECLARATION OF OBJECT " &
102 "OF TYPE DREC - " & TAG
);
106 WHEN CONSTRAINT_ERROR
=>
107 FAILED
("CONSTRAINT IMPROPERLY CHECKED " &
108 "DURING DECLARATION OF DREC - " & TAG
);
112 TYPE CONS
IS PRIVATE;
113 PROCEDURE ACC_CHK
(OBJ_XCP
: BOOLEAN;
116 PROCEDURE ACC_CHK
(OBJ_XCP
: BOOLEAN;
120 TYPE ACC_CONS
IS ACCESS CONS
;
125 FUNCTION VALUE
RETURN CONS
IS
137 FAILED
("NO CHECK DURING ALLOCATION " &
138 "OF OBJECT OF TYPE CONS - " &
140 ELSIF X
.ALL /= VALUE
THEN
141 FAILED
("INCORRECT VALUE FOR OBJECT " &
142 "OF TYPE CONS - " & TAG
);
145 WHEN CONSTRAINT_ERROR
=>
147 FAILED
("IMPROPER CONSTRAINT " &
149 "ALLOCATION OF OBJECT " &
150 "OF TYPE CONS - " & TAG
);
154 WHEN CONSTRAINT_ERROR
=>
155 FAILED
("CONSTRAINT IMPROPERLY CHECKED " &
156 "DURING DECLARATION OF X - " & TAG
);
159 WHEN CONSTRAINT_ERROR
=>
160 FAILED
("CONSTRAINT IMPROPERLY CHECKED " &
161 "DURING DECLARATION OF ACC_CONS - " & TAG
);
164 SEQUENCE_NUMBER
:= 1;
166 TYPE REC_DEF
(D3
: INTEGER := 1) IS
171 PACKAGE PACK1
IS NEW DER_CHK
(REC_DEF
,
175 PROCEDURE PROC1
IS NEW ACC_CHK
(REC_DEF
);
177 PROC1
(OBJ_XCP
=> TRUE, TAG
=> "PROC1");
180 SEQUENCE_NUMBER
:= 2;
182 TYPE ARR_DEF
(D3
: INTEGER := IDENT_INT
(1)) IS
187 PACKAGE PACK2
IS NEW DER_CHK
(ARR_DEF
,
191 PROCEDURE PROC2
IS NEW ACC_CHK
(ARR_DEF
);
193 PROC2
(OBJ_XCP
=> TRUE, TAG
=> "PROC2");
196 SEQUENCE_NUMBER
:= 3;
198 TYPE VAR_REC_DEF1
(D3
: INTEGER := 1) IS
202 C1
: REC
(D3
, IDENT_INT
(11));
204 C2
: INTEGER := IDENT_INT
(5);
208 PACKAGE PACK3
IS NEW DER_CHK
(VAR_REC_DEF1
,
212 PROCEDURE PROC3
IS NEW ACC_CHK
(VAR_REC_DEF1
);
214 PROC3
(OBJ_XCP
=> TRUE, TAG
=> "PROC3");
217 SEQUENCE_NUMBER
:= 4;
219 TYPE VAR_REC_DEF6
(D3
: INTEGER := IDENT_INT
(-6)) IS
223 C1
: REC
(D3
, IDENT_INT
(11));
225 C2
: INTEGER := IDENT_INT
(5);
229 PACKAGE PACK4
IS NEW DER_CHK
(VAR_REC_DEF6
,
233 PROCEDURE PROC4
IS NEW ACC_CHK
(VAR_REC_DEF6
);
235 PROC4
(OBJ_XCP
=> FALSE, TAG
=> "PROC4");
238 SEQUENCE_NUMBER
:= 5;
240 TYPE VAR_REC_DEF11
(D3
: INTEGER := 11) IS
244 C1
: REC
(D3
, IDENT_INT
(11));
246 C2
: INTEGER := IDENT_INT
(5);
250 PACKAGE PACK5
IS NEW DER_CHK
(VAR_REC_DEF11
,
254 PROCEDURE PROC5
IS NEW ACC_CHK
(VAR_REC_DEF11
);
256 PROC5
(OBJ_XCP
=> FALSE, TAG
=> "PROC5");
259 SEQUENCE_NUMBER
:= 6;
261 TYPE VAR_ARR_DEF1
(D3
: INTEGER := IDENT_INT
(1)) IS
265 C1
: MY_ARR
(D3
..IDENT_INT
(11));
267 C2
: INTEGER := IDENT_INT
(5);
271 PACKAGE PACK6
IS NEW DER_CHK
(VAR_ARR_DEF1
,
275 PROCEDURE PROC6
IS NEW ACC_CHK
(VAR_ARR_DEF1
);
277 PROC6
(OBJ_XCP
=> TRUE, TAG
=> "PROC6");
280 SEQUENCE_NUMBER
:= 7;
282 TYPE VAR_ARR_DEF6
(D3
: INTEGER := -6) IS
286 C1
: MY_ARR
(D3
..IDENT_INT
(11));
288 C2
: INTEGER := IDENT_INT
(5);
292 PACKAGE PACK7
IS NEW DER_CHK
(VAR_ARR_DEF6
,
296 PROCEDURE PROC7
IS NEW ACC_CHK
(VAR_ARR_DEF6
);
298 PROC7
(OBJ_XCP
=> FALSE, TAG
=> "PROC7");
301 SEQUENCE_NUMBER
:= 8;
303 TYPE VAR_ARR_DEF11
(D3
: INTEGER := IDENT_INT
(11)) IS
307 C1
: MY_ARR
(D3
..IDENT_INT
(11));
309 C2
: INTEGER := IDENT_INT
(5);
313 PACKAGE PACK8
IS NEW DER_CHK
(VAR_ARR_DEF11
,
317 PROCEDURE PROC8
IS NEW ACC_CHK
(VAR_ARR_DEF11
);
319 PROC8
(OBJ_XCP
=> FALSE, TAG
=> "PROC8");
323 FAILED
("UNEXPECTED EXCEPTION RAISED DURING " &
324 "DECLARATION / INSTANTIATION ELABORATION - " &
325 INTEGER'IMAGE (SEQUENCE_NUMBER
));