c3a1002.a

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

-- C3A1002.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 tagged records and task 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 task types are declared with both 
--      default and non default values.  Discriminants for tagged types are 
--      only declared without 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:
--      23 Oct 95   SAIC    Initial prerelease version.
--      19 Oct 96   SAIC    ACVC 2.1: modified test description.  Initialized
--                          Int_Val.
--
--!

package C3A1002_0 is

   subtype Small_Int is Integer range 1 .. 15;

   type Enu_Type is (M, F);

   type Tag_Type is tagged         
     record                                          
        I : Small_Int := 1;
     end record;

   type NTag_Type (D : Small_Int) is new Tag_Type with
     record                                          
        S : String (1 .. D) := "Aloha";  
     end record;

   type Incomplete1;                               -- no discriminant

   type Incomplete2 (<>);                          -- unknown discriminant

   type Incomplete3;                               -- no discriminant

   type Incomplete4 (<>);                          -- unknown discriminant

   type Incomplete5;                               -- no discriminant

   type Incomplete6 (<>);                          -- unknown discriminant

   type Incomplete1 (D1 : Enu_Type) is tagged      -- no discriminant/  
     record                                        -- explicit discriminant
        case D1 is
           when M => MInteger : Small_Int := 9;
           when F => FInteger : Small_Int := 8;
        end case;
     end record;

   type Incomplete2 (D2 : Small_Int) is new       -- unknown discriminant/
     Incomplete1 (D1 => F) with record            -- explicit discriminant
        ID : String (1 .. D2) := "ACVC95";
     end record;

   type Incomplete3 is new                         -- no discriminant/
     NTag_Type with record                         -- inherited discriminant
        E : Enu_Type := M;
     end record;

   type Incomplete4 is new                         -- unknown discriminant/
     NTag_Type (D => 3) with record                -- inherited discriminant
        E : Enu_Type := F;
     end record;

   task type Incomplete5 (D5 : Enu_Type) is      -- no discriminant/
      entry Read_Disc (P : out Enu_Type);        -- explicit discriminant
   end Incomplete5;

   task type Incomplete6 
     (D6 : Small_Int := 4) is                    -- unknown discriminant/
      entry Read_Int (P : out Small_Int);        -- explicit discriminant
   end Incomplete6;

end C3A1002_0;

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

package body C3A1002_0 is

   task body Incomplete5 is  
   begin
      select 
         accept Read_Disc (P : out Enu_Type) do  
            P := D5;
         end Read_Disc;
      or
         terminate;
      end select;

   end Incomplete5;

   ----------------------------------------------------------------------
   task body Incomplete6 is 
   begin
      select 
         accept Read_Int (P : out Small_Int) do  
            P := D6;
         end Read_Int;
      or
         terminate;
      end select;

   end Incomplete6;

end C3A1002_0;

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

with Report;

with C3A1002_0;
use  C3A1002_0;

procedure C3A1002 is

   Enum_Val : Enu_Type := M;

   Int_Val  : Small_Int := 15;

   -- Discriminant value comes from default.

   Incomplete6_Obj_1  :  Incomplete6;

   -- Discriminant value comes from explicit constraint.

   Incomplete1_Obj_1  :  Incomplete1 (M);

   Incomplete2_Obj_1  :  Incomplete2 (6);

   Incomplete5_Obj_1  :  Incomplete5 (F);

   Incomplete6_Obj_2  :  Incomplete6 (7);

   -- Discriminant value comes from assignment.        

   Incomplete1_Obj_2  :  Incomplete1
                      := (F, 12);

   Incomplete3_Obj_1  :  Incomplete3
                      := (D => 2, S => "Hi", I => 10, E => F);

   Incomplete4_Obj_1  :  Incomplete4
                      := (E => M, D => 3, S => "Bye", I => 14);

begin

   Report.Test ("C3A1002", "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 "   &
                "tagged records and task types");

   -- Check the initial values.

   if (Incomplete6_Obj_1.D6 /= 4) then 
      Report.Failed ("Wrong initial value for Incomplete6_Obj_1");
   end if;

   -- Check the explicit values.

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

   if (Incomplete2_Obj_1.D2       /= 6) or 
      (Incomplete2_Obj_1.FInteger /= 8) or
      (Incomplete2_Obj_1.ID       /= "ACVC95") then
         Report.Failed ("Wrong values for Incomplete2_Obj_1");
   end if;

   if (Incomplete5_Obj_1.D5 /= F) then 
      Report.Failed ("Wrong value for Incomplete5_Obj_1");
   end if;

   Incomplete5_Obj_1.Read_Disc (Enum_Val);

   if (Enum_Val /= F) then 
      Report.Failed ("Wrong value for Enum_Val");
   end if;

   if (Incomplete6_Obj_2.D6 /= 7) then 
      Report.Failed ("Wrong value for Incomplete6_Obj_2");
   end if;

   Incomplete6_Obj_1.Read_Int (Int_Val);

   if (Int_Val /= 4) then 
      Report.Failed ("Wrong value for Int_Val");
   end if;

   -- Check the assigned values.

   if (Incomplete1_Obj_2.D1       /= F)  or 
      (Incomplete1_Obj_2.FInteger /= 12) then
         Report.Failed ("Wrong values for Incomplete1_Obj_2");
   end if;

   if (Incomplete3_Obj_1.D /= 2 ) or 
      (Incomplete3_Obj_1.I /= 10) or
      (Incomplete3_Obj_1.E /= F ) or
      (Incomplete3_Obj_1.S /= "Hi") then
         Report.Failed ("Wrong values for Incomplete3_Obj_1");
   end if;

   if (Incomplete4_Obj_1.E /= M )      or 
      (Incomplete4_Obj_1.D /= 3)       or
      (Incomplete4_Obj_1.S /= "Bye")   or
      (Incomplete4_Obj_1.I /= 14)      then
         Report.Failed ("Wrong values for Incomplete4_Obj_1");
   end if;

   Report.Result;

end C3A1002;