|
111
|
1 -- C433001.A
|
|
|
2
|
|
|
3 -- Grant of Unlimited Rights
|
|
|
4 --
|
|
|
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.
|
|
|
15 --
|
|
|
16 -- DISCLAIMER
|
|
|
17 --
|
|
|
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.
|
|
|
24 --*
|
|
|
25 --
|
|
|
26 -- OBJECTIVE
|
|
|
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.
|
|
|
31 --
|
|
|
32 -- TEST DESCRIPTION
|
|
|
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.
|
|
|
36 --
|
|
|
37 -- HISTORY:
|
|
|
38 -- 16 DEC 1999 RLB Initial Version.
|
|
|
39
|
|
|
40 with Report;
|
|
|
41 procedure C433001 is
|
|
|
42
|
|
|
43 type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
|
|
|
44
|
|
|
45 type Array_1 is array (Positive range <>) of Integer;
|
|
|
46
|
|
|
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));
|
|
|
50
|
|
|
51 type Array_2 is array (Color_Type range <>) of Integer;
|
|
|
52
|
|
|
53 subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) ..
|
|
|
54 Color_Type'Val(Report.Ident_Int(2)));
|
|
|
55 -- Red .. Yellow
|
|
|
56 subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) ..
|
|
|
57 Color_Type'Val(Report.Ident_Int(6)));
|
|
|
58 -- Green .. Violet
|
|
|
59 type Array_3 is array (Color_Type range <>, Positive range <>) of Integer;
|
|
|
60
|
|
|
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
|
|
|
69
|
|
|
70 procedure Check_1 (Obj : Array_1; Low, High : Integer;
|
|
|
71 First_Component, Second_Component,
|
|
|
72 Last_Component : Integer;
|
|
|
73 Test_Case : Character) is
|
|
|
74 begin
|
|
|
75 if Obj'First /= Low then
|
|
|
76 Report.Failed ("Low bound incorrect (" & Test_Case & ")");
|
|
|
77 end if;
|
|
|
78 if Obj'Last /= High then
|
|
|
79 Report.Failed ("High bound incorrect (" & Test_Case & ")");
|
|
|
80 end if;
|
|
|
81 if Obj(Low) /= First_Component then
|
|
|
82 Report.Failed ("First Component incorrect (" & Test_Case & ")");
|
|
|
83 end if;
|
|
|
84 if Obj(Low+1) /= Second_Component then
|
|
|
85 Report.Failed ("First Component incorrect (" & Test_Case & ")");
|
|
|
86 end if;
|
|
|
87 if Obj(High) /= Last_Component then
|
|
|
88 Report.Failed ("First Component incorrect (" & Test_Case & ")");
|
|
|
89 end if;
|
|
|
90 end Check_1;
|
|
|
91
|
|
|
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
|
|
|
96 begin
|
|
|
97 if Obj'First /= Low then
|
|
|
98 Report.Failed ("Low bound incorrect (" & Test_Case & ")");
|
|
|
99 end if;
|
|
|
100 if Obj'Last /= High then
|
|
|
101 Report.Failed ("High bound incorrect (" & Test_Case & ")");
|
|
|
102 end if;
|
|
|
103 if Obj(Low) /= First_Component then
|
|
|
104 Report.Failed ("First Component incorrect (" & Test_Case & ")");
|
|
|
105 end if;
|
|
|
106 if Obj(Color_Type'Succ(Low)) /= Second_Component then
|
|
|
107 Report.Failed ("First Component incorrect (" & Test_Case & ")");
|
|
|
108 end if;
|
|
|
109 if Obj(High) /= Last_Component then
|
|
|
110 Report.Failed ("First Component incorrect (" & Test_Case & ")");
|
|
|
111 end if;
|
|
|
112 end Check_2;
|
|
|
113
|
|
|
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
|
|
|
118 begin
|
|
|
119 if Test_Obj'First(1) /= Low_1 then
|
|
|
120 Report.Failed ("Low bound for dimension 1 incorrect (" &
|
|
|
121 Test_Case & ")");
|
|
|
122 end if;
|
|
|
123 if Test_Obj'Last(1) /= High_1 then
|
|
|
124 Report.Failed ("High bound for dimension 1 incorrect (" &
|
|
|
125 Test_Case & ")");
|
|
|
126 end if;
|
|
|
127 if Test_Obj'First(2) /= Low_2 then
|
|
|
128 Report.Failed ("Low bound for dimension 2 incorrect (" &
|
|
|
129 Test_Case & ")");
|
|
|
130 end if;
|
|
|
131 if Test_Obj'Last(2) /= High_2 then
|
|
|
132 Report.Failed ("High bound for dimension 2 incorrect (" &
|
|
|
133 Test_Case & ")");
|
|
|
134 end if;
|
|
|
135 if Test_Obj /= Check_Obj then
|
|
|
136 Report.Failed ("Components incorrect (" & Test_Case & ")");
|
|
|
137 end if;
|
|
|
138 end Check_3;
|
|
|
139
|
|
|
140 procedure Subtest_Check_1 (Obj : Sub_1_3;
|
|
|
141 First_Component, Second_Component,
|
|
|
142 Last_Component : Integer;
|
|
|
143 Test_Case : Character) is
|
|
|
144 begin
|
|
|
145 Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component,
|
|
|
146 Test_Case);
|
|
|
147 end Subtest_Check_1;
|
|
|
148
|
|
|
149 procedure Subtest_Check_2 (Obj : Sub_2_2;
|
|
|
150 First_Component, Second_Component,
|
|
|
151 Last_Component : Integer;
|
|
|
152 Test_Case : Character) is
|
|
|
153 begin
|
|
|
154 Check_2 (Obj, Green, Violet, First_Component, Second_Component,
|
|
|
155 Last_Component, Test_Case);
|
|
|
156 end Subtest_Check_2;
|
|
|
157
|
|
|
158 procedure Subtest_Check_3 (Obj : Sub_3_2;
|
|
|
159 Test_Case : Character) is
|
|
|
160 begin
|
|
|
161 Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case);
|
|
|
162 end Subtest_Check_3;
|
|
|
163
|
|
|
164 begin
|
|
|
165
|
|
|
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");
|
|
|
171
|
|
|
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,
|
|
|
175 Test_Case => 'A');
|
|
|
176
|
|
|
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,
|
|
|
180 Test_Case => 'B');
|
|
|
181
|
|
|
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,
|
|
|
185 Test_Case => 'C');
|
|
|
186
|
|
|
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,
|
|
|
190 Test_Case => 'D');
|
|
|
191
|
|
|
192 -- Check named choices are allowed:
|
|
|
193 Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8),
|
|
|
194 Low => 1, High => 3,
|
|
|
195 First_Component => 8, Second_Component => -1, Last_Component => 8,
|
|
|
196 Test_Case => 'E');
|
|
|
197
|
|
|
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,
|
|
|
201 Test_Case => 'F');
|
|
|
202
|
|
|
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,
|
|
|
206 Test_Case => 'G');
|
|
|
207
|
|
|
208 Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)),
|
|
|
209 Test_Case => 'H');
|
|
|
210
|
|
|
211 -- Check object declarations and assignment:
|
|
|
212 declare
|
|
|
213 Var : Sub_1_2 := (4, 36, others => 86);
|
|
|
214 begin
|
|
|
215 Check_1 (Var, Low => 3, High => 5,
|
|
|
216 First_Component => 4, Second_Component => 36,
|
|
|
217 Last_Component => 86,
|
|
|
218 Test_Case => 'I');
|
|
|
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,
|
|
|
223 Test_Case => 'J');
|
|
|
224 end;
|
|
|
225
|
|
|
226 -- Check positional aggregates that are too long:
|
|
|
227 begin
|
|
|
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,
|
|
|
231 Test_Case => 'K');
|
|
|
232 Report.Failed ("Constraint_Error not raised by positional " &
|
|
|
233 "aggregate with too many choices (K)");
|
|
|
234 exception
|
|
|
235 when Constraint_Error => null; -- Expected exception.
|
|
|
236 end;
|
|
|
237
|
|
|
238 begin
|
|
|
239 Subtest_Check_3 (((0, others => 10), (2, 3, others => 4),
|
|
|
240 (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)),
|
|
|
241 Test_Case => 'L');
|
|
|
242 Report.Failed ("Constraint_Error not raised by positional " &
|
|
|
243 "aggregate with too many choices (L)");
|
|
|
244 exception
|
|
|
245 when Constraint_Error => null; -- Expected exception.
|
|
|
246 end;
|
|
|
247
|
|
|
248 -- Check named aggregates with choices in the index subtype but not in the
|
|
|
249 -- applicable index constraint:
|
|
|
250
|
|
|
251 begin
|
|
|
252 Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89,
|
|
|
253 10 => 66, -- 10 not in applicable index constraint
|
|
|
254 others => 93),
|
|
|
255 First_Component => 88, Second_Component => 93,
|
|
|
256 Last_Component => 93,
|
|
|
257 Test_Case => 'M');
|
|
|
258 Report.Failed ("Constraint_Error not raised by aggregate choice " &
|
|
|
259 "index outside of applicable index constraint (M)");
|
|
|
260 exception
|
|
|
261 when Constraint_Error => null; -- Expected exception.
|
|
|
262 end;
|
|
|
263
|
|
|
264 begin
|
|
|
265 Subtest_Check_2 (
|
|
|
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,
|
|
|
270 Test_Case => 'N');
|
|
|
271 Report.Failed ("Constraint_Error not raised by aggregate choice " &
|
|
|
272 "index outside of applicable index constraint (N)");
|
|
|
273 exception
|
|
|
274 when Constraint_Error => null; -- Expected exception.
|
|
|
275 end;
|
|
|
276
|
|
|
277 begin
|
|
|
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)),
|
|
|
281 Test_Case => 'P');
|
|
|
282 Report.Failed ("Constraint_Error not raised by aggregate choice " &
|
|
|
283 "index outside of applicable index constraint (P)");
|
|
|
284 exception
|
|
|
285 when Constraint_Error => null; -- Expected exception.
|
|
|
286 end;
|
|
|
287
|
|
|
288 begin
|
|
|
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))),
|
|
|
293 Test_Case => 'Q');
|
|
|
294 Report.Failed ("Constraint_Error not raised by aggregate choice " &
|
|
|
295 "index outside of applicable index constraint (Q)");
|
|
|
296 exception
|
|
|
297 when Constraint_Error => null; -- Expected exception.
|
|
|
298 end;
|
|
|
299
|
|
|
300 Report.Result;
|
|
|
301
|
|
|
302 end C433001;
|
