Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/c4/c460006.a @ 111:04ced10e8804
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 -- C460006.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 a view conversion to a tagged type is permitted in the | |
28 -- prefix of a selected component, an object renaming declaration, and | |
29 -- (if the operand is a variable) on the left side of an assignment | |
30 -- statement. Check that such a renaming or assignment does not change | |
31 -- the tag of the operand. | |
32 -- | |
33 -- Check that, for a view conversion of a tagged type, each | |
34 -- nondiscriminant component of the new view denotes the matching | |
35 -- component of the operand object. Check that reading the value of the | |
36 -- view yields the result of converting the value of the operand object | |
37 -- to the target subtype. | |
38 -- | |
39 -- TEST DESCRIPTION: | |
40 -- The fact that the tag of an object is not changed is verified by | |
41 -- making calls to primitive operations which in turn make (re)dispatching | |
42 -- calls, and confirming that the proper bodies are executed. | |
43 -- | |
44 -- Selected components are checked in three contexts: as the object name | |
45 -- in an object renaming declaration, as the left operand of an inequality | |
46 -- operation, and as the left side of an assignment statement. | |
47 -- | |
48 -- View conversions of an object of a 2nd level type extension are | |
49 -- renamed as objects of an ancestor type and of a class-wide type. In | |
50 -- one case the operand of the conversion is itself a renaming of an | |
51 -- object. | |
52 -- | |
53 -- View conversions of an object of a 2nd level type extension are | |
54 -- checked for equality with record aggregates of various ancestor types. | |
55 -- In one case, the view conversion is to a class-wide type, and it is | |
56 -- checked for equality with the result of a class-wide function with | |
57 -- the following structure: | |
58 -- | |
59 -- function F return T'Class is | |
60 -- A : DDT := Expected_Value; | |
61 -- X : T'Class := T(A); | |
62 -- begin | |
63 -- return X; | |
64 -- | |
65 -- end F; | |
66 -- | |
67 -- ... | |
68 -- | |
69 -- Var : DDT := Expected_Value; | |
70 -- | |
71 -- if (T'Class(Var) /= F) then -- Condition should yield FALSE. | |
72 -- FAIL; | |
73 -- end if; | |
74 -- | |
75 -- The view conversion to which X is initialized does not affect the | |
76 -- value or tag of the operand; the tag of X is that of type DDT (not T), | |
77 -- and the components are those of A. The result of this function | |
78 -- should equal the value of an object of type DDT initialized to the | |
79 -- same value as F.A. | |
80 -- | |
81 -- To check that assignment to a view conversion does not change the tag | |
82 -- of the operand, an assignment is made to a conversion of an object, | |
83 -- and the object is then passed as an actual to a dispatching operation. | |
84 -- Conversions to both specific and class-wide types are checked. | |
85 -- | |
86 -- | |
87 -- CHANGE HISTORY: | |
88 -- 20 Jul 95 SAIC Initial prerelease version. | |
89 -- 24 Apr 96 SAIC Added type conversions. | |
90 -- | |
91 --! | |
92 | |
93 package C460006_0 is | |
94 | |
95 type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, | |
96 Child_Outer, Child_Inner, | |
97 Grandchild_Outer, Grandchild_Inner); | |
98 | |
99 type Root_Type is abstract tagged record | |
100 First_Call : Call_ID_Kind := None; | |
101 Second_Call : Call_ID_Kind := None; | |
102 end record; | |
103 | |
104 procedure Inner_Proc (X : in out Root_Type) is abstract; | |
105 procedure Outer_Proc (X : in out Root_Type) is abstract; | |
106 | |
107 end C460006_0; | |
108 | |
109 | |
110 --==================================================================-- | |
111 | |
112 | |
113 package C460006_0.C460006_1 is | |
114 | |
115 type Parent_Type is new Root_Type with record | |
116 C1 : Integer := 0; | |
117 end record; | |
118 | |
119 procedure Inner_Proc (X : in out Parent_Type); | |
120 procedure Outer_Proc (X : in out Parent_Type); | |
121 | |
122 end C460006_0.C460006_1; | |
123 | |
124 | |
125 --==================================================================-- | |
126 | |
127 | |
128 package body C460006_0.C460006_1 is | |
129 | |
130 procedure Inner_Proc (X : in out Parent_Type) is | |
131 begin | |
132 X.Second_Call := Parent_Inner; | |
133 end Inner_Proc; | |
134 | |
135 ------------------------------------------------- | |
136 procedure Outer_Proc (X : in out Parent_Type) is | |
137 begin | |
138 X.First_Call := Parent_Outer; | |
139 Inner_Proc ( Parent_Type'Class(X) ); | |
140 end Outer_Proc; | |
141 | |
142 end C460006_0.C460006_1; | |
143 | |
144 | |
145 --==================================================================-- | |
146 | |
147 | |
148 package C460006_0.C460006_1.C460006_2 is | |
149 | |
150 type Child_Type is new Parent_Type with record | |
151 C2 : String(1 .. 5) := "-----"; | |
152 end record; | |
153 | |
154 procedure Inner_Proc (X : in out Child_Type); | |
155 procedure Outer_Proc (X : in out Child_Type); | |
156 | |
157 end C460006_0.C460006_1.C460006_2; | |
158 | |
159 | |
160 --==================================================================-- | |
161 | |
162 | |
163 package body C460006_0.C460006_1.C460006_2 is | |
164 | |
165 procedure Inner_Proc (X : in out Child_Type) is | |
166 begin | |
167 X.Second_Call := Child_Inner; | |
168 end Inner_Proc; | |
169 | |
170 ------------------------------------------------- | |
171 procedure Outer_Proc (X : in out Child_Type) is | |
172 begin | |
173 X.First_Call := Child_Outer; | |
174 Inner_Proc ( Parent_Type'Class(X) ); | |
175 end Outer_Proc; | |
176 | |
177 end C460006_0.C460006_1.C460006_2; | |
178 | |
179 | |
180 --==================================================================-- | |
181 | |
182 | |
183 package C460006_0.C460006_1.C460006_2.C460006_3 is | |
184 | |
185 type Grandchild_Type is new Child_Type with record | |
186 C3: String(1 .. 5) := "-----"; | |
187 end record; | |
188 | |
189 procedure Inner_Proc (X : in out Grandchild_Type); | |
190 procedure Outer_Proc (X : in out Grandchild_Type); | |
191 | |
192 | |
193 function ClassWide_Func return Parent_Type'Class; | |
194 | |
195 | |
196 Grandchild_Value : constant Grandchild_Type := (First_Call => None, | |
197 Second_Call => None, | |
198 C1 => 15, | |
199 C2 => "Hello", | |
200 C3 => "World"); | |
201 | |
202 end C460006_0.C460006_1.C460006_2.C460006_3; | |
203 | |
204 | |
205 --==================================================================-- | |
206 | |
207 | |
208 package body C460006_0.C460006_1.C460006_2.C460006_3 is | |
209 | |
210 procedure Inner_Proc (X : in out Grandchild_Type) is | |
211 begin | |
212 X.Second_Call := Grandchild_Inner; | |
213 end Inner_Proc; | |
214 | |
215 ------------------------------------------------- | |
216 procedure Outer_Proc (X : in out Grandchild_Type) is | |
217 begin | |
218 X.First_Call := Grandchild_Outer; | |
219 Inner_Proc ( Parent_Type'Class(X) ); | |
220 end Outer_Proc; | |
221 | |
222 ------------------------------------------------- | |
223 function ClassWide_Func return Parent_Type'Class is | |
224 A : Grandchild_Type := Grandchild_Value; | |
225 X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A. | |
226 begin | |
227 return X; | |
228 end ClassWide_Func; | |
229 | |
230 end C460006_0.C460006_1.C460006_2.C460006_3; | |
231 | |
232 | |
233 --==================================================================-- | |
234 | |
235 | |
236 with C460006_0.C460006_1.C460006_2.C460006_3; | |
237 | |
238 with Report; | |
239 procedure C460006 is | |
240 | |
241 package Root_Package renames C460006_0; | |
242 package Parent_Package renames C460006_0.C460006_1; | |
243 package Child_Package renames C460006_0.C460006_1.C460006_2; | |
244 package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3; | |
245 | |
246 begin | |
247 Report.Test ("C460006", "Check that a view conversion to a tagged type " & | |
248 "is permitted in the prefix of a selected component, an " & | |
249 "object renaming declaration, and (if the operand is a " & | |
250 "variable) on the left side of an assignment statement. " & | |
251 "Check that such a renaming or assignment does not change " & | |
252 " the tag of the operand"); | |
253 | |
254 | |
255 -- | |
256 -- Check conversion as prefix of selected component: | |
257 -- | |
258 | |
259 Selected_Component_Subtest: | |
260 declare | |
261 use Root_Package, Parent_Package, Child_Package, Grandchild_Package; | |
262 | |
263 Var : Grandchild_Type := Grandchild_Value; | |
264 CW_Var : Parent_Type'Class := Var; | |
265 | |
266 Ren : Integer renames Parent_Type(Var).C1; | |
267 | |
268 begin | |
269 if Ren /= 15 then | |
270 Report.Failed ("Wrong value: selected component in renaming"); | |
271 end if; | |
272 | |
273 if Child_Type(Var).C2 /= "Hello" then | |
274 Report.Failed ("Wrong value: selected component in IF"); | |
275 end if; | |
276 | |
277 Grandchild_Type(CW_Var).C3(2..4) := "eir"; | |
278 if CW_Var /= Parent_Type'Class | |
279 (Grandchild_Type'(None, None, 15, "Hello", "Weird")) | |
280 then | |
281 Report.Failed ("Wrong value: selected component in assignment"); | |
282 end if; | |
283 end Selected_Component_Subtest; | |
284 | |
285 | |
286 -- | |
287 -- Check conversion in object renaming: | |
288 -- | |
289 | |
290 Object_Renaming_Subtest: | |
291 declare | |
292 use Root_Package, Parent_Package, Child_Package, Grandchild_Package; | |
293 | |
294 Var : Grandchild_Type := Grandchild_Value; | |
295 Ren1 : Parent_Type renames Parent_Type(Var); | |
296 Ren2 : Child_Type renames Child_Type(Var); | |
297 Ren3 : Parent_Type'Class renames Parent_Type'Class(Var); | |
298 Ren4 : Parent_Type renames Parent_Type(Ren2); -- Rename of rename. | |
299 begin | |
300 Outer_Proc (Ren1); | |
301 if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then | |
302 Report.Failed ("Value or tag not preserved by object renaming: Ren1"); | |
303 end if; | |
304 | |
305 Outer_Proc (Ren2); | |
306 if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then | |
307 Report.Failed ("Value or tag not preserved by object renaming: Ren2"); | |
308 end if; | |
309 | |
310 Outer_Proc (Ren3); | |
311 if Ren3 /= Parent_Type'Class | |
312 (Grandchild_Type'(Grandchild_Outer, | |
313 Grandchild_Inner, | |
314 15, | |
315 "Hello", | |
316 "World")) | |
317 then | |
318 Report.Failed ("Value or tag not preserved by object renaming: Ren3"); | |
319 end if; | |
320 | |
321 Outer_Proc (Ren4); | |
322 if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then | |
323 Report.Failed ("Value or tag not preserved by object renaming: Ren4"); | |
324 end if; | |
325 end Object_Renaming_Subtest; | |
326 | |
327 | |
328 -- | |
329 -- Check reading view conversion, and conversion as left side of assignment: | |
330 -- | |
331 | |
332 View_Conversion_Subtest: | |
333 declare | |
334 use Root_Package, Parent_Package, Child_Package, Grandchild_Package; | |
335 | |
336 Var : Grandchild_Type := Grandchild_Value; | |
337 Specific : Child_Type; | |
338 ClassWide : Parent_Type'Class := Var; -- Grandchild_Type tag. | |
339 begin | |
340 if Parent_Type(Var) /= (None, None, 15) then | |
341 Report.Failed ("View has wrong value: #1"); | |
342 end if; | |
343 | |
344 if Child_Type(Var) /= (None, None, 15, "Hello") then | |
345 Report.Failed ("View has wrong value: #2"); | |
346 end if; | |
347 | |
348 if Parent_Type'Class(Var) /= ClassWide_Func then | |
349 Report.Failed ("Upward view conversion did not preserve " & | |
350 "extension's components"); | |
351 end if; | |
352 | |
353 | |
354 Parent_Type(Specific) := (None, None, 26); -- Assign to view. | |
355 Outer_Proc (Specific); -- Call dispatching op. | |
356 | |
357 if Specific /= (Child_Outer, Child_Inner, 26, "-----") then | |
358 Report.Failed ("Value or tag not preserved by assignment: Specific"); | |
359 end if; | |
360 | |
361 | |
362 Parent_Type(ClassWide) := (None, None, 44); -- Assign to view. | |
363 Outer_Proc (ClassWide); -- Call dispatching op. | |
364 | |
365 if ClassWide /= Parent_Type'Class | |
366 (Grandchild_Type'(Grandchild_Outer, | |
367 Grandchild_Inner, | |
368 44, | |
369 "Hello", | |
370 "World")) | |
371 then | |
372 Report.Failed ("Value or tag not preserved by assignment: ClassWide"); | |
373 end if; | |
374 end View_Conversion_Subtest; | |
375 | |
376 Report.Result; | |
377 | |
378 end C460006; |