OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c433001.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- 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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.