c330001.a

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

-- C330001.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 variable object of an indefinite type is properly 
--      initialized/constrained by an initial value assignment that is 
--      a) an aggregate, b) a function, or c) an object.  Check that objects 
--      of the above types do not need explicit constraints if they have 
--      initial values.  
--                    
-- TEST DESCRIPTION: 
--      An indefinite subtype is either: 
--         a) An unconstrained array subtype. 
--         b) A subtype with unknown discriminants.
--         c) A subtype with unconstrained discriminants without defaults. 
-- 
--      Declare several indefinite types in a parent package specification.  
--      In the private part, complete one type with a discriminant without 
--      default (indefinite) and the other with a default discriminant 
--      (definite).  Declare objects of both indefinite and definite subtypes 
--      in children (private and public) with initialization expressions.  The 
--      test verifies all values of the objects.  It also verifies that
--      Constraint_Error is raised if an attempt is made to change the 
--      discriminants of the objects of the indefinite subtypes.        
-- 
-- 
-- CHANGE HISTORY: 
--      15 Jan 95   SAIC    Initial version for ACVC 2.1
--      25 Jul 96   SAIC    Modified test description. Deleted use C330001_0.
--      20 Nov 98   RLB     Added Elaborate pragmas to avoid problems
--                          with an unconventional, but legal, elaboration
--                          order.
--!

package C330001_0 is  

   subtype Sub_Type is Integer range 1 .. 20;

   type Tag_W_Disc (D : Sub_Type) is tagged record
       C1 :  String (1 .. D);
   end record;

   -- Indefinite type declarations.

   type FullViewDefinite_Unknown_Disc (<>) is private;           

   type Indefinite_No_Disc is array (Positive range <>) of Integer;

   type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged
     record
        C1 : Boolean := False;
     end record;

   type Indefinite_New_W_Disc (ND : Sub_Type) is new 
     Indefinite_Tag_W_Disc (ND) with record
        C2 : Integer := 9;
     end record;

   type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with 
     record     
        S : Sub_Type := 18;
     end record;
                                                    
   type Indefinite_W_Inherit_Disc_2 is     
     new Tag_W_Disc with private;                                       
                                                                           
   function Indef_Func_1 return FullViewDefinite_Unknown_Disc;

   function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2;

private

   type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is
      record     
        S : String (1 .. D) := "Hi";
      end record;

   type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with 
      record     
        S : Sub_Type;
      end record;

end C330001_0;

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

package body C330001_0 is  

   function Indef_Func_1 return FullViewDefinite_Unknown_Disc is
      Var_1 : FullViewDefinite_Unknown_Disc;      -- No need for explicit 
                                                  -- constraints, use initial
   begin                                          -- values.
      return Var_1;
   end Indef_Func_1;

   ------------------------------------------------------------------
   function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is
      Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P);
   begin
      return Var_2;
   end Indef_Func_2;

end C330001_0;

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

with C330001_0;
pragma Elaborate(C330001_0); -- Insure that the functions can be called.
private
package C330001_0.C330001_1 is  

   PrivateChild_Obj    : Tag_W_Disc := (D => 4, C1 => "ACVC");

   PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1 
     := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15);

   -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in 
   -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization
   -- expression.

   PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19);

   -- Since full view of FullViewDefinite_Unknown_Disc is definite in the 
   -- parent package, no initialization expression needed for 
   -- PrivateChild_Obj_03.

   PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc;

   PrivateChild_Obj_04 : Indefinite_No_Disc          := (12, 15);

end C330001_0.C330001_1;

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

with C330001_0;
pragma Elaborate(C330001_0); -- Insure that the functions can be called.
package C330001_0.C330001_2 is  

   PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1;

   PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2   := Indef_Func_2 (4);

   PublicChild_Obj_03 : Indefinite_No_Disc            := (38, 72, 21, 59);

   PublicChild_Obj_04 : Indefinite_Tag_W_Disc         := (D => 7, C1 => True);

   PublicChild_Obj_05 : Indefinite_Tag_W_Disc         := PublicChild_Obj_04;

   PublicChild_Obj_06 : Indefinite_New_W_Disc (6);

   procedure Assign_Private_Obj_3;

   function Raised_CE_PublicChild_Obj return Boolean;

   function Raised_CE_PrivateChild_Obj return Boolean;

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

   function Verify_Public_Obj_1 return Boolean;

   function Verify_Public_Obj_2 return Boolean;

   function Verify_Private_Obj_1 return Boolean;

   function Verify_Private_Obj_2 return Boolean;

   function Verify_Private_Obj_3 return Boolean;

end C330001_0.C330001_2;

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

with Report;
with C330001_0.C330001_1;
package body C330001_0.C330001_2 is  

   procedure Assign_Private_Obj_3 is
   begin
      C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha");
   end Assign_Private_Obj_3;

   ------------------------------------------------------------------
   function Raised_CE_PublicChild_Obj return Boolean is
   begin
      PublicChild_Obj_03 := (16, 13);       -- C_E, can't change constraints 
                                            -- of PublicChild_Obj_03.

      Report.Failed ("Constraint_Error not raised - Public child");

      -- Next line prevents dead assignment.

      Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image 
                      (PublicChild_Obj_03'First) );
      return False;

   exception                             
      when Constraint_Error => 
         return True;                       -- Exception is expected.
      when others           => 
         return False;
   end Raised_CE_PublicChild_Obj;

   ------------------------------------------------------------------
   function Raised_CE_PrivateChild_Obj return Boolean is
   begin
      C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18);      
                                            -- C_E, can't change constraints
                                            -- of PrivateChild_Obj_04.

      Report.Failed ("Constraint_Error not raised - Private child");

      -- Next line prevents dead assignment.

      Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image 
                      (C330001_0.C330001_1.PrivateChild_Obj_04'Last) );
      return False;

   exception                             
      when Constraint_Error => 
         return True;                       -- Exception is expected.
      when others           => 
         return False;
   end Raised_CE_PrivateChild_Obj;

   ------------------------------------------------------------------
   function Verify_Public_Obj_1 return Boolean is
   begin
      return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi");

   end Verify_Public_Obj_1;

   ------------------------------------------------------------------
   function Verify_Public_Obj_2 return Boolean is
   begin
      return (PublicChild_Obj_02.D  = 5       and
              PublicChild_Obj_02.C1 = "Hello" and 
              PublicChild_Obj_02.S  = 4);

   end Verify_Public_Obj_2;

   ------------------------------------------------------------------
   function Verify_Private_Obj_1 return Boolean is
   begin
      return (C330001_0.C330001_1.PrivateChild_Obj_01.D  = 4      and
              C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and
              C330001_0.C330001_1.PrivateChild_Obj_01.S  = 15);

   end Verify_Private_Obj_1;

   ------------------------------------------------------------------
   function Verify_Private_Obj_2 return Boolean is
   begin
      return (C330001_0.C330001_1.PrivateChild_Obj_02.D  = 5       and
              C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and
              C330001_0.C330001_1.PrivateChild_Obj_02.S  = 19);

   end Verify_Private_Obj_2;

   ------------------------------------------------------------------
   function Verify_Private_Obj_3 return Boolean is
   begin
      return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and
              C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha");

   end Verify_Private_Obj_3;

end C330001_0.C330001_2;

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

with C330001_0.C330001_2;
with Report;

use  C330001_0.C330001_2;

procedure C330001 is  
begin
   Report.Test ("C330001", "Check that a variable object of an indefinite " &
                "type is properly initialized/constrained by an initial "   &
                "value assignment that is a) an aggregate, b) a function, " &
                "or c) an object.  Check that objects of the above types "  &
                "do not need explicit constraints if they have initial "    &
                "values");

   -- Verify values of public child objects.

   if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then 
      Report.Failed ("Wrong values for PublicChild_Obj_01 or " &
                     "PublicChild_Obj_02");
   end if;
   
   if PublicChild_Obj_03'First /= 1 or
      PublicChild_Obj_03'Last  /= 4 then
      Report.Failed ("Wrong values for PublicChild_Obj_03");
   end if;

   if PublicChild_Obj_05.D  /= 7 or 
      not PublicChild_Obj_05.C1  then
      Report.Failed ("Wrong values for PublicChild_Obj_05");
   end if;

   if PublicChild_Obj_06.ND /= 6 or 
      PublicChild_Obj_06.C2 /= 9 or
      PublicChild_Obj_06.C1      then
      Report.Failed ("Wrong values for PublicChild_Obj_06");
   end if;

   -- Definite object can have its discriminant changed by assignment to
   -- the entire object.

   Assign_Private_Obj_3;

   -- Verify values of private child objects.

   if not Verify_Private_Obj_1 or not 
          Verify_Private_Obj_2 or not 
          Verify_Private_Obj_3 then
      Report.Failed ("Wrong values for PrivateChild_Obj_01 or " &
                     "PrivateChild_Obj_02 or PrivateChild_Obj_03");
   end if;

   -- Attempt to change the discriminants of the objects of the indefinite
   -- subtypes:  Constraint_Error.

   if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then
      Report.Failed ("Constraint_Error not raised");
   end if;

   Report.Result;

end C330001;