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.
27 -- Check that if a discriminant constraint depends on a discriminant,
28 -- the evaluation of the expressions in the constraint is deferred
29 -- until an object of the subtype is created. Check for cases of
30 -- records where the component containing the constraint is present
34 -- This transition test defines record types with discriminant components
35 -- which depend on the discriminants. The discriminants are calculated
36 -- by function calls. The test verifies that Constraint_Error is raised
37 -- during the object creations when values of discriminants are
38 -- incompatible with the subtypes. Also check for cases, where the
39 -- component is absent.
41 -- Inspired by C37213E.ADA, C37213G.ADA, C37215E.ADA, and C37215G.ADA.
45 -- 10 Apr 96 SAIC Initial version for ACVC 2.1.
46 -- 14 Jul 96 SAIC Modified test description. Added exception handler
47 -- for VObj_10 assignment.
48 -- 26 Oct 96 SAIC Added LM references.
56 subtype Small_Int
is Integer range 1..10;
58 type Rec_W_Disc
(Disc1
, Disc2
: Small_Int
) is
60 Str1
: String (1 .. Disc1
) := (others => '*');
61 Str2
: String (1 .. Disc2
) := (others => '*');
64 type My_Array
is array (Small_Int
range <>) of Integer;
66 Func1_Cons
: Integer := 0;
68 ---------------------------------------------------------
69 function Chk
(Cons
: Integer;
71 Message
: String) return Boolean is
74 Report
.Failed
(Message
& ": Func1_Cons is " &
75 Integer'Image(Func1_Cons
));
80 ---------------------------------------------------------
81 function Func1
return Integer is
83 Func1_Cons
:= Func1_Cons
+ Report
.Ident_Int
(1);
89 Report
.Test
("C371003", "Check that if a discriminant constraint " &
90 "depends on a discriminant, the evaluation of the " &
91 "expressions in the constraint is deferred until " &
92 "object declarations");
94 ---------------------------------------------------------
96 type VRec_01
(D3
: Integer) is
100 C1
: Rec_W_Disc
(D3
, Func1
); -- Func1 evaluated, value 1.
102 C2
: Integer := Report
.Ident_Int
(0);
106 Chk1
: Boolean := Chk
(Func1_Cons
, 1,
107 "Func1 not evaluated for VRec_01");
109 VObj_1
: VRec_01
(1); -- Func1 not evaluated again
110 VObj_2
: VRec_01
(2); -- Func1 not evaluated again
112 Chk2
: Boolean := Chk
(Func1_Cons
, 1,
113 "Func1 evaluated too many times");
116 if VObj_1
/= (D3
=> 1,
119 Str1
=> (others => '*'),
120 Str2
=> (others => '*'))) or
124 Str1
=> (others => '*'),
125 Str2
=> (others => '*'))) then
126 Report
.Failed
("VObj_1 & VObj_2 - Discriminant values not correct");
130 ---------------------------------------------------------
134 type VRec_Of_VRec_01
(D3
: Integer) is
138 C1
: Rec_W_Disc
(Func1
, D3
); -- Func1 evaluated, value -10.
139 when others => -- Constraint_Error not raised.
140 C2
: Integer := Report
.Ident_Int
(0);
144 type VRec_Of_VRec_02
(D3
: Integer) is
148 C1
: Rec_W_Disc
(1, D3
);
150 C2
: Integer := Report
.Ident_Int
(0);
154 type VRec_Of_MyArr_01
(D3
: Integer) is
158 C1
: My_Array
(Func1
..D3
); -- Func1 evaluated, value -9.
159 when others => -- Constraint_Error not raised.
160 C2
: Integer := Report
.Ident_Int
(0);
164 type VRec_Of_MyArr_02
(D3
: Integer) is
168 C1
: My_Array
(D3
..1);
170 C2
: Integer := Report
.Ident_Int
(0);
176 ---------------------------------------------------------
177 -- Component containing the constraint is present.
180 VObj_3
: VRec_Of_VRec_01
(1); -- Constraint_Error raised.
182 Report
.Failed
("VObj_3 - Constraint_Error should be raised");
183 if VObj_3
/= (1, (1, 1, others => (others => '*'))) then
184 Report
.Comment
("VObj_3 - Shouldn't get here");
189 when Constraint_Error
=> -- Exception expected.
192 Report
.Failed
("VObj_3 - unexpected exception raised");
195 ---------------------------------------------------------
196 -- Component containing the constraint is present.
199 subtype Subtype_VRec
is -- No Constraint_Error raised.
200 VRec_Of_VRec_01
(Report
.Ident_Int
(1));
203 VObj_4
: Subtype_VRec
; -- Constraint_Error raised.
205 Report
.Failed
("VObj_4 - Constraint_Error should be raised");
206 if VObj_4
/= (D3
=> 1,
209 Str1
=> (others => '*'),
210 Str2
=> (others => '*'))) then
211 Report
.Comment
("VObj_4 - Shouldn't get here");
216 when Constraint_Error
=> -- Exception expected.
219 Report
.Failed
("VObj_4 - unexpected exception raised");
223 when Constraint_Error
=>
224 Report
.Failed
("Subtype_VRec - Constraint_Error raised");
226 Report
.Failed
("Subtype_VRec - unexpected exception raised");
229 ---------------------------------------------------------
230 -- Component containing the constraint is absent.
233 type Arr
is array (1..5) of
234 VRec_Of_VRec_01
(Report
.Ident_Int
(-6)); -- No Constraint_Error
235 VObj_5
: Arr
; -- for either declaration.
238 if VObj_5
/= (1 .. 5 => (-6, 0)) then
239 Report
.Comment
("VObj_5 - wrong values");
245 Report
.Failed
("Arr - unexpected exception raised");
248 ---------------------------------------------------------
249 -- Component containing the constraint is present.
252 type Rec_Of_Rec_Of_MyArr
is
254 C1
: VRec_Of_MyArr_01
(1); -- No Constraint_Error raised.
258 Obj_6
: Rec_Of_Rec_Of_MyArr
; -- Constraint_Error raised.
260 Report
.Failed
("Obj_6 - Constraint_Error should be raised");
261 if Obj_6
/= (C1
=> (1, (1, 1))) then
262 Report
.Comment
("Obj_6 - Shouldn't get here");
267 when Constraint_Error
=> -- Exception expected.
270 Report
.Failed
("Obj_6 - unexpected exception raised");
274 when Constraint_Error
=>
275 Report
.Failed
("Rec_Of_Rec_Of_MyArr - Constraint_Error raised");
277 Report
.Failed
("Rec_Of_Rec_Of_MyArr - unexpected exception " &
281 ---------------------------------------------------------
282 -- Component containing the constraint is absent.
286 new VRec_Of_MyArr_01
(11); -- No Constraint_Error raised
287 Obj_7
: New_VRec_Arr
; -- for either declaration.
290 if Obj_7
/= (11, 0) then
291 Report
.Failed
("Obj_7 - value incorrect");
297 Report
.Failed
("New_VRec_Arr - unexpected exception raised");
300 ---------------------------------------------------------
301 -- Component containing the constraint is present.
305 VRec_Of_VRec_02
(Report
.Ident_Int
(0)); -- No Constraint_Error
309 VObj_8
: New_VRec
; -- Constraint_Error raised.
311 Report
.Failed
("VObj_8 - Constraint_Error should be raised");
312 if VObj_8
/= (1, (1, 1, others => (others => '*'))) then
313 Report
.Comment
("VObj_8 - Shouldn't get here");
318 when Constraint_Error
=> -- Exception expected.
321 Report
.Failed
("VObj_8 - unexpected exception raised");
325 when Constraint_Error
=>
326 Report
.Failed
("New_VRec - Constraint_Error raised");
328 Report
.Failed
("New_VRec - unexpected exception raised");
331 ---------------------------------------------------------
332 -- Component containing the constraint is absent.
336 VRec_Of_VRec_02
(Report
.Ident_Int
(11)); -- No Constraint_Error
337 VObj_9
: Sub_VRec
; -- raised for either
340 if VObj_9
/= (11, 0) then
341 Report
.Comment
("VObj_9 - wrong values");
347 Report
.Failed
("Sub_VRec - unexpected exception raised");
350 ---------------------------------------------------------
351 -- Component containing the constraint is present.
354 type Acc_VRec_01
is access
355 VRec_Of_VRec_02
(Report
.Ident_Int
(0)); -- No Constraint_Error
359 VObj_10
: Acc_VRec_01
; -- No Constraint_Error
362 VObj_10
:= new VRec_Of_VRec_02
363 (Report
.Ident_Int
(0)); -- Constraint_Error
365 Report
.Failed
("VObj_10 - Constraint_Error should be raised");
366 if VObj_10
.all /= (1, (1, 1, others => (others => '*'))) then
367 Report
.Comment
("VObj_10 - Shouldn't get here");
371 when Constraint_Error
=> -- Exception expected.
374 Report
.Failed
("VObj_10 - unexpected exception raised");
378 when Constraint_Error
=>
379 Report
.Failed
("VObj_10 - Constraint_Error exception raised");
381 Report
.Failed
("VObj_10 - unexpected exception raised at " &
386 when Constraint_Error
=>
387 Report
.Failed
("Acc_VRec_01 - Constraint_Error raised");
389 Report
.Failed
("Acc_VRec_01 - unexpected exception raised");
392 ---------------------------------------------------------
393 -- Component containing the constraint is absent.
396 type Acc_VRec_02
is access
397 VRec_Of_VRec_02
(11); -- No Constraint_Error
399 VObj_11
: Acc_VRec_02
; -- declaration.
402 VObj_11
:= new VRec_Of_VRec_02
(11);
403 if VObj_11
.all /= (11, 0) then
404 Report
.Comment
("VObj_11 - wrong values");
410 Report
.Failed
("Acc_VRec_02 - unexpected exception raised");
413 ---------------------------------------------------------
414 -- Component containing the constraint is present.
417 type Acc_VRec_03
is access
418 VRec_Of_MyArr_02
; -- No Constraint_Error
420 VObj_12
: Acc_VRec_03
; -- declaration.
422 VObj_12
:= new VRec_Of_MyArr_02
423 (Report
.Ident_Int
(0)); -- Constraint_Error raised.
425 Report
.Failed
("VObj_12 - Constraint_Error should be raised");
426 if VObj_12
.all /= (1, (1, 1)) then
427 Report
.Comment
("VObj_12 - Shouldn't get here");
431 when Constraint_Error
=> -- Exception expected.
434 Report
.Failed
("VObj_12 - unexpected exception raised");
438 when Constraint_Error
=>
439 Report
.Failed
("Acc_VRec_03 - Constraint_Error raised");
441 Report
.Failed
("Acc_VRec_03 - unexpected exception raised");
444 ---------------------------------------------------------
445 -- Component containing the constraint is absent.
448 type Acc_VRec_04
is access
449 VRec_Of_MyArr_02
(11); -- No Constraint_Error
451 VObj_13
: Acc_VRec_04
; -- declaration.
454 VObj_13
:= new VRec_Of_MyArr_02
(11);
455 if VObj_13
.all /= (11, 0) then
456 Report
.Comment
("VObj_13 - wrong values");
462 Report
.Failed
("Acc_VRec_04 - unexpected exception raised");
471 Report
.Failed
("Discriminant value checked too soon");