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
93package 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
107end C460006_0;
108
109
110     --==================================================================--
111
112
113package 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
122end C460006_0.C460006_1;
123
124
125     --==================================================================--
126
127
128package 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
142end C460006_0.C460006_1;
143
144
145     --==================================================================--
146
147
148package 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
157end C460006_0.C460006_1.C460006_2;
158
159
160     --==================================================================--
161
162
163package 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
177end C460006_0.C460006_1.C460006_2;
178
179
180     --==================================================================--
181
182
183package 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
202end C460006_0.C460006_1.C460006_2.C460006_3;
203
204
205     --==================================================================--
206
207
208package 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
230end C460006_0.C460006_1.C460006_2.C460006_3;
231
232
233     --==================================================================--
234
235
236with C460006_0.C460006_1.C460006_2.C460006_3;
237
238with Report;
239procedure 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
246begin
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
378end C460006;
379