3 -- Grant of Unlimited Rights
5 -- The Ada Conformity Assessment Authority (ACAA) holds unlimited
6 -- rights in the software and documentation contained herein. Unlimited
7 -- rights are the same as those granted by the U.S. Government for older
8 -- parts of the Ada Conformity Assessment Test Suite, and are defined
9 -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10 -- intends to confer upon all recipients unlimited rights equal to those
11 -- held by the ACAA. These rights include rights to use, duplicate,
12 -- release or disclose the released technical data and computer software
13 -- in whole or in part, in any manner and for any purpose whatsoever, and
14 -- to have or permit others to do so.
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 an others choice is allowed in an array aggregate whose
28 -- applicable index constraint is dynamic. (This was an extension to
29 -- Ada 83). Check that index choices are within the applicable index
30 -- constraint for array aggregates with others choices.
33 -- In this test, we declare several unconstrained array types, and
34 -- several dynamic subtypes. We then test a variety of cases of using
35 -- appropriate aggregates. Some cases expect to raise Constraint_Error.
38 -- 16 DEC 1999 RLB Initial Version.
43 type Color_Type
is (Red
, Orange
, Yellow
, Green
, Blue
, Indigo
, Violet
);
45 type Array_1
is array (Positive range <>) of Integer;
47 subtype Sub_1_1
is Array_1
(Report
.Ident_Int
(1) .. Report
.Ident_Int
(3));
48 subtype Sub_1_2
is Array_1
(Report
.Ident_Int
(3) .. Report
.Ident_Int
(5));
49 subtype Sub_1_3
is Array_1
(Report
.Ident_Int
(5) .. Report
.Ident_Int
(9));
51 type Array_2
is array (Color_Type
range <>) of Integer;
53 subtype Sub_2_1
is Array_2
(Color_Type
'Val(Report
.Ident_Int
(0)) ..
54 Color_Type
'Val(Report
.Ident_Int
(2)));
56 subtype Sub_2_2
is Array_2
(Color_Type
'Val(Report
.Ident_Int
(3)) ..
57 Color_Type
'Val(Report
.Ident_Int
(6)));
59 type Array_3
is array (Color_Type
range <>, Positive range <>) of Integer;
61 subtype Sub_3_1
is Array_3
(Color_Type
'Val(Report
.Ident_Int
(0)) ..
62 Color_Type
'Val(Report
.Ident_Int
(2)),
63 Report
.Ident_Int
(3) .. Report
.Ident_Int
(5));
64 -- Red .. Yellow, 3 .. 5
65 subtype Sub_3_2
is Array_3
(Color_Type
'Val(Report
.Ident_Int
(1)) ..
66 Color_Type
'Val(Report
.Ident_Int
(3)),
67 Report
.Ident_Int
(6) .. Report
.Ident_Int
(8));
68 -- Orange .. Green, 6 .. 8
70 procedure Check_1
(Obj
: Array_1
; Low
, High
: Integer;
71 First_Component
, Second_Component
,
72 Last_Component
: Integer;
73 Test_Case
: Character) is
75 if Obj
'First /= Low
then
76 Report
.Failed
("Low bound incorrect (" & Test_Case
& ")");
78 if Obj
'Last /= High
then
79 Report
.Failed
("High bound incorrect (" & Test_Case
& ")");
81 if Obj
(Low
) /= First_Component
then
82 Report
.Failed
("First Component incorrect (" & Test_Case
& ")");
84 if Obj
(Low
+1) /= Second_Component
then
85 Report
.Failed
("First Component incorrect (" & Test_Case
& ")");
87 if Obj
(High
) /= Last_Component
then
88 Report
.Failed
("First Component incorrect (" & Test_Case
& ")");
92 procedure Check_2
(Obj
: Array_2
; Low
, High
: Color_Type
;
93 First_Component
, Second_Component
,
94 Last_Component
: Integer;
95 Test_Case
: Character) is
97 if Obj
'First /= Low
then
98 Report
.Failed
("Low bound incorrect (" & Test_Case
& ")");
100 if Obj
'Last /= High
then
101 Report
.Failed
("High bound incorrect (" & Test_Case
& ")");
103 if Obj
(Low
) /= First_Component
then
104 Report
.Failed
("First Component incorrect (" & Test_Case
& ")");
106 if Obj
(Color_Type
'Succ(Low
)) /= Second_Component
then
107 Report
.Failed
("First Component incorrect (" & Test_Case
& ")");
109 if Obj
(High
) /= Last_Component
then
110 Report
.Failed
("First Component incorrect (" & Test_Case
& ")");
114 procedure Check_3
(Test_Obj
, Check_Obj
: Array_3
;
115 Low_1
, High_1
: Color_Type
;
116 Low_2
, High_2
: Integer;
117 Test_Case
: Character) is
119 if Test_Obj
'First(1) /= Low_1
then
120 Report
.Failed
("Low bound for dimension 1 incorrect (" &
123 if Test_Obj
'Last(1) /= High_1
then
124 Report
.Failed
("High bound for dimension 1 incorrect (" &
127 if Test_Obj
'First(2) /= Low_2
then
128 Report
.Failed
("Low bound for dimension 2 incorrect (" &
131 if Test_Obj
'Last(2) /= High_2
then
132 Report
.Failed
("High bound for dimension 2 incorrect (" &
135 if Test_Obj
/= Check_Obj
then
136 Report
.Failed
("Components incorrect (" & Test_Case
& ")");
140 procedure Subtest_Check_1
(Obj
: Sub_1_3
;
141 First_Component
, Second_Component
,
142 Last_Component
: Integer;
143 Test_Case
: Character) is
145 Check_1
(Obj
, 5, 9, First_Component
, Second_Component
, Last_Component
,
149 procedure Subtest_Check_2
(Obj
: Sub_2_2
;
150 First_Component
, Second_Component
,
151 Last_Component
: Integer;
152 Test_Case
: Character) is
154 Check_2
(Obj
, Green
, Violet
, First_Component
, Second_Component
,
155 Last_Component
, Test_Case
);
158 procedure Subtest_Check_3
(Obj
: Sub_3_2
;
159 Test_Case
: Character) is
161 Check_3
(Obj
, Obj
, Orange
, Green
, 6, 8, Test_Case
);
166 Report
.Test
("C433001",
167 "Check that an others choice is allowed in an array " &
168 "aggregate whose applicable index constraint is dynamic. " &
169 "Also check index choices are within the applicable index " &
170 "constraint for array aggregates with others choices");
172 -- Check with a qualified expression:
173 Check_1
(Sub_1_1
'(2, 3, others => 4), Low => 1, High => 3,
174 First_Component => 2, Second_Component => 3, Last_Component => 4,
177 Check_2 (Sub_2_1'(1, others => Report
.Ident_Int
(6)),
178 Low
=> Red
, High
=> Yellow
,
179 First_Component
=> 1, Second_Component
=> 6, Last_Component
=> 6,
182 Check_3
(Sub_3_1
'((1, others => 3), others => (2, 4, others => 6)),
183 Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)),
184 Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5,
187 -- Check that the others clause does not need to represent any components:
188 Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low
=> 3, High
=> 5,
189 First_Component
=> 5, Second_Component
=> 6, Last_Component
=> 8,
192 -- Check named choices are allowed:
193 Check_1
(Sub_1_1
'(2 => Report.Ident_Int(-1), others => 8),
195 First_Component => 8, Second_Component => -1, Last_Component => 8,
198 -- Check named choices and formal parameters:
199 Subtest_Check_1 ((6 => 4, 8 => 86, others => 1),
200 First_Component => 1, Second_Component => 4, Last_Component => 1,
203 Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89,
204 Indigo => Report.Ident_Int(42), Blue => 0, others => -1),
205 First_Component => 88, Second_Component => 0, Last_Component => 89,
208 Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)),
211 -- Check object declarations and assignment:
213 Var : Sub_1_2 := (4, 36, others => 86);
215 Check_1 (Var, Low => 3, High => 5,
216 First_Component => 4, Second_Component => 36,
217 Last_Component => 86,
219 Var := (5 => 415, others => Report.Ident_Int(1522));
220 Check_1 (Var, Low => 3, High => 5,
221 First_Component => 1522, Second_Component => 1522,
222 Last_Component => 415,
226 -- Check positional aggregates that are too long:
228 Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93),
229 First_Component => 88, Second_Component => 89,
230 Last_Component => 91,
232 Report.Failed ("Constraint_Error not raised by positional " &
233 "aggregate with too many choices (K)");
235 when Constraint_Error => null; -- Expected exception.
239 Subtest_Check_3 (((0, others => 10), (2, 3, others => 4),
240 (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)),
242 Report.Failed ("Constraint_Error not raised by positional " &
243 "aggregate with too many choices (L)");
245 when Constraint_Error => null; -- Expected exception.
248 -- Check named aggregates with choices in the index subtype but not in the
249 -- applicable index constraint:
252 Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89,
253 10 => 66, -- 10 not in applicable index constraint
255 First_Component => 88, Second_Component => 93,
256 Last_Component => 93,
258 Report.Failed ("Constraint_Error not raised by aggregate choice " &
259 "index outside of applicable index constraint (M)");
261 when Constraint_Error => null; -- Expected exception.
266 (Yellow => 23, -- Yellow not in applicable index constraint.
267 Blue => 16, others => 77),
268 First_Component => 77, Second_Component => 16,
269 Last_Component => 77,
271 Report.Failed ("Constraint_Error not raised by aggregate choice " &
272 "index outside of applicable index constraint (N)");
274 when Constraint_Error => null; -- Expected exception.
278 Subtest_Check_3 ((Orange => (0, others => 10),
279 Blue => (2, 3, others => 4), -- Blue not in applicable index cons.
280 others => (1, 2, 3)),
282 Report.Failed ("Constraint_Error not raised by aggregate choice " &
283 "index outside of applicable index constraint (P)");
285 when Constraint_Error => null; -- Expected exception.
289 Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)),
290 Green => (8 => 2, 4 => 3, others => 7),
291 -- 4 not in applicable index cons.
292 others => (1, 2, 3, others => Report.Ident_Int(10))),
294 Report.Failed ("Constraint_Error not raised by aggregate choice " &
295 "index outside of applicable index constraint (Q)");
297 when Constraint_Error => null; -- Expected exception.