c371001.a

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

-- C371001.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 if a discriminant constraint depends on a discriminant,
--      the evaluation of the expressions in the constraint is deferred 
--      until an object of the subtype is created.  Check for cases of 
--      records with private type component.
--
-- TEST DESCRIPTION:
--      This transition test defines record type and incomplete types with 
--      discriminant components which depend on the discriminants.  The 
--      discriminants are calculated by function calls.  The test verifies
--      that Constraint_Error is raised during the object creations when 
--      values of discriminants are incompatible with the subtypes.
--
--      Inspired by C37214A.ADA and C37216A.ADA.
--
--
-- CHANGE HISTORY:
--      11 Apr 96   SAIC    Initial version for ACVC 2.1.
--      06 Oct 96   SAIC    Added LM references. Replaced "others exception"
--                          with "unexpected exception"                     
--
--!

with Report; 

procedure C371001 is

   subtype Small_Int is Integer range 1..10;

   Func1_Cons : Integer := 0;

   ---------------------------------------------------------
   function Func1 return Integer is
   begin
      Func1_Cons := Func1_Cons + Report.Ident_Int(1);
      return Func1_Cons;
   end Func1;


begin
   Report.Test ("C371001", "Check that if a discriminant constraint " &
                "depends on a discriminant, the evaluation of the "   &
                "expressions in the constraint is deferred until "    &
                "object declarations");

   ---------------------------------------------------------
   -- Constraint checks on an object declaration of a record.

   begin

      declare

         package C371001_0 is

            type PT_W_Disc (D : Small_Int) is private;
            type Rec_W_Private (D1 : Integer) is
              record
                 C : PT_W_Disc (D1);
              end record;
   
            type Rec (D3 : Integer) is
              record
                 C1 : Rec_W_Private (D3);
              end record;

         private
            type PT_W_Disc (D : Small_Int) is 
              record
                 Str : String (1 .. D) := (others => '*');
              end record;

         end C371001_0;                         

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

         Obj : C371001_0.Rec(Report.Ident_Int(0));  -- Constraint_Error raised.

      begin
         Report.Failed ("Obj - Constraint_Error should be raised");
         if Obj.C1.D1 /= 0 then
            Report.Failed ("Obj - Shouldn't get here");
         end if;

      exception
         when others           => 
              Report.Failed ("Obj - exception raised too late");
      end;

   exception                      
      when Constraint_Error =>                      -- Exception expected.
           null;
      when others           => 
           Report.Failed ("Obj - unexpected exception raised");
   end;

   -------------------------------------------------------------------
   -- Constraint checks on an object declaration of an array.

   begin
      declare

         package C371001_1 is

            type PT_W_Disc (D : Small_Int) is private;
            type Rec_W_Private (D1 : Integer) is
              record
                 C : PT_W_Disc (D1);
              end record;

            type Rec_01 (D3 : Integer) is
              record
                 C1 : Rec_W_Private (D3);
              end record;

            type Arr is array (1 .. 5) of 
              Rec_01(Report.Ident_Int(0));          -- No Constraint_Error 
                                                    -- raised. 
         private
            type PT_W_Disc (D : Small_Int) is 
              record
                 Str : String (1 .. D) := (others => '*');
              end record;

         end C371001_1;                         

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

      begin
         declare
            Obj1 : C371001_1.Arr;                   -- Constraint_Error raised.
         begin
            Report.Failed ("Obj1 - Constraint_Error should be raised");
            if Obj1(1).D3 /= 0 then
               Report.Failed ("Obj1 - Shouldn't get here");
            end if;

         exception
            when others           => 
                 Report.Failed ("Obj1 - exception raised too late");
         end;

      exception
         when Constraint_Error =>                   -- Exception expected.
              null;
         when others =>
              Report.Failed ("Obj1 - unexpected exception raised");
      end;

   exception
      when Constraint_Error =>
           Report.Failed ("Arr - Constraint_Error raised");
      when others =>
           Report.Failed ("Arr - unexpected exception raised");
   end;


   -------------------------------------------------------------------
   -- Constraint checks on an object declaration of an access type.

   begin
      declare

         package C371001_2 is

            type PT_W_Disc (D : Small_Int) is private;
            type Rec_W_Private (D1 : Integer) is
              record
                 C : PT_W_Disc (D1);
              end record;
   
            type Rec_02 (D3 : Integer) is
              record
                 C1 : Rec_W_Private (D3);
              end record;

            type Acc_Rec2 is access Rec_02          -- No Constraint_Error 
              (Report.Ident_Int(11));               -- raised. 

         private
            type PT_W_Disc (D : Small_Int) is 
              record
                 Str : String (1 .. D) := (others => '*');
              end record;

         end C371001_2;                         

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

      begin
         declare
            Obj2 : C371001_2.Acc_Rec2;              -- No Constraint_Error 
                                                    -- raised.
         begin
            Obj2 := new C371001_2.Rec_02 (Report.Ident_Int(11));       
                                                    -- Constraint_Error raised.

            Report.Failed ("Obj2 - Constraint_Error should be raised");
            if Obj2.D3 /= 1 then
               Report.Failed ("Obj2 - Shouldn't get here");
            end if;

         exception
            when Constraint_Error =>                -- Exception expected.
               null;
            when others           => 
               Report.Failed ("Obj2 - unexpected exception raised in " &
                              "assignment");
         end;

      exception
         when Constraint_Error =>  
              Report.Failed ("Obj2 - Constraint_Error raised in declaration");
         when others =>
              Report.Failed ("Obj2 - unexpected exception raised in " &
                             "declaration");
      end;

   exception
      when Constraint_Error =>  
           Report.Failed ("Acc_Rec2 - Constraint_Error raised");
      when others =>
           Report.Failed ("Acc_Rec2 - unexpected exception raised");
   end;

   -------------------------------------------------------------------
   -- Constraint checks on an object declaration of a subtype.

   Func1_Cons := -1;

   begin
      declare

         package C371001_3 is

            type PT_W_Disc (D1, D2 : Small_Int) is private;
            type Rec_W_Private (D3, D4 : Integer) is
              record
                 C : PT_W_Disc (D3, D4);
              end record;
   
            type Rec_03 (D5 : Integer) is
              record
                 C1 : Rec_W_Private (D5, Func1);     -- Func1 evaluated,
              end record;                            -- value 0.

            subtype Subtype_Rec is Rec_03(1);        -- No Constraint_Error 
                                                     -- raised. 
         private
            type PT_W_Disc (D1, D2 : Small_Int) is 
              record
                 Str1 : String (1 .. D1) := (others => '*');
                 Str2 : String (1 .. D2) := (others => '*');
              end record;

         end C371001_3;                         

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

      begin
         declare
            Obj3 : C371001_3.Subtype_Rec;            -- Constraint_Error raised.
         begin
            Report.Failed ("Obj3 - Constraint_Error should be raised");
            if Obj3.D5 /= 1 then
               Report.Failed ("Obj3 - Shouldn't get here");
            end if;

         exception
            when others           => 
                 Report.Failed ("Obj3 - exception raised too late");
         end;

      exception
         when Constraint_Error =>                    -- Exception expected.
              null;
         when others =>
              Report.Failed ("Obj3 - unexpected exception raised");
      end;

   exception
      when Constraint_Error =>
           Report.Failed ("Subtype_Rec - Constraint_Error raised");
      when others =>
           Report.Failed ("Subtype_Rec - unexpected exception raised");
   end;

   -------------------------------------------------------------------
   -- Constraint checks on an object declaration of an incomplete type.

   Func1_Cons := 10;

   begin
      declare

         package C371001_4 is

            type Rec_04 (D3 : Integer);
            type PT_W_Disc (D : Small_Int) is private;
            type Rec_W_Private (D1, D2 : Small_Int) is
              record
                 C : PT_W_Disc (D2);
              end record;

            type Rec_04 (D3 : Integer) is
              record
                 C1 : Rec_W_Private (D3, Func1);     -- Func1 evaluated
              end record;                            -- value 11.

            type Acc_Rec4 is access Rec_04 (1);      -- No Constraint_Error 
                                                     -- raised. 
         private
            type PT_W_Disc (D : Small_Int) is 
              record
                 Str : String (1 .. D) := (others => '*');
              end record;

         end C371001_4;                         

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

      begin
         declare
            Obj4 : C371001_4.Acc_Rec4;               -- No Constraint_Error 
                                                     -- raised.
         begin
            Obj4 := new C371001_4.Rec_04 (1);        -- Constraint_Error raised.

            Report.Failed ("Obj4 - Constraint_Error should be raised");
            if Obj4.D3 /= 1 then
               Report.Failed ("Obj4 - Shouldn't get here");
            end if;

         exception
            when Constraint_Error =>                 -- Exception expected.
               null;
            when others           => 
               Report.Failed ("Obj4 - unexpected exception raised in " &
                              "assignment");
         end;

      exception
         when Constraint_Error =>  
              Report.Failed ("Obj4 - Constraint_Error raised in declaration");
         when others =>
              Report.Failed ("Obj4 - unexpected exception raised in " &
                             "declaration");
      end;

   exception
      when Constraint_Error =>  
           Report.Failed ("Acc_Rec4 - Constraint_Error raised");
      when others =>
           Report.Failed ("Acc_Rec4 - unexpected exception raised");
   end;

   Report.Result;

exception
   when others =>
        Report.Failed ("Discriminant value checked too soon");
        Report.Result;

end C371001;