Subversion Repositories openrisc

-- C390007.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 the tag of an object of a tagged type is preserved by

--      type conversion and parameter passing.

--

-- TEST DESCRIPTION:

--      The fact that the tag of an object is not changed is verified by

--      making dispatching calls to primitive operations, and confirming that

--      the proper body is executed. Objects of both specific and class-wide

--      types are checked.

--

--      The dispatching calls are made in two contexts. The first is a

--      straightforward dispatching call made from within a class-wide

--      operation. The second is a redispatch from within a primitive

--      operation.

--

--      For the parameter passing case, the initial class-wide and specific

--      objects are passed directly in calls to the class-wide and primitive

--      operations. The redispatch is accomplished by initializing a local

--      class-wide object in the primitive operation to the value of the

--      formal parameter, and using the local object as the actual in the

--      (re)dispatching call.

--

--      For the type conversion case, the initial class-wide object is assigned

--      a view conversion of an object of a specific type:

--

--         type T is tagged ...

--         type DT is new T with ...

--

--         A : DT;

--         B : T'Class := T(A); -- Despite conversion, tag of B is that of DT.

--

--      The class-wide object is then passed directly in calls to the

--      class-wide and primitive operations. For the initial object of a

--      specific type, however, a view conversion of the object is passed,

--      forcing a non-dispatching call in the primitive operation case. Within

--      the primitive operation, a view conversion of the formal parameter to

--      a class-wide type is then used to force a (re)dispatching call.

--

--      For the type conversion and parameter passing case, a combining of

--      view conversion and parameter passing of initial specific objects are

--      called directly to the class-wide and primitive operations.

--

--

-- CHANGE HISTORY:

--      28 Jun 95   SAIC    Initial prerelease version.

--      23 Apr 96   SAIC    Added use C390007_0 in the main.

--

--!

package C390007_0 is

   type Call_ID_Kind is (None, Parent_Outer,  Parent_Inner,

                               Derived_Outer, Derived_Inner);

   type Root_Type is abstract tagged null record;

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

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

   procedure ClassWide_Proc (X : in out Root_Type'Class);

end C390007_0;

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

package body C390007_0 is

   procedure ClassWide_Proc (X : in out Root_Type'Class) is

   begin

      Inner_Proc (X);

   end ClassWide_Proc;

end C390007_0;

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

package C390007_0.C390007_1 is

   type Param_Parent_Type is new Root_Type with record

      Last_Call : Call_ID_Kind := None;

   end record;

   procedure Outer_Proc (X : in out Param_Parent_Type);

   procedure Inner_Proc (X : in out Param_Parent_Type);

end C390007_0.C390007_1;

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

package body C390007_0.C390007_1 is

   procedure Outer_Proc (X : in out Param_Parent_Type) is

   begin

      X.Last_Call := Parent_Outer;

   end Outer_Proc;

   procedure Inner_Proc (X : in out Param_Parent_Type) is

   begin

      X.Last_Call := Parent_Inner;

   end Inner_Proc;

end C390007_0.C390007_1;

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

package C390007_0.C390007_1.C390007_2 is

   type Param_Derived_Type is new Param_Parent_Type with null record;

   procedure Outer_Proc (X : in out Param_Derived_Type);

   procedure Inner_Proc (X : in out Param_Derived_Type);

end C390007_0.C390007_1.C390007_2;

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

package body C390007_0.C390007_1.C390007_2 is

   procedure Outer_Proc (X : in out Param_Derived_Type) is

      Y : Root_Type'Class := X;

   begin

      Inner_Proc (Y);  -- Redispatch.

      Root_Type'Class (X) := Y;

   end Outer_Proc;

   procedure Inner_Proc (X : in out Param_Derived_Type) is

   begin

      X.Last_Call := Derived_Inner;

   end Inner_Proc;

end C390007_0.C390007_1.C390007_2;

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

package C390007_0.C390007_3 is

   type Convert_Parent_Type is new Root_Type with record

      First_Call  : Call_ID_Kind := None;

      Second_Call : Call_ID_Kind := None;

   end record;

   procedure Outer_Proc (X : in out Convert_Parent_Type);

   procedure Inner_Proc (X : in out Convert_Parent_Type);

end C390007_0.C390007_3;

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

package body C390007_0.C390007_3 is

   procedure Outer_Proc (X : in out Convert_Parent_Type) is

   begin

      X.First_Call := Parent_Outer;

      Inner_Proc (Root_Type'Class(X));  -- Redispatch.

   end Outer_Proc;

   procedure Inner_Proc (X : in out Convert_Parent_Type) is

   begin

      X.Second_Call := Parent_Inner;

   end Inner_Proc;

end C390007_0.C390007_3;

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

package C390007_0.C390007_3.C390007_4 is

   type Convert_Derived_Type is new Convert_Parent_Type with null record;

   procedure Outer_Proc (X : in out Convert_Derived_Type);

   procedure Inner_Proc (X : in out Convert_Derived_Type);

end C390007_0.C390007_3.C390007_4;

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

package body C390007_0.C390007_3.C390007_4 is

   procedure Outer_Proc (X : in out Convert_Derived_Type) is

   begin

      X.First_Call := Derived_Outer;

      Inner_Proc (Root_Type'Class(X));  -- Redispatch.

   end Outer_Proc;

   procedure Inner_Proc (X : in out Convert_Derived_Type) is

   begin

      X.Second_Call := Derived_Inner;

   end Inner_Proc;

end C390007_0.C390007_3.C390007_4;

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

with C390007_0.C390007_1.C390007_2;

with C390007_0.C390007_3.C390007_4;

use  C390007_0;

with Report;

procedure C390007 is

begin

   Report.Test ("C390007", "Check that the tag of an object of a tagged " &

                "type is preserved by type conversion and parameter passing");

   --

   -- Check that tags are preserved by parameter passing:

   --

   Parameter_Passing_Subtest:

   declare

      Specific_A  : C390007_0.C390007_1.C390007_2.Param_Derived_Type;

      Specific_B  : C390007_0.C390007_1.C390007_2.Param_Derived_Type;

      ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A;

      ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B;

      use C390007_0.C390007_1;

      use C390007_0.C390007_1.C390007_2;

   begin

      Outer_Proc (Specific_A);

      if Specific_A.Last_Call /= Derived_Inner then

         Report.Failed ("Parameter passing: tag not preserved in call to " &

                        "primitive operation with specific operand");

      end if;

      C390007_0.ClassWide_Proc (Specific_B);

      if Specific_B.Last_Call /= Derived_Inner then

         Report.Failed ("Parameter passing: tag not preserved in call to " &

                        "class-wide operation with specific operand");

      end if;

      Outer_Proc (ClassWide_A);

      if ClassWide_A.Last_Call /= Derived_Inner then

         Report.Failed ("Parameter passing: tag not preserved in call to " &

                        "primitive operation with class-wide operand");

      end if;

      C390007_0.ClassWide_Proc (ClassWide_B);

      if ClassWide_B.Last_Call /= Derived_Inner then

         Report.Failed ("Parameter passing: tag not preserved in call to " &

                        "class-wide operation with class-wide operand");

      end if;

   end Parameter_Passing_Subtest;

   --

   -- Check that tags are preserved by type conversion:

   --

   Type_Conversion_Subtest:

   declare

      Specific_A  : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;

      Specific_B  : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;

      ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class :=

                    C390007_0.C390007_3.Convert_Parent_Type(Specific_A);

      ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class :=

                    C390007_0.C390007_3.Convert_Parent_Type(Specific_B);

      use C390007_0.C390007_3;

      use C390007_0.C390007_3.C390007_4;

   begin

      Outer_Proc (Convert_Parent_Type(Specific_A));

      if (Specific_A.First_Call  /= Parent_Outer)  or

         (Specific_A.Second_Call /= Derived_Inner)

      then

         Report.Failed ("Type conversion: tag not preserved in call to " &

                        "primitive operation with specific operand");

      end if;

      Outer_Proc (ClassWide_A);

      if (ClassWide_A.First_Call  /= Derived_Outer) or

         (ClassWide_A.Second_Call /= Derived_Inner)

      then

         Report.Failed ("Type conversion: tag not preserved in call to " &

                        "primitive operation with class-wide operand");

      end if;

      C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B));

      if (Specific_B.Second_Call /= Derived_Inner) then

         Report.Failed ("Type conversion: tag not preserved in call to " &

                        "class-wide operation with specific operand");

      end if;

      C390007_0.ClassWide_Proc (ClassWide_B);

      if (ClassWide_A.Second_Call /= Derived_Inner) then

         Report.Failed ("Type conversion: tag not preserved in call to " &

                        "class-wide operation with class-wide operand");

      end if;

   end Type_Conversion_Subtest;

   --

   -- Check that tags are preserved by type conversion and parameter passing:

   --

   Type_Conversion_And_Parameter_Passing_Subtest:

   declare

      Specific_A  : C390007_0.C390007_1.C390007_2.Param_Derived_Type;

      Specific_B  : C390007_0.C390007_1.C390007_2.Param_Derived_Type;

      use C390007_0.C390007_1;

      use C390007_0.C390007_1.C390007_2;

   begin

      Outer_Proc (Param_Parent_Type (Specific_A));

      if Specific_A.Last_Call /= Parent_Outer then

         Report.Failed ("Type conversion and parameter passing: tag not " &

                        "preserved in call to primitive operation with "  &

                        "specific operand");

      end if;

      C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B));

      if Specific_B.Last_Call /= Derived_Inner then

         Report.Failed ("Type conversion and parameter passing: tag not " &

                        "preserved in call to class-wide operation with "  &

                        "specific operand");

      end if;

   end Type_Conversion_And_Parameter_Passing_Subtest;

   Report.Result;

end C390007;