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 AN
29 -- OBJECT OR A SUBTYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS
30 -- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY:
31 -- 1) ONLY IN AN OBJECT DECLARATION, AND
32 -- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT
36 -- JBG 10/17/86 CREATED ORIGINAL TEST.
37 -- VCL 10/23/87 MODIFIED THIS HEADER; SEPARATED THIS TEST INTO
38 -- 3 NEW TESTS (J,K,L); CHANGED THE AGGREGATE FOR
39 -- THE PARAMETER 'VALUE' IN THE CALL OF PROCEDURE
40 -- 'SUBTYPE_CHK1'; MOVED THE CALL TO REPORT.TEST
41 -- SO THAT IT COMES BEFORE ANY DECLARATIONS; ADDED
42 -- A SEQUENCE COUNTER TO IDENTIFY WHICH SUBTEST
43 -- DECLARATION PART RAISES CONSTRAINT_ERROR.
44 -- VCL 03/28/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY
45 -- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL
46 -- PARAMETERS TO THE GENERIC UNITS AND THE
47 -- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE
48 -- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE
51 WITH REPORT
; USE REPORT
;
54 TEST
("C37213J", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " &
55 "OR AN INDEX CONSTRAINT THAT DEPEND ON A " &
56 "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " &
57 "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " &
58 "USED AS THE ACTUAL PARAMETER TO A GENERIC " &
59 "FORMAL TYPE USED TO DECLARE AN OBJECT OR A " &
63 SUBTYPE SM
IS INTEGER RANGE 1..10;
64 TYPE REC
(D1
, D2
: SM
) IS
65 RECORD NULL; END RECORD;
66 TYPE MY_ARR
IS ARRAY (SM
RANGE <>) OF INTEGER;
68 SEQUENCE_NUMBER
: INTEGER;
74 PACKAGE OBJ_CHK
IS END OBJ_CHK
;
78 PROCEDURE SUBTYP_CHK
(OBJ_XCP
: BOOLEAN;
81 PACKAGE BODY OBJ_CHK
IS
82 BEGIN -- DECLARE AN OBJECT OF THE FORMAL TYPE.
86 FUNCTION VALUE
RETURN CONS
IS
96 FAILED
("NO CHECK DURING DECLARATION " &
97 "OF OBJECT OF TYPE CONS - " & TAG
);
99 FAILED
("INCORRECT VALUE FOR OBJECT OF " &
100 "TYPE CONS - " & TAG
);
104 WHEN CONSTRAINT_ERROR
=>
106 FAILED
("IMPROPER CONSTRAINT CHECKED " &
107 "DURING DECLARATION OF OBJECT " &
108 "OF TYPE CONS - " & TAG
);
112 PROCEDURE SUBTYP_CHK
(OBJ_XCP
: BOOLEAN;
114 BEGIN -- DECLARE A SUBTYPE OF THE FORMAL TYPE.
116 SUBTYPE SCONS
IS CONS
;
121 FUNCTION VALUE
RETURN SCONS
IS
131 FAILED
("NO CHECK DURING DECLARATION " &
132 "OF OBJECT OF SUBTYPE SCONS - " &
134 ELSIF X
/= VALUE
THEN
135 FAILED
("INCORRECT VALUE FOR OBJECT " &
136 "OF SUBTYPE SCONS - " & TAG
);
140 WHEN CONSTRAINT_ERROR
=>
142 FAILED
("IMPROPER CONSTRAINT CHECKED " &
143 "DURING DECLARATION OF OBJECT " &
144 "OF SUBTYPE SCONS - " & TAG
);
148 WHEN CONSTRAINT_ERROR
=>
149 FAILED
("CONSTRAINT IMPROPERLY CHECKED " &
150 "DURING SUBTYPE DECLARATION - " & TAG
);
153 SEQUENCE_NUMBER
:= 1;
155 TYPE REC_DEF
(D3
: INTEGER := 1) IS
160 PACKAGE PACK1
IS NEW OBJ_CHK
(REC_DEF
,
164 PROCEDURE PROC1
IS NEW SUBTYP_CHK
(REC_DEF
);
166 PROC1
(OBJ_XCP
=> TRUE, TAG
=> "PROC1");
169 SEQUENCE_NUMBER
:= 2;
171 TYPE ARR_DEF
(D3
: INTEGER := IDENT_INT
(1)) IS
176 PACKAGE PACK2
IS NEW OBJ_CHK
(ARR_DEF
,
180 PROCEDURE PROC2
IS NEW SUBTYP_CHK
(ARR_DEF
);
182 PROC2
(OBJ_XCP
=> TRUE, TAG
=> "PROC2");
186 SEQUENCE_NUMBER
:= 3;
188 TYPE VAR_REC_DEF1
(D3
: INTEGER := 1) IS
192 C1
: REC
(D3
, IDENT_INT
(11));
194 C2
: INTEGER := IDENT_INT
(5);
198 PACKAGE PACK3
IS NEW OBJ_CHK
(VAR_REC_DEF1
,
202 PROCEDURE PROC3
IS NEW SUBTYP_CHK
(VAR_REC_DEF1
);
204 PROC3
(OBJ_XCP
=> TRUE, TAG
=> "PROC3");
207 SEQUENCE_NUMBER
:= 4;
209 TYPE VAR_REC_DEF6
(D3
: INTEGER := IDENT_INT
(-6)) IS
213 C1
: REC
(D3
, IDENT_INT
(11));
215 C2
: INTEGER := IDENT_INT
(5);
219 PACKAGE PACK4
IS NEW OBJ_CHK
(VAR_REC_DEF6
,
223 PROCEDURE PROC4
IS NEW SUBTYP_CHK
(VAR_REC_DEF6
);
225 PROC4
(OBJ_XCP
=> FALSE,TAG
=> "PROC4");
228 SEQUENCE_NUMBER
:= 5;
230 TYPE VAR_REC_DEF11
(D3
: INTEGER := 11) IS
234 C1
: REC
(D3
, IDENT_INT
(11));
236 C2
: INTEGER := IDENT_INT
(5);
240 PACKAGE PACK5
IS NEW OBJ_CHK
(VAR_REC_DEF11
,
244 PROCEDURE PROC5
IS NEW SUBTYP_CHK
(VAR_REC_DEF11
);
246 PROC5
(OBJ_XCP
=> FALSE, TAG
=> "PROC5");
249 SEQUENCE_NUMBER
:= 6;
251 TYPE VAR_ARR_DEF1
(D3
: INTEGER := IDENT_INT
(1)) IS
255 C1
: MY_ARR
(D3
..IDENT_INT
(11));
257 C2
: INTEGER := IDENT_INT
(5);
261 PACKAGE PACK6
IS NEW OBJ_CHK
(VAR_ARR_DEF1
,
265 PROCEDURE PROC6
IS NEW SUBTYP_CHK
(VAR_ARR_DEF1
);
267 PROC6
(OBJ_XCP
=> TRUE, TAG
=> "PROC6");
270 SEQUENCE_NUMBER
:= 7;
272 TYPE VAR_ARR_DEF6
(D3
: INTEGER := -6) IS
276 C1
: MY_ARR
(D3
..IDENT_INT
(11));
278 C2
: INTEGER := IDENT_INT
(5);
282 PACKAGE PACK7
IS NEW OBJ_CHK
(VAR_ARR_DEF6
,
286 PROCEDURE PROC7
IS NEW SUBTYP_CHK
(VAR_ARR_DEF6
);
288 PROC7
(OBJ_XCP
=> FALSE, TAG
=> "PROC7");
291 SEQUENCE_NUMBER
:= 8;
293 TYPE VAR_ARR_DEF11
(D3
: INTEGER := IDENT_INT
(11)) IS
297 C1
: MY_ARR
(D3
..IDENT_INT
(11));
299 C2
: INTEGER := IDENT_INT
(5);
303 PACKAGE PACK8
IS NEW OBJ_CHK
(VAR_ARR_DEF11
,
307 PROCEDURE PROC8
IS NEW SUBTYP_CHK
(VAR_ARR_DEF11
);
309 PROC8
(OBJ_XCP
=> FALSE, TAG
=> "PROC8");
314 FAILED
("EXCEPTION RAISED DURING DECLARATION / " &
315 "INSTANTIATION ELABORATION - " &
316 INTEGER'IMAGE(SEQUENCE_NUMBER
));