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 the type of the ancestor part of an extension aggregate
28 -- has discriminants that are not inherited by the type of the aggregate,
29 -- and the ancestor part is a subtype mark that denotes a constrained
30 -- subtype, Constraint_Error is raised if: 1) any discriminant of the
31 -- ancestor has a different value than that specified for a corresponding
32 -- discriminant in the derived type definition for some ancestor of the
33 -- type of the aggregate, or 2) the value for the discriminant in the
34 -- record association list is not the value of the corresponding
35 -- discriminant. Check that the components of the value of the
36 -- aggregate not given by the record component association list are
37 -- initialized by default as for an object of the ancestor type.
42 -- type T (D1: ...) is tagged ...
44 -- type DT is new T with ...
45 -- subtype ST is DT (D1 => 3); -- Constrained subtype.
47 -- type NT1 (D2: ...) is new DT (D1 => D2) with null record;
48 -- type NT2 (D2: ...) is new DT (D1 => 6) with null record;
49 -- type NT3 is new DT (D1 => 6) with null record;
51 -- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained.
52 -- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained.
53 -- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2.
55 -- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained.
56 -- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained.
57 -- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2.
59 -- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained.
60 -- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained.
61 -- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3.
63 -- In A, B, D, E, G, and H the ancestor part is the name of an
64 -- unconstrained subtype, so this rule does not apply. In C, F, and I
65 -- the ancestor part (ST) is the name of a constrained subtype of DT,
66 -- which is itself a derived type of a discriminated tagged type T. ST
67 -- constrains the discriminant of DT (D1) to the value 3; thus, the
68 -- type of any extension aggregate for which ST is the ancestor part
69 -- must have an ancestor which also constrained D1 to 3. F and I raise
70 -- Constraint_Error because NT2 and NT3, respectively, constrain D1 to
71 -- 6. C raises Constraint_Error because NT1 constrains D1 to the value
72 -- of D2, which is set to 6 in the record component association list of
75 -- This test verifies each of the three scenarios above:
77 -- (1) Ancestor of type of aggregate constrains discriminant with
79 -- (2) Ancestor of type of aggregate constrains discriminant with
80 -- value, and has a new discriminant part.
81 -- (3) Ancestor of type of aggregate constrains discriminant with
82 -- value, and has no discriminant part.
84 -- Verification is made for cases where the type of the aggregate is
85 -- once- and twice-removed from the type of the ancestor part.
87 -- Additionally, a case is included where a new discriminant corresponds
88 -- to multiple discriminants of the type of the ancestor part.
90 -- To test the portion of the objective concerning "initialization by
91 -- default," the test verifies that, after a successful aggregate
92 -- assignment, components not assigned an explicit value by the aggregate
93 -- contain the default values for the corresponding components of the
98 -- 06 Dec 94 SAIC ACVC 2.0
99 -- 15 Dec 94 SAIC Removed discriminant defaults from tagged types.
100 -- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint
101 -- for component NT_C3.Str2. Added missing component
102 -- checks. Removed record component update from
103 -- Avoid_Optimization. Fixed incorrect component
105 -- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for
112 Default_String
: constant String := "This is a default string"; -- len = 24
113 Another_String
: constant String := "Another default string"; -- len = 22
115 subtype Length
is Natural range 0..255;
117 type ROOT
(D1
: Length
) is tagged
119 S1
: String (1..D1
) := Default_String
(1..D1
);
120 Acc
: Natural := 356;
123 procedure Avoid_Optimization
(Rec
: in out ROOT
); -- Inherited by all type
126 type Unconstrained_Der
is new ROOT
with
128 Str1
: String(1..5) := "abcde";
131 subtype Constrained_Subtype
is Unconstrained_Der
(D1
=> 10);
133 type NT_A1
(D2
: Length
) is new Unconstrained_Der
(D1
=> D2
) with
135 S2
: String(1..D2
); -- Inherited discrim. constrained by
136 end record; -- new discriminant.
138 type NT_A2
(D3
: Length
) is new NT_A1
(D2
=> D3
) with
140 S3
: String(1..D3
); -- Inherited discrim. constrained by
141 end record; -- new discriminant.
144 type NT_B1
(D2
: Length
) is new Unconstrained_Der
(D1
=> 5) with
146 S2
: String(1..D2
); -- Inherited discrim. constrained by
147 end record; -- explicit value.
149 type NT_B2
(D3
: Length
) is new NT_B1
(D2
=> 10) with
151 S3
: String(1..D3
); -- Inherited discrim. constrained by
152 end record; -- explicit value.
154 type NT_B3
(D2
: Length
) is new Unconstrained_Der
(D1
=> 10) with
160 type NT_C1
is new Unconstrained_Der
(D1
=> 5) with
162 Str2
: String(1..5); -- Inherited discrim. constrained
163 end record; -- No new value.
165 type NT_C2
(D2
: Length
) is new NT_C1
with
167 S2
: String(1..D2
); -- Inherited discrim. not further
168 end record; -- constrained, new discriminant.
170 type NT_C3
is new Unconstrained_Der
(D1
=> 10) with
176 type MULTI_ROOT
(D1
: Length
; D2
: Length
) is tagged
178 S1
: String (1..D1
) := Default_String
(1..D1
);
179 S2
: String (1..D2
) := Another_String
(1..D2
);
182 procedure Avoid_Optimization
(Rec
: in out MULTI_ROOT
); -- Inherited by all
185 type Mult_Unconstr_Der
is new MULTI_ROOT
with
187 Str1
: String(1..8) := "AbCdEfGh"; -- Derived, no constraints.
190 -- Subtypes with constrained discriminants.
191 subtype Mult_Constr_Sub1
is Mult_Unconstr_Der
(D1
=> 15, -- Disc. have
192 D2
=> 20); -- diff values
194 subtype Mult_Constr_Sub2
is Mult_Unconstr_Der
(D1
=> 15, -- Disc. have
195 D2
=> 15); -- same value
197 type Mult_NT_A1
(D3
: Length
) is
198 new Mult_Unconstr_Der
(D1
=> D3
, D2
=> D3
) with
200 S3
: String(1..D3
); -- Both inherited discriminants constrained
201 end record; -- by new discriminant.
206 --=====================================================================--
210 package body C432003_0
is
212 procedure Avoid_Optimization
(Rec
: in out ROOT
) is
214 Rec
.S1
:= Report
.Ident_Str
(Rec
.S1
);
215 end Avoid_Optimization
;
217 procedure Avoid_Optimization
(Rec
: in out MULTI_ROOT
) is
219 Rec
.S1
:= Report
.Ident_Str
(Rec
.S1
);
220 end Avoid_Optimization
;
225 --=====================================================================--
233 Report
.Test
("C432003", "Extension aggregates where ancestor part " &
234 "is a subtype mark that denotes a constrained " &
235 "subtype causing Constraint_Error if any " &
236 "discriminant of the ancestor has a different " &
237 "value than that specified for a corresponding " &
238 "discriminant in the derived type definition " &
239 "for some ancestor of the type of the aggregate");
244 -- Variety of string object declarations.
245 String2
: String(1..2) := Report
.Ident_Str
("12");
246 String5
: String(1..5) := Report
.Ident_Str
("12345");
247 String8
: String(1..8) := Report
.Ident_Str
("AbCdEfGh");
248 String10
: String(1..10) := Report
.Ident_Str
("1234567890");
249 String15
: String(1..15) := Report
.Ident_Str
("123456789012345");
250 String20
: String(1..20) := Report
.Ident_Str
("12345678901234567890");
257 A
: C432003_0
.NT_A1
:= -- OK
258 (C432003_0
.ROOT
with D2
=> 5,
262 C432003_0
.Avoid_Optimization
(A
);
267 A
.S1
/= C432003_0
.Default_String
(1..5)
269 Report
.Failed
("Incorrect object values for Object A");
273 when Constraint_Error
=>
274 Report
.Failed
("Constraint_Error raised for Object A");
280 C
: C432003_0
.NT_A1
:= -- OK
281 (C432003_0
.Constrained_Subtype
with D2
=> 10,
284 C432003_0
.Avoid_Optimization
(C
);
285 if C
.D2
/= 10 or C
.Acc
/= 356 or
286 C
.Str1
/= "abcde" or C
.S2
/= String10
or
287 C
.S1
/= C432003_0
.Default_String
(1..10)
289 Report
.Failed
("Incorrect object values for Object C");
293 when Constraint_Error
=>
294 Report
.Failed
("Constraint_Error raised for Object C");
300 D
: C432003_0
.NT_A1
:= -- C_E
301 (C432003_0
.Constrained_Subtype
with
302 D2
=> Report
.Ident_Int
(5),
305 C432003_0
.Avoid_Optimization
(D
);
306 Report
.Failed
("Constraint_Error not raised for Object D");
309 when Constraint_Error
=>
310 null; -- Raise of Constraint_Error is expected.
316 E
: C432003_0
.NT_A2
:= -- OK
317 (C432003_0
.Constrained_Subtype
with D3
=> 10,
321 C432003_0
.Avoid_Optimization
(E
);
322 if E
.D3
/= 10 or E
.Acc
/= 356 or
323 E
.Str1
/= "abcde" or E
.S2
/= String10
or
325 E
.S1
/= C432003_0
.Default_String
(1..10)
327 Report
.Failed
("Incorrect object values for Object E");
331 when Constraint_Error
=>
332 Report
.Failed
("Constraint_Error raised for Object E");
338 F
: C432003_0
.NT_A2
:= -- C_E
339 (C432003_0
.Constrained_Subtype
with
340 D3
=> Report
.Ident_Int
(5),
344 C432003_0
.Avoid_Optimization
(F
);
345 Report
.Failed
("Constraint_Error not raised for Object F");
348 when Constraint_Error
=>
349 null; -- Raise of Constraint_Error is expected.
355 G
: C432003_0
.NT_B2
:= -- OK
356 (C432003_0
.ROOT
with D3
=> 5,
361 C432003_0
.Avoid_Optimization
(G
);
362 if G
.D3
/= 5 or G
.Acc
/= 356 or
363 G
.Str1
/= "cdefg" or G
.S2
/= String10
or
365 G
.S1
/= C432003_0
.Default_String
(1..5)
367 Report
.Failed
("Incorrect object values for Object G");
371 when Constraint_Error
=>
372 Report
.Failed
("Constraint_Error raised for Object G");
378 H
: C432003_0
.NT_B3
:= -- OK
379 (C432003_0
.Unconstrained_Der
with D2
=> 5,
382 C432003_0
.Avoid_Optimization
(H
);
383 if H
.D2
/= 5 or H
.Acc
/= 356 or
384 H
.Str1
/= "abcde" or H
.S2
/= String5
or
385 H
.S1
/= C432003_0
.Default_String
(1..10)
387 Report
.Failed
("Incorrect object values for Object H");
391 when Constraint_Error
=>
392 Report
.Failed
("Constraint_Error raised for Object H");
398 I
: C432003_0
.NT_B1
:= -- C_E
399 (C432003_0
.Constrained_Subtype
with
400 D2
=> Report
.Ident_Int
(10),
403 C432003_0
.Avoid_Optimization
(I
);
404 Report
.Failed
("Constraint_Error not raised for Object I");
407 when Constraint_Error
=>
408 null; -- Raise of Constraint_Error is expected.
414 J
: C432003_0
.NT_B2
:= -- C_E
415 (C432003_0
.Constrained_Subtype
with
416 D3
=> Report
.Ident_Int
(10),
420 C432003_0
.Avoid_Optimization
(J
);
421 Report
.Failed
("Constraint_Error not raised by Object J");
424 when Constraint_Error
=>
425 null; -- Raise of Constraint_Error is expected.
431 K
: C432003_0
.NT_B3
:= -- OK
432 (C432003_0
.Constrained_Subtype
with D2
=> 5,
435 C432003_0
.Avoid_Optimization
(K
);
436 if K
.D2
/= 5 or K
.Acc
/= 356 or
437 K
.Str1
/= "abcde" or K
.S2
/= String5
or
438 K
.S1
/= C432003_0
.Default_String
(1..10)
440 Report
.Failed
("Incorrect object values for Object K");
444 when Constraint_Error
=>
445 Report
.Failed
("Constraint_Error raised for Object K");
451 M
: C432003_0
.NT_C2
:= -- OK
452 (C432003_0
.ROOT
with D2
=> 10,
457 C432003_0
.Avoid_Optimization
(M
);
458 if M
.D2
/= 10 or M
.Acc
/= 356 or
459 M
.Str1
/= "cdefg" or M
.S2
/= String10
or
461 M
.S1
/= C432003_0
.Default_String
(1..5)
463 Report
.Failed
("Incorrect object values for Object M");
467 when Constraint_Error
=>
468 Report
.Failed
("Constraint_Error raised for Object M");
474 O
: C432003_0
.NT_C1
:= -- C_E
475 (C432003_0
.Constrained_Subtype
with
476 Str2
=> Report
.Ident_Str
(String5
));
478 C432003_0
.Avoid_Optimization
(O
);
479 Report
.Failed
("Constraint_Error not raised for Object O");
482 when Constraint_Error
=>
483 null; -- Raise of Constraint_Error is expected.
489 P
: C432003_0
.NT_C2
:= -- C_E
490 (C432003_0
.Constrained_Subtype
with
491 D2
=> Report
.Ident_Int
(10),
495 C432003_0
.Avoid_Optimization
(P
);
496 Report
.Failed
("Constraint_Error not raised by Object P");
499 when Constraint_Error
=>
500 null; -- Raise of Constraint_Error is expected.
506 Q
: C432003_0
.NT_C3
:=
507 (C432003_0
.Constrained_Subtype
with Str2
=> String5
); -- OK
509 C432003_0
.Avoid_Optimization
(Q
);
510 if Q
.Str2
/= String5
or
514 Q
.S1
/= C432003_0
.Default_String
(1..10)
516 Report
.Failed
("Incorrect object values for Object Q");
520 when Constraint_Error
=>
521 Report
.Failed
("Constraint_Error raised for Object Q");
525 -- The following cases test where a new discriminant corresponds
526 -- to multiple discriminants of the type of the ancestor part.
530 S
: C432003_0
.Mult_NT_A1
:= -- OK
531 (C432003_0
.Mult_Unconstr_Der
with D3
=> 15,
534 C432003_0
.Avoid_Optimization
(S
);
535 if S
.S1
/= C432003_0
.Default_String
(1..15) or
537 S
.S2
/= C432003_0
.Another_String
(1..15) or
541 Report
.Failed
("Incorrect object values for Object S");
545 when Constraint_Error
=>
546 Report
.Failed
("Constraint_Error raised for Object S");
552 U
: C432003_0
.Mult_NT_A1
:= -- C_E
553 (C432003_0
.Mult_Constr_Sub1
with
554 D3
=> Report
.Ident_Int
(15),
557 C432003_0
.Avoid_Optimization
(U
);
558 Report
.Failed
("Constraint_Error not raised for Object U");
561 when Constraint_Error
=>
562 null; -- Raise of Constraint_Error is expected.
568 V
: C432003_0
.Mult_NT_A1
:= -- OK
569 (C432003_0
.Mult_Constr_Sub2
with D3
=> 15,
572 C432003_0
.Avoid_Optimization
(V
);
576 V
.S1
/= C432003_0
.Default_String
(1..15) or
577 V
.S2
/= C432003_0
.Another_String
(1..15)
579 Report
.Failed
("Incorrect object values for Object V");
583 when Constraint_Error
=>
584 Report
.Failed
("Constraint_Error raised for Object V");
589 when others => Report
.Failed
("Exception raised in Test_Block");