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--      20 JAN 2009   RLB   Corrected error messages.
40
41with Report;
42procedure C433001 is
43
44    type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
45
46    type Array_1 is array (Positive range <>) of Integer;
47
48    subtype Sub_1_1 is Array_1 (Report.Ident_Int(1) .. Report.Ident_Int(3));
49    subtype Sub_1_2 is Array_1 (Report.Ident_Int(3) .. Report.Ident_Int(5));
50    subtype Sub_1_3 is Array_1 (Report.Ident_Int(5) .. Report.Ident_Int(9));
51
52    type Array_2 is array (Color_Type range <>) of Integer;
53
54    subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) ..
55                                Color_Type'Val(Report.Ident_Int(2)));
56                                                 -- Red .. Yellow
57    subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) ..
58                                Color_Type'Val(Report.Ident_Int(6)));
59                                                 -- Green .. Violet
60    type Array_3 is array (Color_Type range <>, Positive range <>) of Integer;
61
62    subtype Sub_3_1 is Array_3 (Color_Type'Val(Report.Ident_Int(0)) ..
63                                Color_Type'Val(Report.Ident_Int(2)),
64                                Report.Ident_Int(3) .. Report.Ident_Int(5));
65                                                 -- Red .. Yellow, 3 .. 5
66    subtype Sub_3_2 is Array_3 (Color_Type'Val(Report.Ident_Int(1)) ..
67                                Color_Type'Val(Report.Ident_Int(3)),
68                                Report.Ident_Int(6) .. Report.Ident_Int(8));
69                                                 -- Orange .. Green, 6 .. 8
70
71    procedure Check_1 (Obj : Array_1; Low, High : Integer;
72                       First_Component, Second_Component,
73                           Last_Component : Integer;
74                       Test_Case : Character) is
75    begin
76        if Obj'First /= Low then
77           Report.Failed ("Low bound incorrect (" & Test_Case & ")");
78        end if;
79        if Obj'Last /= High then
80           Report.Failed ("High bound incorrect (" & Test_Case & ")");
81        end if;
82        if Obj(Low) /= First_Component then
83           Report.Failed ("First Component incorrect (" & Test_Case & ")");
84        end if;
85        if Obj(Low+1) /= Second_Component then
86           Report.Failed ("Second Component incorrect (" & Test_Case & ")");
87        end if;
88        if Obj(High) /= Last_Component then
89           Report.Failed ("Last Component incorrect (" & Test_Case & ")");
90        end if;
91    end Check_1;
92
93    procedure Check_2 (Obj : Array_2; Low, High : Color_Type;
94                       First_Component, Second_Component,
95                           Last_Component : Integer;
96                       Test_Case : Character) is
97    begin
98        if Obj'First /= Low then
99           Report.Failed ("Low bound incorrect (" & Test_Case & ")");
100        end if;
101        if Obj'Last /= High then
102           Report.Failed ("High bound incorrect (" & Test_Case & ")");
103        end if;
104        if Obj(Low) /= First_Component then
105           Report.Failed ("First Component incorrect (" & Test_Case & ")");
106        end if;
107        if Obj(Color_Type'Succ(Low)) /= Second_Component then
108           Report.Failed ("Second Component incorrect (" & Test_Case & ")");
109        end if;
110        if Obj(High) /= Last_Component then
111           Report.Failed ("Last Component incorrect (" & Test_Case & ")");
112        end if;
113    end Check_2;
114
115    procedure Check_3 (Test_Obj, Check_Obj : Array_3;
116                       Low_1, High_1 : Color_Type;
117                       Low_2, High_2 : Integer;
118                       Test_Case : Character) is
119    begin
120        if Test_Obj'First(1) /= Low_1 then
121           Report.Failed ("Low bound for dimension 1 incorrect (" &
122                Test_Case & ")");
123        end if;
124        if Test_Obj'Last(1) /= High_1 then
125           Report.Failed ("High bound for dimension 1 incorrect (" &
126                Test_Case & ")");
127        end if;
128        if Test_Obj'First(2) /= Low_2 then
129           Report.Failed ("Low bound for dimension 2 incorrect (" &
130                Test_Case & ")");
131        end if;
132        if Test_Obj'Last(2) /= High_2 then
133           Report.Failed ("High bound for dimension 2 incorrect (" &
134                Test_Case & ")");
135        end if;
136        if Test_Obj /= Check_Obj then
137           Report.Failed ("Components incorrect (" & Test_Case & ")");
138        end if;
139    end Check_3;
140
141    procedure Subtest_Check_1 (Obj : Sub_1_3;
142                               First_Component, Second_Component,
143                                        Last_Component : Integer;
144                               Test_Case : Character) is
145    begin
146        Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component,
147                 Test_Case);
148    end Subtest_Check_1;
149
150    procedure Subtest_Check_2 (Obj : Sub_2_2;
151                               First_Component, Second_Component,
152                                        Last_Component : Integer;
153                               Test_Case : Character) is
154    begin
155        Check_2 (Obj, Green, Violet, First_Component, Second_Component,
156                 Last_Component, Test_Case);
157    end Subtest_Check_2;
158
159    procedure Subtest_Check_3 (Obj : Sub_3_2;
160                               Test_Case : Character) is
161    begin
162        Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case);
163    end Subtest_Check_3;
164
165begin
166
167    Report.Test ("C433001",
168                 "Check that an others choice is allowed in an array " &
169                 "aggregate whose applicable index constraint is dynamic. " &
170                 "Also check index choices are within the applicable index " &
171                 "constraint for array aggregates with others choices");
172
173    -- Check with a qualified expression:
174    Check_1 (Sub_1_1'(2, 3, others => 4), Low => 1, High => 3,
175             First_Component => 2, Second_Component => 3, Last_Component => 4,
176             Test_Case => 'A');
177
178    Check_2 (Sub_2_1'(1, others => Report.Ident_Int(6)),
179             Low => Red, High => Yellow,
180             First_Component => 1, Second_Component => 6, Last_Component => 6,
181             Test_Case => 'B');
182
183    Check_3 (Sub_3_1'((1, others => 3), others => (2, 4, others => 6)),
184             Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)),
185             Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5,
186             Test_Case => 'C');
187
188    -- Check that the others clause does not need to represent any components:
189    Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low => 3, High => 5,
190             First_Component => 5, Second_Component => 6, Last_Component => 8,
191             Test_Case => 'D');
192
193    -- Check named choices are allowed:
194    Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8),
195             Low => 1, High => 3,
196             First_Component => 8, Second_Component => -1, Last_Component => 8,
197             Test_Case => 'E');
198
199    -- Check named choices and formal parameters:
200    Subtest_Check_1 ((6 => 4, 8 => 86, others => 1),
201             First_Component => 1, Second_Component => 4, Last_Component => 1,
202             Test_Case => 'F');
203
204    Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89,
205             Indigo => Report.Ident_Int(42), Blue => 0, others => -1),
206             First_Component => 88, Second_Component => 0, Last_Component => 89,
207             Test_Case => 'G');
208
209    Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)),
210             Test_Case => 'H');
211
212    -- Check object declarations and assignment:
213    declare
214        Var : Sub_1_2 := (4, 36, others => 86);
215    begin
216        Check_1 (Var, Low => 3, High => 5,
217             First_Component => 4, Second_Component => 36,
218             Last_Component => 86,
219             Test_Case => 'I');
220        Var := (5 => 415, others => Report.Ident_Int(1522));
221        Check_1 (Var, Low => 3, High => 5,
222             First_Component => 1522, Second_Component => 1522,
223             Last_Component => 415,
224             Test_Case => 'J');
225    end;
226
227    -- Check positional aggregates that are too long:
228    begin
229        Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93),
230             First_Component => 88, Second_Component => 89,
231             Last_Component => 91,
232             Test_Case => 'K');
233        Report.Failed ("Constraint_Error not raised by positional " &
234                       "aggregate with too many choices (K)");
235    exception
236        when Constraint_Error => null; -- Expected exception.
237    end;
238
239    begin
240        Subtest_Check_3 (((0, others => 10), (2, 3, others => 4),
241             (5, 6, 8, others => 10), (1, 4, 7),  others => (1, 2, 3)),
242             Test_Case => 'L');
243        Report.Failed ("Constraint_Error not raised by positional " &
244                       "aggregate with too many choices (L)");
245    exception
246        when Constraint_Error => null; -- Expected exception.
247    end;
248
249    -- Check named aggregates with choices in the index subtype but not in the
250    -- applicable index constraint:
251
252    begin
253        Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89,
254             10 => 66, -- 10 not in applicable index constraint
255             others => 93),
256             First_Component => 88, Second_Component => 93,
257             Last_Component => 93,
258             Test_Case => 'M');
259        Report.Failed ("Constraint_Error not raised by aggregate choice " &
260                       "index outside of applicable index constraint (M)");
261    exception
262        when Constraint_Error => null; -- Expected exception.
263    end;
264
265    begin
266        Subtest_Check_2 (
267             (Yellow => 23, -- Yellow not in applicable index constraint.
268             Blue => 16, others => 77),
269             First_Component => 77, Second_Component => 16,
270             Last_Component => 77,
271             Test_Case => 'N');
272        Report.Failed ("Constraint_Error not raised by aggregate choice " &
273                       "index outside of applicable index constraint (N)");
274    exception
275        when Constraint_Error => null; -- Expected exception.
276    end;
277
278    begin
279        Subtest_Check_3 ((Orange => (0, others => 10),
280             Blue => (2, 3, others => 4), -- Blue not in applicable index cons.
281             others => (1, 2, 3)),
282             Test_Case => 'P');
283        Report.Failed ("Constraint_Error not raised by aggregate choice " &
284                       "index outside of applicable index constraint (P)");
285    exception
286        when Constraint_Error => null; -- Expected exception.
287    end;
288
289    begin
290        Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)),
291             Green => (8 => 2, 4 => 3, others => 7),
292                -- 4 not in applicable index cons.
293             others => (1, 2, 3, others => Report.Ident_Int(10))),
294             Test_Case => 'Q');
295        Report.Failed ("Constraint_Error not raised by aggregate choice " &
296                       "index outside of applicable index constraint (Q)");
297    exception
298        when Constraint_Error => null; -- Expected exception.
299    end;
300
301    Report.Result;
302
303end C433001;
304