path: root/gcc/testsuite/ada/acats/tests/c4/c460006.a

-- C460006.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that a view conversion to a tagged type is permitted in the 
--      prefix of a selected component, an object renaming declaration, and 
--      (if the operand is a variable) on the left side of an assignment 
--      statement. Check that such a renaming or assignment does not change 
--      the tag of the operand.
--
--      Check that, for a view conversion of a tagged type, each
--      nondiscriminant component of the new view denotes the matching
--      component of the operand object. Check that reading the value of the
--      view yields the result of converting the value of the operand object
--      to the target subtype.
--
-- TEST DESCRIPTION:
--      The fact that the tag of an object is not changed is verified by
--      making calls to primitive operations which in turn make (re)dispatching
--      calls, and confirming that the proper bodies are executed.
--
--      Selected components are checked in three contexts: as the object name
--      in an object renaming declaration, as the left operand of an inequality
--      operation, and as the left side of an assignment statement.
--
--      View conversions of an object of a 2nd level type extension are
--      renamed as objects of an ancestor type and of a class-wide type. In
--      one case the operand of the conversion is itself a renaming of an
--      object.
--
--      View conversions of an object of a 2nd level type extension are
--      checked for equality with record aggregates of various ancestor types.
--      In one case, the view conversion is to a class-wide type, and it is
--      checked for equality with the result of a class-wide function with
--      the following structure:
--
--         function F return T'Class is
--            A : DDT     := Expected_Value;
--            X : T'Class := T(A);
--         begin
--            return X;
--
--         end F;
--
--         ...
--
--         Var : DDT := Expected_Value;
--
--         if (T'Class(Var) /= F) then    -- Condition should yield FALSE.
--            FAIL;
--         end if;
--
--      The view conversion to which X is initialized does not affect the
--      value or tag of the operand; the tag of X is that of type DDT (not T),
--      and the components are those of A. The result of this function
--      should equal the value of an object of type DDT initialized to the
--      same value as F.A.
--
--      To check that assignment to a view conversion does not change the tag
--      of the operand, an assignment is made to a conversion of an object,
--      and the object is then passed as an actual to a dispatching operation.
--      Conversions to both specific and class-wide types are checked.
--
--
-- CHANGE HISTORY:
--      20 Jul 95   SAIC    Initial prerelease version.
--      24 Apr 96   SAIC    Added type conversions.
--
--!

package C460006_0 is

   type Call_ID_Kind is (None, Parent_Outer,     Parent_Inner,
                               Child_Outer,      Child_Inner,
                               Grandchild_Outer, Grandchild_Inner);

   type Root_Type is abstract tagged record
      First_Call  : Call_ID_Kind := None;
      Second_Call : Call_ID_Kind := None;
   end record;

   procedure Inner_Proc (X : in out Root_Type) is abstract;
   procedure Outer_Proc (X : in out Root_Type) is abstract;

end C460006_0;


     --==================================================================--


package C460006_0.C460006_1 is

   type Parent_Type is new Root_Type with record
      C1 : Integer := 0;
   end record;

   procedure Inner_Proc (X : in out Parent_Type);
   procedure Outer_Proc (X : in out Parent_Type);

end C460006_0.C460006_1;


     --==================================================================--


package body C460006_0.C460006_1 is

   procedure Inner_Proc (X : in out Parent_Type) is
   begin
      X.Second_Call := Parent_Inner;
   end Inner_Proc;

   -------------------------------------------------
   procedure Outer_Proc (X : in out Parent_Type) is
   begin
      X.First_Call := Parent_Outer;
      Inner_Proc ( Parent_Type'Class(X) );
   end Outer_Proc;

end C460006_0.C460006_1;


     --==================================================================--


package C460006_0.C460006_1.C460006_2 is

   type Child_Type is new Parent_Type with record
      C2 : String(1 .. 5) := "-----";
   end record;

   procedure Inner_Proc (X : in out Child_Type);
   procedure Outer_Proc (X : in out Child_Type);

end C460006_0.C460006_1.C460006_2;


     --==================================================================--


package body C460006_0.C460006_1.C460006_2 is

   procedure Inner_Proc (X : in out Child_Type) is
   begin
      X.Second_Call := Child_Inner;
   end Inner_Proc;

   -------------------------------------------------
   procedure Outer_Proc (X : in out Child_Type) is
   begin
      X.First_Call := Child_Outer;
      Inner_Proc ( Parent_Type'Class(X) );
   end Outer_Proc;

end C460006_0.C460006_1.C460006_2;


     --==================================================================--


package C460006_0.C460006_1.C460006_2.C460006_3 is

   type Grandchild_Type is new Child_Type with record
      C3: String(1 .. 5) := "-----";
   end record;

   procedure Inner_Proc (X : in out Grandchild_Type);
   procedure Outer_Proc (X : in out Grandchild_Type);


   function ClassWide_Func return Parent_Type'Class;


   Grandchild_Value : constant Grandchild_Type := (First_Call  => None,
                                                   Second_Call => None,
                                                   C1          => 15,
                                                   C2          => "Hello",
                                                   C3          => "World");

end C460006_0.C460006_1.C460006_2.C460006_3;


     --==================================================================--


package body C460006_0.C460006_1.C460006_2.C460006_3 is

   procedure Inner_Proc (X : in out Grandchild_Type) is
   begin
      X.Second_Call := Grandchild_Inner;
   end Inner_Proc;

   -------------------------------------------------
   procedure Outer_Proc (X : in out Grandchild_Type) is
   begin
      X.First_Call := Grandchild_Outer;
      Inner_Proc ( Parent_Type'Class(X) );
   end Outer_Proc;

   -------------------------------------------------
   function ClassWide_Func return Parent_Type'Class is
      A : Grandchild_Type   := Grandchild_Value;
      X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A.
   begin
      return X;
   end ClassWide_Func;

end C460006_0.C460006_1.C460006_2.C460006_3;


     --==================================================================--


with C460006_0.C460006_1.C460006_2.C460006_3;

with Report;
procedure C460006 is

   package Root_Package       renames C460006_0;
   package Parent_Package     renames C460006_0.C460006_1;
   package Child_Package      renames C460006_0.C460006_1.C460006_2;
   package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3;

begin
   Report.Test ("C460006", "Check that a view conversion to a tagged type " &
                "is permitted in the prefix of a selected component, an "   &
                "object renaming declaration, and (if the operand is a "    &
                "variable) on the left side of an assignment statement.  "  &
                "Check that such a renaming or assignment does not change " &
                " the tag of the operand");


   --
   -- Check conversion as prefix of selected component:
   --

   Selected_Component_Subtest:
   declare
      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;

      Var    : Grandchild_Type   := Grandchild_Value;
      CW_Var : Parent_Type'Class := Var;

      Ren    : Integer renames Parent_Type(Var).C1;

   begin
      if Ren /= 15 then
         Report.Failed ("Wrong value: selected component in renaming");
      end if;

      if Child_Type(Var).C2 /= "Hello" then
         Report.Failed ("Wrong value: selected component in IF");
      end if;

      Grandchild_Type(CW_Var).C3(2..4) := "eir";
      if CW_Var /= Parent_Type'Class
                   (Grandchild_Type'(None, None, 15, "Hello", "Weird"))
      then
         Report.Failed ("Wrong value: selected component in assignment");
      end if;
   end Selected_Component_Subtest;


   --
   -- Check conversion in object renaming:
   --

   Object_Renaming_Subtest:
   declare
      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;

      Var : Grandchild_Type := Grandchild_Value;
      Ren1 : Parent_Type       renames Parent_Type(Var);
      Ren2 : Child_Type        renames Child_Type(Var);
      Ren3 : Parent_Type'Class renames Parent_Type'Class(Var);
      Ren4 : Parent_Type       renames Parent_Type(Ren2); -- Rename of rename.
   begin
      Outer_Proc (Ren1);
      if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then
         Report.Failed ("Value or tag not preserved by object renaming: Ren1");
      end if;

      Outer_Proc (Ren2);
      if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then
         Report.Failed ("Value or tag not preserved by object renaming: Ren2");
      end if;

      Outer_Proc (Ren3);
      if Ren3 /= Parent_Type'Class
                 (Grandchild_Type'(Grandchild_Outer,
                                   Grandchild_Inner,
                                   15,
                                   "Hello",
                                   "World"))
      then
         Report.Failed ("Value or tag not preserved by object renaming: Ren3");
      end if;

      Outer_Proc (Ren4);
      if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then
         Report.Failed ("Value or tag not preserved by object renaming: Ren4");
      end if;
   end Object_Renaming_Subtest;


   --
   -- Check reading view conversion, and conversion as left side of assignment:
   --

   View_Conversion_Subtest:
   declare
      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;

      Var : Grandchild_Type := Grandchild_Value;
      Specific  : Child_Type;
      ClassWide : Parent_Type'Class := Var;   -- Grandchild_Type tag.
   begin
      if Parent_Type(Var) /= (None, None, 15) then
         Report.Failed ("View has wrong value: #1");
      end if;

      if Child_Type(Var) /= (None, None, 15, "Hello") then
         Report.Failed ("View has wrong value: #2");
      end if;

      if Parent_Type'Class(Var) /= ClassWide_Func then
         Report.Failed ("Upward view conversion did not preserve " &
                        "extension's components");
      end if;


      Parent_Type(Specific) := (None, None, 26); -- Assign to view.
      Outer_Proc (Specific);                     -- Call dispatching op.

      if Specific /= (Child_Outer, Child_Inner, 26, "-----") then
         Report.Failed ("Value or tag not preserved by assignment: Specific");
      end if;


      Parent_Type(ClassWide) := (None, None, 44); -- Assign to view.
      Outer_Proc (ClassWide);                     -- Call dispatching op.

      if ClassWide /= Parent_Type'Class
                      (Grandchild_Type'(Grandchild_Outer,
                                        Grandchild_Inner,
                                        44,
                                        "Hello",
                                        "World"))
      then
         Report.Failed ("Value or tag not preserved by assignment: ClassWide");
      end if;
   end View_Conversion_Subtest;

   Report.Result;

end C460006;