Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c4/c433001.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;