Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c390007.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 -- C390007.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 the tag of an object of a tagged type is preserved by
28 -- type conversion and parameter passing.
29 --
30 -- TEST DESCRIPTION:
31 -- The fact that the tag of an object is not changed is verified by
32 -- making dispatching calls to primitive operations, and confirming that
33 -- the proper body is executed. Objects of both specific and class-wide
34 -- types are checked.
35 --
36 -- The dispatching calls are made in two contexts. The first is a
37 -- straightforward dispatching call made from within a class-wide
38 -- operation. The second is a redispatch from within a primitive
39 -- operation.
40 --
41 -- For the parameter passing case, the initial class-wide and specific
42 -- objects are passed directly in calls to the class-wide and primitive
43 -- operations. The redispatch is accomplished by initializing a local
44 -- class-wide object in the primitive operation to the value of the
45 -- formal parameter, and using the local object as the actual in the
46 -- (re)dispatching call.
47 --
48 -- For the type conversion case, the initial class-wide object is assigned
49 -- a view conversion of an object of a specific type:
50 --
51 -- type T is tagged ...
52 -- type DT is new T with ...
53 --
54 -- A : DT;
55 -- B : T'Class := T(A); -- Despite conversion, tag of B is that of DT.
56 --
57 -- The class-wide object is then passed directly in calls to the
58 -- class-wide and primitive operations. For the initial object of a
59 -- specific type, however, a view conversion of the object is passed,
60 -- forcing a non-dispatching call in the primitive operation case. Within
61 -- the primitive operation, a view conversion of the formal parameter to
62 -- a class-wide type is then used to force a (re)dispatching call.
63 --
64 -- For the type conversion and parameter passing case, a combining of
65 -- view conversion and parameter passing of initial specific objects are
66 -- called directly to the class-wide and primitive operations.
67 --
68 --
69 -- CHANGE HISTORY:
70 -- 28 Jun 95 SAIC Initial prerelease version.
71 -- 23 Apr 96 SAIC Added use C390007_0 in the main.
72 --
73 --!
74
75 package C390007_0 is
76
77 type Call_ID_Kind is (None, Parent_Outer, Parent_Inner,
78 Derived_Outer, Derived_Inner);
79
80 type Root_Type is abstract tagged null record;
81
82 procedure Outer_Proc (X : in out Root_Type) is abstract;
83 procedure Inner_Proc (X : in out Root_Type) is abstract;
84
85 procedure ClassWide_Proc (X : in out Root_Type'Class);
86
87 end C390007_0;
88
89
90 --==================================================================--
91
92
93 package body C390007_0 is
94
95 procedure ClassWide_Proc (X : in out Root_Type'Class) is
96 begin
97 Inner_Proc (X);
98 end ClassWide_Proc;
99
100 end C390007_0;
101
102
103 --==================================================================--
104
105
106 package C390007_0.C390007_1 is
107
108 type Param_Parent_Type is new Root_Type with record
109 Last_Call : Call_ID_Kind := None;
110 end record;
111
112 procedure Outer_Proc (X : in out Param_Parent_Type);
113 procedure Inner_Proc (X : in out Param_Parent_Type);
114
115 end C390007_0.C390007_1;
116
117
118 --==================================================================--
119
120
121 package body C390007_0.C390007_1 is
122
123 procedure Outer_Proc (X : in out Param_Parent_Type) is
124 begin
125 X.Last_Call := Parent_Outer;
126 end Outer_Proc;
127
128 procedure Inner_Proc (X : in out Param_Parent_Type) is
129 begin
130 X.Last_Call := Parent_Inner;
131 end Inner_Proc;
132
133 end C390007_0.C390007_1;
134
135
136 --==================================================================--
137
138
139 package C390007_0.C390007_1.C390007_2 is
140
141 type Param_Derived_Type is new Param_Parent_Type with null record;
142
143 procedure Outer_Proc (X : in out Param_Derived_Type);
144 procedure Inner_Proc (X : in out Param_Derived_Type);
145
146 end C390007_0.C390007_1.C390007_2;
147
148
149 --==================================================================--
150
151
152 package body C390007_0.C390007_1.C390007_2 is
153
154 procedure Outer_Proc (X : in out Param_Derived_Type) is
155 Y : Root_Type'Class := X;
156 begin
157 Inner_Proc (Y); -- Redispatch.
158 Root_Type'Class (X) := Y;
159 end Outer_Proc;
160
161 procedure Inner_Proc (X : in out Param_Derived_Type) is
162 begin
163 X.Last_Call := Derived_Inner;
164 end Inner_Proc;
165
166 end C390007_0.C390007_1.C390007_2;
167
168
169 --==================================================================--
170
171
172 package C390007_0.C390007_3 is
173
174 type Convert_Parent_Type is new Root_Type with record
175 First_Call : Call_ID_Kind := None;
176 Second_Call : Call_ID_Kind := None;
177 end record;
178
179 procedure Outer_Proc (X : in out Convert_Parent_Type);
180 procedure Inner_Proc (X : in out Convert_Parent_Type);
181
182 end C390007_0.C390007_3;
183
184
185 --==================================================================--
186
187
188 package body C390007_0.C390007_3 is
189
190 procedure Outer_Proc (X : in out Convert_Parent_Type) is
191 begin
192 X.First_Call := Parent_Outer;
193 Inner_Proc (Root_Type'Class(X)); -- Redispatch.
194 end Outer_Proc;
195
196 procedure Inner_Proc (X : in out Convert_Parent_Type) is
197 begin
198 X.Second_Call := Parent_Inner;
199 end Inner_Proc;
200
201 end C390007_0.C390007_3;
202
203
204 --==================================================================--
205
206
207 package C390007_0.C390007_3.C390007_4 is
208
209 type Convert_Derived_Type is new Convert_Parent_Type with null record;
210
211 procedure Outer_Proc (X : in out Convert_Derived_Type);
212 procedure Inner_Proc (X : in out Convert_Derived_Type);
213
214 end C390007_0.C390007_3.C390007_4;
215
216
217 --==================================================================--
218
219
220 package body C390007_0.C390007_3.C390007_4 is
221
222 procedure Outer_Proc (X : in out Convert_Derived_Type) is
223 begin
224 X.First_Call := Derived_Outer;
225 Inner_Proc (Root_Type'Class(X)); -- Redispatch.
226 end Outer_Proc;
227
228 procedure Inner_Proc (X : in out Convert_Derived_Type) is
229 begin
230 X.Second_Call := Derived_Inner;
231 end Inner_Proc;
232
233 end C390007_0.C390007_3.C390007_4;
234
235
236 --==================================================================--
237
238
239 with C390007_0.C390007_1.C390007_2;
240 with C390007_0.C390007_3.C390007_4;
241 use C390007_0;
242
243 with Report;
244 procedure C390007 is
245 begin
246 Report.Test ("C390007", "Check that the tag of an object of a tagged " &
247 "type is preserved by type conversion and parameter passing");
248
249
250 --
251 -- Check that tags are preserved by parameter passing:
252 --
253
254 Parameter_Passing_Subtest:
255 declare
256 Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
257 Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
258
259 ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A;
260 ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B;
261
262 use C390007_0.C390007_1;
263 use C390007_0.C390007_1.C390007_2;
264 begin
265
266 Outer_Proc (Specific_A);
267 if Specific_A.Last_Call /= Derived_Inner then
268 Report.Failed ("Parameter passing: tag not preserved in call to " &
269 "primitive operation with specific operand");
270 end if;
271
272 C390007_0.ClassWide_Proc (Specific_B);
273 if Specific_B.Last_Call /= Derived_Inner then
274 Report.Failed ("Parameter passing: tag not preserved in call to " &
275 "class-wide operation with specific operand");
276 end if;
277
278 Outer_Proc (ClassWide_A);
279 if ClassWide_A.Last_Call /= Derived_Inner then
280 Report.Failed ("Parameter passing: tag not preserved in call to " &
281 "primitive operation with class-wide operand");
282 end if;
283
284 C390007_0.ClassWide_Proc (ClassWide_B);
285 if ClassWide_B.Last_Call /= Derived_Inner then
286 Report.Failed ("Parameter passing: tag not preserved in call to " &
287 "class-wide operation with class-wide operand");
288 end if;
289
290 end Parameter_Passing_Subtest;
291
292
293 --
294 -- Check that tags are preserved by type conversion:
295 --
296
297 Type_Conversion_Subtest:
298 declare
299 Specific_A : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;
300 Specific_B : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;
301
302 ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class :=
303 C390007_0.C390007_3.Convert_Parent_Type(Specific_A);
304 ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class :=
305 C390007_0.C390007_3.Convert_Parent_Type(Specific_B);
306
307 use C390007_0.C390007_3;
308 use C390007_0.C390007_3.C390007_4;
309 begin
310
311 Outer_Proc (Convert_Parent_Type(Specific_A));
312 if (Specific_A.First_Call /= Parent_Outer) or
313 (Specific_A.Second_Call /= Derived_Inner)
314 then
315 Report.Failed ("Type conversion: tag not preserved in call to " &
316 "primitive operation with specific operand");
317 end if;
318
319 Outer_Proc (ClassWide_A);
320 if (ClassWide_A.First_Call /= Derived_Outer) or
321 (ClassWide_A.Second_Call /= Derived_Inner)
322 then
323 Report.Failed ("Type conversion: tag not preserved in call to " &
324 "primitive operation with class-wide operand");
325 end if;
326
327 C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B));
328 if (Specific_B.Second_Call /= Derived_Inner) then
329 Report.Failed ("Type conversion: tag not preserved in call to " &
330 "class-wide operation with specific operand");
331 end if;
332
333 C390007_0.ClassWide_Proc (ClassWide_B);
334 if (ClassWide_A.Second_Call /= Derived_Inner) then
335 Report.Failed ("Type conversion: tag not preserved in call to " &
336 "class-wide operation with class-wide operand");
337 end if;
338
339 end Type_Conversion_Subtest;
340
341
342 --
343 -- Check that tags are preserved by type conversion and parameter passing:
344 --
345
346 Type_Conversion_And_Parameter_Passing_Subtest:
347 declare
348 Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
349 Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
350
351 use C390007_0.C390007_1;
352 use C390007_0.C390007_1.C390007_2;
353 begin
354
355 Outer_Proc (Param_Parent_Type (Specific_A));
356 if Specific_A.Last_Call /= Parent_Outer then
357 Report.Failed ("Type conversion and parameter passing: tag not " &
358 "preserved in call to primitive operation with " &
359 "specific operand");
360 end if;
361
362 C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B));
363 if Specific_B.Last_Call /= Derived_Inner then
364 Report.Failed ("Type conversion and parameter passing: tag not " &
365 "preserved in call to class-wide operation with " &
366 "specific operand");
367 end if;
368
369 end Type_Conversion_And_Parameter_Passing_Subtest;
370
371
372 Report.Result;
373
374 end C390007;