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, WHERE AN INDEX CONSTRAINT DEPENDS ON A RECORD
27 -- DISCRIMINANT WITH A DEFAULT VALUE AND THE RECORD TYPE IS NOT
28 -- EXPLICITLY CONSTRAINED, THAT THE NON-DISCRIMINANT EXPRESSIONS
29 -- IN THE INDEX CONSTRAINT ARE:
30 -- 1) EVALUATED WHEN THE RECORD COMPONENT SUBTYPE DEFINITION
32 -- 2) PROPERLY CHECKED FOR COMPATIBILITY ONLY IN AN ALLOCATION
33 -- OR OBJECT DECLARATION AND ONLY IF THE DISCRIMINANT-
34 -- DEPENDENT COMPONENT IS PRESENT IN THE SUBTYPE.
37 -- JBG 10/17/86 CREATED ORIGINAL TEST.
38 -- VCL 10/23/87 MODIFIED THIS HEADER; MODIFIED THE CHECK OF
39 -- SUBTYPE 'SCONS', IN BOTH SUBPARTS OF THE TEST,
40 -- TO INDICATE FAILURE IF CONSTRAINT_ERROR IS RAISED
41 -- FOR THE SUBTYPE DECLARATION AND FAILURE IF
42 -- CONSTRAINT_ERROR IS NOT RAISED FOR AN OBJECT
43 -- DECLARATION OF THIS SUBTYPE; RELOCATED THE CALL TO
44 -- REPORT.TEST SO THAT IT COMES BEFORE ANY
45 -- DECLARATIONS; ADDED 'SEQUENCE_NUMBER' TO IDENTIFY
46 -- THE CURRENT SUBTEST (FOR EXCEPTIONS); CHANGE THE
47 -- TYPE OF THE DISCRIMINANT IN THE RECORD 'CONS'
48 -- TO AN INTEGER SUBTYPE.
49 -- VCL 03/30/88 MODIFIED HEADER AND MESSAGES OUTPUT BY REPORT
52 WITH REPORT
; USE REPORT
;
55 TEST
("C37213H", "THE NON-DISCRIMINANT EXPRESSIONS OF AN " &
56 "INDEX CONSTRAINT THAT DEPEND ON A " &
57 "DISCRIMINANT WITH A DEFAULT VALUE ARE " &
58 "PROPERLY EVALUATED AND CHECKED WHEN THE " &
59 "RECORD TYPE IS NOT EXPLICITLY CONSTRAINED AND " &
60 "THE COMPONENT IS AND IS NOT PRESENT IN THE " &
64 SEQUENCE_NUMBER
: INTEGER;
66 SUBTYPE DISCR
IS INTEGER RANGE -50..50;
67 SUBTYPE SM
IS INTEGER RANGE 1..10;
68 TYPE MY_ARR
IS ARRAY (SM
RANGE <>) OF INTEGER;
70 F1_CONS
: INTEGER := 2;
75 MESSAGE
: STRING) RETURN BOOLEAN IS
78 FAILED
(MESSAGE
& ": F1_CONS IS " &
79 INTEGER'IMAGE(F1_CONS
));
84 FUNCTION F1
RETURN INTEGER IS
86 F1_CONS
:= F1_CONS
- IDENT_INT
(1);
92 -- CASE 1: DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT.
96 TYPE CONS
(D3
: DISCR
:= IDENT_INT
(1)) IS
100 C1
: MY_ARR
(F1
..D3
); -- F1 EVALUATED.
102 C2
: INTEGER := IDENT_INT
(0);
106 CHK1
: BOOLEAN := CHK
(F1_CONS
, 1, "F1 NOT EVALUATED");
108 X
: CONS
; -- F1 NOT EVALUATED AGAIN.
109 Y
: CONS
; -- F1 NOT EVALUATED AGAIN.
111 CHK2
: BOOLEAN := CHK
(F1_CONS
, 1, "F1 EVALUATED");
113 IF X
.C1
'FIRST /= 1 OR Y
.C1
'LAST /= 1 THEN
114 FAILED
("VALUES NOT CORRECT");
121 SEQUENCE_NUMBER
:= 2;
123 TYPE CONS
(D3
: DISCR
:= IDENT_INT
(1)) IS
129 C2
: INTEGER := IDENT_INT
(0);
137 FAILED
("INDEX CHECK NOT PERFORMED - 1");
138 IF X
/= (1, (1, 1)) THEN
139 COMMENT
("INCORRECT VALUES FOR X - 1");
143 WHEN CONSTRAINT_ERROR
=>
146 FAILED
("UNEXPECTED EXCEPTION RAISED - 1");
151 SUBTYPE SCONS
IS CONS
;
156 FAILED
("INDEX CHECK NOT PERFORMED - 2");
157 IF X
/= (1, (1, 1)) THEN
158 COMMENT
("INCORRECT VALUES FOR X " &
163 WHEN CONSTRAINT_ERROR
=>
166 FAILED
("UNEXPECTED EXCEPTION RAISED " &
171 FAILED
("UNEXPECTED EXCEPTION RAISED - 2B");
176 TYPE ARR
IS ARRAY (1..5) OF CONS
;
181 FAILED
("INDEX CHECK NOT PERFORMED - 3");
182 IF X
/= (1..5 => (1, (1, 1))) THEN
183 COMMENT
("INCORRECT VALUES FOR X " &
188 WHEN CONSTRAINT_ERROR
=>
191 FAILED
("UNEXPECTED EXCEPTION RAISED " &
196 FAILED
("UNEXPECTED EXCEPTION RAISED - 3B");
209 FAILED
("INDEX CHECK NOT PERFORMED - 4");
210 IF X
/= (C1
=> (1, (1, 1))) THEN
211 COMMENT
("INCORRECT VALUES FOR X " &
216 WHEN CONSTRAINT_ERROR
=>
219 FAILED
("UNEXPECTED EXCEPTION RAISED " &
224 FAILED
("UNEXPECTED EXCEPTION RAISED - 4B");
229 TYPE NREC
IS NEW CONS
;
234 FAILED
("INDEX CHECK NOT PERFORMED - 5");
235 IF X
/= (1, (1, 1)) THEN
236 COMMENT
("INCORRECT VALUES FOR X " &
241 WHEN CONSTRAINT_ERROR
=>
244 FAILED
("UNEXPECTED EXCEPTION RAISED " &
249 FAILED
("UNEXPECTED EXCEPTION RAISED - 5B");
254 TYPE ACC_CONS
IS ACCESS CONS
;
260 FAILED
("INDEX CHECK NOT PERFORMED - 6");
261 IF X
.ALL /= (1, (1, 1)) THEN
262 COMMENT
("INCORRECT VALUES FOR X " &
266 WHEN CONSTRAINT_ERROR
=>
269 COMMENT
("UNEXPECTED EXCEPTION " &
274 COMMENT
("UNEXPECTED EXCEPTION RAISED " &
279 FAILED
("UNEXPECTED EXCEPTION RAISED - 6C");
284 -- CASE D2: DISCRIMINANT-DEPENDENT COMPONENT IS ABSENT.
288 SEQUENCE_NUMBER
:= 3;
290 TYPE CONS
(D3
: DISCR
:= IDENT_INT
(-6)) IS
294 C1
: MY_ARR
(D3
..F1
); -- F1 EVALUATED.
296 C2
: INTEGER := IDENT_INT
(0);
299 CHK1
: BOOLEAN := CHK
(F1_CONS
, 1, "F1 NOT EVALUATED");
301 X
: CONS
; -- F1 NOT EVALUATED AGAIN.
302 Y
: CONS
; -- F1 NOT EVALUATED AGAIN.
304 CHK2
: BOOLEAN := CHK
(F1_CONS
, 1, "F1 EVALUATED");
306 IF X
/= (-6, 0) OR Y
/= (-6, 0) THEN
307 FAILED
("VALUES NOT CORRECT");
313 SEQUENCE_NUMBER
:= 4;
315 TYPE CONS
(D3
: DISCR
:= IDENT_INT
(11)) IS
321 C2
: INTEGER := IDENT_INT
(0);
330 FAILED
("X VALUE IS INCORRECT - 11");
335 FAILED
("UNEXPECTED EXCEPTION RAISED - 11");
340 SUBTYPE SCONS
IS CONS
;
346 FAILED
("X VALUE INCORRECT - 12");
351 FAILED
("UNEXPECTED EXCEPTION RAISED - " &
356 FAILED
("UNEXPECTED EXCEPTION RAISED - 12B");
361 TYPE ARR
IS ARRAY (1..5) OF CONS
;
366 IF X
/= (1..5 => (11, 0)) THEN
367 FAILED
("X VALUE INCORRECT - 13");
372 FAILED
("UNEXPECTED EXCEPTION RAISED - " &
377 FAILED
("UNEXPECTED EXCEPTION RAISED - 13B");
390 IF X
/= (C1
=> (11, 0)) THEN
391 FAILED
("X VALUE INCORRECT - 14");
396 FAILED
("UNEXPECTED EXCEPTION RAISED - " &
401 FAILED
("UNEXPECTED EXCEPTION RAISED - 14B");
406 TYPE NREC
IS NEW CONS
;
412 FAILED
("X VALUE INCORRECT - 15");
416 WHEN CONSTRAINT_ERROR
=>
419 FAILED
("UNEXPECTED EXCEPTION RAISED - " &
424 FAILED
("UNEXPECTED EXCEPTION RAISED - 15B");
429 TYPE ACC_CONS
IS ACCESS CONS
;
433 IF X
.ALL /= (11, 0) THEN
434 FAILED
("X VALUE INCORRECT - 17");
438 FAILED
("UNEXPECTED EXCEPTION RAISED - " &
443 FAILED
("UNEXPECTED EXCEPTION RAISED - 17B");
448 WHEN CONSTRAINT_ERROR
=>
449 FAILED
("INDEX VALUES IMPROPERLY CHECKED - " &
450 INTEGER'IMAGE (SEQUENCE_NUMBER
));
452 FAILED
("UNEXPECTED EXCEPTION RAISED " &
453 INTEGER'IMAGE (SEQUENCE_NUMBER
));