cde0001.a

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

-- CDE0001.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 following names can be used in the declaration of a
--      generic formal parameter (object, array type, or access type) without 
--      causing freezing of the named type:
--        (1) The name of a private type,
--        (2) A name that denotes a subtype of a private type, and
--        (3) A name that denotes a composite type with a subcomponent of a
--           private type (or subtype).
--      Check for untagged and tagged types.
--
-- TEST DESCRIPTION:
--      This transition test defines private and limited private types,
--      subtypes of these private types, records and arrays of both types and
--      subtypes, a tagged type and a private extension.
--      This test creates examples where the above types are used in the 
--      definition of several generic formal type parameters (object, array 
--      type, or access type) in both visible and private parts.  These 
--      visible and private generic packages are instantiated in the body of 
--      the public child and the private child, respectively.  
--      The main program utilizes the functions declared in the public child
--      to verify results of the instantiations.
--
--      Inspired by B74103F.ADA.
--
--
-- CHANGE HISTORY:
--      12 Mar 96   SAIC    Initial version for ACVC 2.1.
--      05 Oct 96   SAIC    ACVC 2.1: Added pragma Elaborate for CDE0001.
--      21 Nov 98   RLB     Added pragma Elaborate for CDE0001 to CDE0001_3.
--!

package CDE0001_0 is

   subtype Small_Int is Integer range 1 .. 2;

   type Private_Type    is private;
   type Limited_Private is limited private;

   subtype Private_Subtype         is Private_Type;
   subtype Limited_Private_Subtype is Limited_Private;

   type Array_Of_LP_Subtype is array (1..2) of Limited_Private_Subtype;

   type Rec_Of_Limited_Private is
     record
        C1 : Limited_Private;
     end record;

   type Rec_Of_Private_SubType is 
     record
        C1 : Private_SubType;
     end record;

   type Tag_Type is tagged
     record
        C1 : Small_Int;
     end record;

   type New_TagType is new Tag_Type with private;

   generic               

      Formal_Obj01 : in out Private_Type;              -- Formal objects defined
      Formal_Obj02 : in out Limited_Private;           -- by names of private 
      Formal_Obj03 : in out Private_Subtype;           -- types, names that
      Formal_Obj04 : in out Limited_Private_Subtype;   -- denotes subtypes of 
      Formal_Obj05 : in out New_TagType;               -- the private types.

   package CDE0001_1 is
      procedure Assign_Objects;

   end CDE0001_1;
   
private

   generic               
      -- Formal array types of a private type, a composite type with a 
      -- subcomponent of a private type.

      type Formal_Arr01 is array (Small_Int) of Private_Type;
      type Formal_Arr02 is array (Small_Int) of Rec_Of_Limited_Private;

      -- Formal access types of composite types with a subcomponent of 
      -- a private subtype.

      type Formal_Acc01 is access Rec_Of_Private_Subtype;
      type Formal_Acc02 is access Array_Of_LP_Subtype;

   package CDE0001_2 is

      procedure Assign_Arrays (P1 : out Formal_Arr01;
                               P2 : out Formal_Arr02);

      procedure Assign_Access (P1 : out Formal_Acc01;
                               P2 : out Formal_Acc02);

   end CDE0001_2;

   ----------------------------------------------------------
   type Private_Type    is range 1 .. 10;
   type Limited_Private is (Eh, Bee, Sea, Dee);
   type New_TagType     is new Tag_Type with 
     record
        C2 : Private_Type;
     end record;

end CDE0001_0;

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

package body CDE0001_0 is

   package body CDE0001_1 is

      procedure Assign_Objects is
      begin
         Formal_Obj01 := Private_Type'First;
         Formal_Obj02 := Limited_Private'Last;
         Formal_Obj03 := Private_Subtype'Last;
         Formal_Obj04 := Limited_Private_Subtype'First;
         Formal_Obj05 := New_TagType'(C1 => 2, C2 => Private_Type'Last);

      end Assign_Objects;

   end CDE0001_1;

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

   package body CDE0001_2 is

      procedure Assign_Arrays (P1 : out Formal_Arr01;
                               P2 : out Formal_Arr02) is
      begin
         P1(1)    := Private_Type'Pred(Private_Type'Last);
         P1(2)    := Private_Type'Succ(Private_Type'First);
         P2(1).C1 := Limited_Private'Succ(Limited_Private'First);
         P2(2).C1 := Limited_Private'Pred(Limited_Private'Last);

      end Assign_Arrays;

      -----------------------------------------------------------------
      procedure Assign_Access (P1 : out Formal_Acc01;
                               P2 : out Formal_Acc02) is
      begin
         P1 := new Rec_Of_Private_Subtype'(C1 => Private_Subtype'Last);
         P2 := new Array_Of_LP_Subtype'(Eh, Dee);

      end Assign_Access;

   end CDE0001_2;

end CDE0001_0;

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

-- The following private child package instantiates its parent private generic
-- package. 

with CDE0001_0;
pragma Elaborate (CDE0001_0); -- So generic unit can be instantiated.
private 
package CDE0001_0.CDE0001_3 is

   type Arr01 is array (Small_Int) of Private_Type;
   type Arr02 is array (Small_Int) of Rec_Of_Limited_Private;
   type Acc01 is access Rec_Of_Private_Subtype;
   type Acc02 is access Array_Of_LP_Subtype;

   package Formal_Types_Pck is new CDE0001_2 (Arr01, Arr02, Acc01, Acc02);
   
   Arr01_Obj : Arr01;
   Arr02_Obj : Arr02;
   Acc01_Obj : Acc01;
   Acc02_Obj : Acc02;

end CDE0001_0.CDE0001_3;

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

package CDE0001_0.CDE0001_4 is

   -- The following functions check the private types defined in the parent
   -- and the private child package from within the client program.

   function Verify_Objects return Boolean;

   function Verify_Arrays return Boolean;

   function Verify_Access return Boolean;

end CDE0001_0.CDE0001_4;

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

with CDE0001_0.CDE0001_3;            -- private sibling.

pragma Elaborate (CDE0001_0.CDE0001_3);

package body CDE0001_0.CDE0001_4 is

   Obj1 : Private_Type            := 2;   
   Obj2 : Limited_Private         := Bee;
   Obj3 : Private_Subtype         := 3;    
   Obj4 : Limited_Private_Subtype := Sea;
   Obj5 : New_TagType             := (1, 5);

   -- Instantiate the generic package declared in the visible part of
   -- the parent.
 
   package Formal_Obj_Pck is new CDE0001_1 (Obj1, Obj2, Obj3, Obj4, Obj5);

   ---------------------------------------------------
   function Verify_Objects return Boolean is
      Result : Boolean := False;
   begin
      if Obj1    = 1    and 
         Obj2    = Dee  and 
         Obj3    = 10   and 
         Obj4    = Eh   and 
         Obj5.C1 = 2    and
         Obj5.C2 = 10   then
           Result := True;
      end if;

      return Result;

   end Verify_Objects;

   ---------------------------------------------------
   function Verify_Arrays return Boolean is
      Result : Boolean := False;
   begin
      if CDE0001_0.CDE0001_3.Arr01_Obj(1)    = 9     and 
         CDE0001_0.CDE0001_3.Arr01_Obj(2)    = 2     and 
         CDE0001_0.CDE0001_3.Arr02_Obj(1).C1 = Bee   and 
         CDE0001_0.CDE0001_3.Arr02_Obj(2).C1 = Sea   then
           Result := True;
      end if;

      return Result;

   end Verify_Arrays;

   ---------------------------------------------------
   function Verify_Access return Boolean is
      Result : Boolean := False;
   begin
      if CDE0001_0.CDE0001_3.Acc01_Obj.C1  = 10   and 
         CDE0001_0.CDE0001_3.Acc02_Obj(1)  = Eh   and
         CDE0001_0.CDE0001_3.Acc02_Obj(2)  = Dee  then
            Result := True;
      end if;

      return Result;

   end Verify_Access;

begin

   Formal_Obj_Pck.Assign_Objects;

   CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Arrays 
     (CDE0001_0.CDE0001_3.Arr01_Obj, CDE0001_0.CDE0001_3.Arr02_Obj);
   CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Access 
     (CDE0001_0.CDE0001_3.Acc01_Obj, CDE0001_0.CDE0001_3.Acc02_Obj);

end CDE0001_0.CDE0001_4;

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

with Report;
with CDE0001_0.CDE0001_4;

procedure CDE0001 is

begin

   Report.Test ("CDE0001", "Check that the name of the private type, a "  &
                "name that denotes a subtype of the private type, or a "  &
                "name that denotes a composite type with a subcomponent " &
                "of a private type can be used in the declaration of a "  &
                "generic formal type parameter without causing freezing " &
                "of the named type");

   if not CDE0001_0.CDE0001_4.Verify_Objects then
      Report.Failed ("Wrong values for formal objects");
   end if;

   if not CDE0001_0.CDE0001_4.Verify_Arrays then
      Report.Failed ("Wrong values for formal array types");
   end if;

   if not CDE0001_0.CDE0001_4.Verify_Access then
      Report.Failed ("Wrong values for formal access types");
   end if;

   Report.Result;

end CDE0001;