c390007.a

来自「linux下编程用 编译软件」· A 代码 · 共 375 行

-- 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;