c3a1001.a

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

-- C3A1001.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 full type completing a type with no discriminant part
--      or an unknown discriminant part may have explicitly declared or
--      inherited discriminants.
--      Check for cases where the types are records and protected types.
--
-- TEST DESCRIPTION:
--      Declare two groups of incomplete types: one group with no discriminant 
--      part and one group with unknown discriminant part.  Both groups of 
--      incomplete types are completed with both explicit and inherited 
--      discriminants.  Discriminants for record and protected types are 
--      declared with default and non default values.
--      In the main program, verify that objects of both groups of incomplete 
--      types can be created by default values or by assignments.
--
--
-- CHANGE HISTORY:
--      11 Oct 95   SAIC    Initial prerelease version.
--      11 Nov 96   SAIC    Revised for version 2.1.
--
--!

package C3A1001_0 is

   type Incomplete1 (<>);                          -- unknown discriminant

   type Incomplete2;                               -- no discriminant

   type Incomplete3 (<>);                          -- unknown discriminant

   type Incomplete4;                               -- no discriminant

   type Incomplete5 (<>);                          -- unknown discriminant

   type Incomplete6;                               -- no discriminant

   type Incomplete8;                               -- no discriminant

   subtype Small_Int is Integer range 1 .. 10;

   type Enu_Type is (M, F);

   type Incomplete1 (Disc : Enu_Type) is           -- unknown discriminant/
     record                                        -- explicit discriminant 
        case Disc is
           when M => MInteger : Small_Int := 3;
           when F => FInteger : Small_Int := 8;
        end case;
     end record;

   type Incomplete2 (Disc : Small_Int := 8) is     -- no discriminant/  
     record                                        -- explicit discriminant 
        ID : String (1 .. Disc) := "Plymouth";
     end record;

   type Incomplete3 is new Incomplete2;            -- unknown discriminant/
                                                   -- inherited discriminant

   type Incomplete4 is new Incomplete2;            -- no discriminant/  
                                                   -- inherited discriminant   
                                                   
   protected type Incomplete5                      -- unknown discriminant/
     (Disc : Enu_Type) is                          -- explicit discriminant
        function Get_Priv_Val return Enu_Type;     
   private
      Enu_Obj : Enu_Type := Disc;
   end Incomplete5;    

   protected type Incomplete6                      -- no discriminant/  
     (Disc : Small_Int := 1) is                    -- explicit discriminant
        function Get_Priv_Val return Small_Int;    -- with default
   private
      Num : Small_Int := Disc;
   end Incomplete6;

   type Incomplete8 (Disc : Small_Int) is          -- no discriminant/  
     record                                        -- explicit discriminant
       Str : String (1 .. Disc);                   -- no default
     end record;

   type Incomplete9 is new Incomplete8;

   function Return_String (S : String) return String;

end C3A1001_0;

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

with Report;

package body C3A1001_0 is

   protected body Incomplete5 is    

      function Get_Priv_Val return Enu_Type is
      begin
         return Enu_Obj;
      end Get_Priv_Val; 

    end Incomplete5; 

   ----------------------------------------------------------------------
   protected body Incomplete6 is                                             
            
      function Get_Priv_Val return Small_Int is
      begin
         return Num;
      end Get_Priv_Val; 

    end Incomplete6; 

   ----------------------------------------------------------------------
   function Return_String (S : String) return String is
   begin
      if Report.Ident_Bool(True) = True then
         return S;
      end if;

      return S;
   end Return_String;
   
end C3A1001_0;

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

with Report;

with C3A1001_0;
use  C3A1001_0;

procedure C3A1001 is

   -- Discriminant value comes from default.

   Incomplete2_Obj_1 :  Incomplete2;                

   Incomplete4_Obj_1 :  Incomplete4;

   Incomplete6_Obj_1 :  Incomplete6;                

   -- Discriminant value comes from explicit constraint.

   Incomplete1_Obj_1 :  Incomplete1 (F);              

   Incomplete5_Obj_1 :  Incomplete5 (M);               

   Incomplete6_Obj_2 :  Incomplete6 (2);           

   -- Discriminant value comes from assignment.        

   Incomplete3_Obj_1 :  Incomplete3 := (Disc => 6, ID => "Sentra");       

   Incomplete1_Obj_2 :  Incomplete1 := (Disc => M, MInteger => 9);    
                                  
   Incomplete2_Obj_2 :  Incomplete2 := (Disc => 5, ID => "Buick");    
                                  
begin

   Report.Test ("C3A1001", "Check that the full type completing a type " &
                "with no discriminant part or an unknown discriminant "  &
                "part may have explicitly declared or inherited "        &
                "discriminants.  Check for cases where the types are "   &
                "records and protected types");

   -- Check the initial values.

   if (Incomplete2_Obj_1.Disc /= 8) or
      (Incomplete2_Obj_1.ID   /= "Plymouth") then
         Report.Failed ("Wrong initial values for Incomplete2_Obj_1");
   end if;

   if (Incomplete4_Obj_1.Disc /= 8) or
      (Incomplete4_Obj_1.ID   /= "Plymouth") then
         Report.Failed ("Wrong initial values for Incomplete4_Obj_1");
   end if;

   if (Incomplete6_Obj_1.Disc         /= 1) or
      (Incomplete6_Obj_1.Get_Priv_Val /= 1) then
         Report.Failed ("Wrong initial value for Incomplete6_Obj_1");
   end if;

   -- Check the explicit values.

   if (Incomplete1_Obj_1.Disc     /= F) or 
      (Incomplete1_Obj_1.FInteger /= 8) then
         Report.Failed ("Wrong values for Incomplete1_Obj_1");
   end if;

   if (Incomplete5_Obj_1.Disc         /= M) or  
      (Incomplete5_Obj_1.Get_Priv_Val /= M) then
         Report.Failed ("Wrong value for Incomplete5_Obj_1");
   end if;

   if (Incomplete6_Obj_2.Disc         /= 2) or
      (Incomplete6_Obj_2.Get_Priv_Val /= 2) then
         Report.Failed ("Wrong value for Incomplete6_Obj_2");
   end if;

   -- Check the assigned values.

   if (Incomplete3_Obj_1.Disc /= 6) or 
      (Incomplete3_Obj_1.ID   /= "Sentra") then
         Report.Failed ("Wrong values for Incomplete3_Obj_1");
   end if;

   if (Incomplete1_Obj_2.Disc     /= M) or
      (Incomplete1_Obj_2.MInteger /= 9) then
         Report.Failed ("Wrong values for Incomplete1_Obj_2");
   end if;

   if (Incomplete2_Obj_2.Disc /= 5) or 
      (Incomplete2_Obj_2.ID   /= "Buick") then
         Report.Failed ("Wrong values for Incomplete2_Obj_2");
   end if;

   -- Make sure that assignments work without problems.

   Incomplete1_Obj_1.FInteger := 1;

   -- Avoid optimization (dead variable removal of FInteger):

   if Incomplete1_Obj_1.FInteger /= Report.Ident_Int(1) 
      then  
         Report.Failed ("Wrong value stored in Incomplete1_Obj_1.FInteger");
   end if;

   Incomplete2_Obj_1.ID       := Return_String ("12345678");

   -- Avoid optimization (dead variable removal of ID)

   if Incomplete2_Obj_1.ID /= Return_String ("12345678")
     then   
        Report.Failed ("Wrong values for Incomplete8_Obj_1.ID");
   end if;

   Incomplete4_Obj_1.ID       := Return_String ("87654321");

   -- Avoid optimization (dead variable removal of ID)

   if Incomplete4_Obj_1.ID /= Return_String ("87654321")
     then   
        Report.Failed ("Wrong values for Incomplete4_Obj_1.ID");
   end if;


   Test1:
   declare
   
      Incomplete8_Obj_1 :  Incomplete8 (10);

   begin
      Incomplete8_Obj_1.Str := "Merry Xmas";

      -- Avoid optimization (dead variable removal of Str):

      if Return_String (Incomplete8_Obj_1.Str) /= "Merry Xmas"
        then   
           Report.Failed ("Wrong values for Incomplete8_Obj_1.Str");
      end if;

   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised in Incomplete8_Obj_1");

   end Test1;

   Test2:
   declare

      Incomplete8_Obj_2 :  Incomplete8 (5);

   begin
      Incomplete8_Obj_2.Str := "Happy";       

      -- Avoid optimization (dead variable removal of Str):

      if Return_String (Incomplete8_Obj_2.Str) /= "Happy"               
        then   
           Report.Failed ("Wrong values for Incomplete8_Obj_1.Str");
      end if;

   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised in Incomplete8_Obj_2");

   end Test2;

   Report.Result;

end C3A1001;