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
75package 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
87end C390007_0;
88
89
90     --==================================================================--
91
92
93package 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
100end C390007_0;
101
102
103     --==================================================================--
104
105
106package 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
115end C390007_0.C390007_1;
116
117
118     --==================================================================--
119
120
121package 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
133end C390007_0.C390007_1;
134
135
136     --==================================================================--
137
138
139package 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
146end C390007_0.C390007_1.C390007_2;
147
148
149     --==================================================================--
150
151
152package 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
166end C390007_0.C390007_1.C390007_2;
167
168
169     --==================================================================--
170
171
172package 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
182end C390007_0.C390007_3;
183
184
185     --==================================================================--
186
187
188package 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
201end C390007_0.C390007_3;
202
203
204     --==================================================================--
205
206
207package 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
214end C390007_0.C390007_3.C390007_4;
215
216
217     --==================================================================--
218
219
220package 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
233end C390007_0.C390007_3.C390007_4;
234
235
236     --==================================================================--
237
238
239with C390007_0.C390007_1.C390007_2;
240with C390007_0.C390007_3.C390007_4;
241use  C390007_0;
242
243with Report;
244procedure C390007 is
245begin
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
374end C390007;
375