Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c330002.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 -- C330002.A
2 --
3 -- Grant of Unlimited Rights
4 --
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7 -- unlimited rights in the software and documentation contained herein.
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
9 -- this public release, the Government intends to confer upon all
10 -- recipients unlimited rights equal to those held by the Government.
11 -- These rights include rights to use, duplicate, release or disclose the
12 -- released technical data and computer software in whole or in part, in
13 -- any manner and for any purpose whatsoever, and to have or permit others
14 -- 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 if a subtype indication of a variable object defines an
28 -- indefinite subtype, then there is an initialization expression.
29 -- Check that the object remains so constrained throughout its lifetime.
30 -- Check for cases of tagged record, arrays and generic formal type.
31 --
32 -- TEST DESCRIPTION:
33 -- An indefinite subtype is either:
34 -- a) An unconstrained array subtype.
35 -- b) A subtype with unknown discriminants (this includes class-wide
36 -- types).
37 -- c) A subtype with unconstrained discriminants without defaults.
38 --
39 -- Declare tagged types with unconstrained discriminants without
40 -- defaults. Declare an unconstrained array. Declare a generic formal
41 -- type with an unknown discriminant and a formal object of this type.
42 -- In the generic package, declare an object of the formal type using
43 -- the formal object as its initial value. In the main program,
44 -- declare objects of tagged types. Instantiate the generic package.
45 -- The test checks that Constraint_Error is raised if an attempt is
46 -- made to change bounds as well as discriminants of the objects of the
47 -- indefinite subtypes.
48 --
49 --
50 -- CHANGE HISTORY:
51 -- 01 Nov 95 SAIC Initial prerelease version.
52 -- 27 Jul 96 SAIC Modified test description & Report.Test. Added
53 -- code to prevent dead variable optimization.
54 --
55 --!
56
57 package C330002_0 is
58
59 subtype Small_Num is Integer range 1 .. 20;
60
61 -- Types with unconstrained discriminants without defaults.
62
63 type Tag_Type (Disc : Small_Num) is tagged
64 record
65 S : String (1 .. Disc);
66 end record;
67
68 function Tag_Value return Tag_Type;
69
70 procedure Assign_Tag (A : out Tag_Type);
71
72 procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String);
73
74 ---------------------------------------------------------------------
75 -- An unconstrained array type.
76
77 type Array_Type is array (Positive range <>) of Integer;
78
79 function Array_Value return Array_Type;
80
81 procedure Assign_Array (A : out Array_Type);
82
83 ---------------------------------------------------------------------
84 generic
85 -- Type with an unknown discriminant.
86 type Formal_Type (<>) is private;
87 FT_Obj : Formal_Type;
88 package Gen is
89 Gen_Obj : Formal_Type := FT_Obj;
90 end Gen;
91
92 end C330002_0;
93
94 --==================================================================--
95
96 with Report;
97 package body C330002_0 is
98
99 procedure Assign_Tag (A : out Tag_Type) is
100 begin
101 A := (3, "Bye");
102 end Assign_Tag;
103
104 ----------------------------------------------------------------------
105 procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is
106 Default : Tag_Type := (1, "!"); -- Unique value.
107 begin
108 if P = Default then -- Both If branches can't do the same thing.
109 Report.Failed (Msg & ": Constraint_Error not raised");
110 else -- Subtests should always select this path.
111 Report.Failed ("Constraint_Error not raised " & Msg);
112 end if;
113 end Avoid_Optimization_and_Fail;
114
115 ----------------------------------------------------------------------
116 function Tag_Value return Tag_Type is
117 TO : Tag_Type := (4 , "ACVC");
118 begin
119 return TO;
120 end Tag_Value;
121
122 ----------------------------------------------------------------------
123 function Array_Value return Array_Type is
124 IA : Array_Type := (20, 31);
125 begin
126 return IA;
127 end Array_Value;
128
129 ----------------------------------------------------------------------
130 procedure Assign_Array (A : out Array_Type) is
131 begin
132 A := (84, 36);
133 end Assign_Array;
134
135 end C330002_0;
136
137 --==================================================================--
138
139 with Report;
140 with C330002_0;
141 use C330002_0;
142
143 procedure C330002 is
144
145 begin
146 Report.Test ("C330002", "Check that if a subtype indication of a " &
147 "variable object defines an indefinite subtype, then " &
148 "there is an initialization expression. Check that " &
149 "the object remains so constrained throughout its " &
150 "lifetime. Check that Constraint_Error is raised " &
151 "if an attempt is made to change bounds as well as " &
152 "discriminants of the objects of the indefinite " &
153 "subtypes. Check for cases of tagged record and generic " &
154 "formal types");
155
156 TagObj_Block:
157 declare
158 TObj_ByAgg : Tag_Type := (5, "Hello"); -- Initial assignment is
159 -- aggregate.
160 TObj_ByObj : Tag_Type := TObj_ByAgg; -- Initial assignment is
161 -- an object.
162 TObj_ByFunc : Tag_Type := Tag_Value; -- Initial assignment is
163 -- function return value.
164 Ren_Obj : Tag_Type renames TObj_ByAgg;
165
166 begin
167
168 begin
169 if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then
170 Report.Failed ("Wrong initial values for TObj_ByAgg");
171 end if;
172
173 TObj_ByAgg := (2, "Hi"); -- C_E, can't change the
174 -- value of the discriminant.
175
176 Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1");
177
178 exception
179 when Constraint_Error => null; -- Exception is expected.
180 when others =>
181 Report.Failed ("Unexpected exception - Subtest 1");
182 end;
183
184
185 begin
186 Assign_Tag (Ren_Obj); -- C_E, can't change the
187 -- value of the discriminant.
188
189 Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2");
190
191 exception
192 when Constraint_Error => null; -- Exception is expected.
193 when others =>
194 Report.Failed ("Unexpected exception - Subtest 2");
195 end;
196
197
198 begin
199 if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then
200 Report.Failed ("Wrong initial values for TObj_ByObj");
201 end if;
202
203 TObj_ByObj := (3, "Bye"); -- C_E, can't change the
204 -- value of the discriminant.
205
206 Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3");
207
208 exception
209 when Constraint_Error => null; -- Exception is expected.
210 when others =>
211 Report.Failed ("Unexpected exception - Subtest 3");
212 end;
213
214
215 begin
216 if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then
217 Report.Failed ("Wrong initial values for TObj_ByFunc");
218 end if;
219
220 TObj_ByFunc := (5, "Aloha"); -- C_E, can't change the
221 -- value of the discriminant.
222
223 Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4");
224
225 exception
226 when Constraint_Error => null; -- Exception is expected.
227 when others =>
228 Report.Failed ("Unexpected exception - Subtest 4");
229 end;
230
231 end TagObj_Block;
232
233
234 ArrObj_Block:
235 declare
236 Arr_Const : constant Array_Type
237 := (9, 7, 6, 8);
238 Arr_ByAgg : Array_Type -- Initial assignment is
239 := (10, 11, 12); -- aggregate.
240 Arr_ByFunc : Array_Type -- Initial assignment is
241 := Array_Value; -- function return value.
242 Arr_ByObj : Array_Type -- Initial assignment is
243 := Arr_ByAgg; -- object.
244
245 Arr_Obj : array (Positive range <>) of Integer
246 := (1, 2, 3, 4, 5);
247 begin
248
249 begin
250 if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then
251 Report.Failed ("Wrong bounds for Arr_Const");
252 end if;
253
254 if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then
255 Report.Failed ("Wrong bounds for Arr_ByAgg");
256 end if;
257
258 if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then
259 Report.Failed ("Wrong bounds for Arr_ByFunc");
260 end if;
261
262 if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then
263 Report.Failed ("Wrong bounds for Arr_ByObj");
264 end if;
265
266 Assign_Array (Arr_ByObj); -- C_E, Arr_ByObj bounds are
267 -- 1..3.
268
269 Report.Failed ("Constraint_Error not raised - Subtest 5");
270
271 exception
272 when Constraint_Error => null; -- Exception is expected.
273 when others =>
274 Report.Failed ("Unexpected exception - Subtest 5");
275 end;
276
277
278 begin
279 if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then
280 Report.Failed ("Wrong bounds for Arr_Obj");
281 end if;
282
283 for I in 0 .. 5 loop
284 Arr_Obj (I + 1) := I + 5; -- C_E, Arr_Obj bounds are
285 end loop; -- 1..5.
286
287 Report.Failed ("Constraint_Error not raised - Subtest 6");
288
289 exception
290 when Constraint_Error => null; -- Exception is expected.
291 when others =>
292 Report.Failed ("Unexpected exception - Subtest 6");
293 end;
294
295 end ArrObj_Block;
296
297
298 GenericObj_Block:
299 declare
300 type Rec (Disc : Small_Num) is
301 record
302 S : Small_Num := Disc;
303 end record;
304
305 Rec_Obj : Rec := (2, 2);
306 package IGen is new Gen (Rec, Rec_Obj);
307
308 begin
309 IGen.Gen_Obj := (3, 3); -- C_E, can't change the
310 -- value of the discriminant.
311
312 Report.Failed ("Constraint_Error not raised - Subtest 7");
313
314 -- Next line prevents dead assignment.
315 Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc));
316
317 exception
318 when Constraint_Error => null; -- Exception is expected.
319 when others =>
320 Report.Failed ("Unexpected exception - Subtest 7");
321
322 end GenericObj_Block;
323
324 Report.Result;
325
326 end C330002;