cb20003.a

来自「用于进行gcc测试」· A 代码 · 共 287 行

-- CB20003.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 exceptions can be raised, reraised, and handled in an
--      accessed subprogram.
--
--
-- TEST DESCRIPTION:
--      Declare a record type, with one component being an access to
--      subprogram type.  Various subprograms are defined to fit the profile 
--      of this access type, such that the record component can refer to 
--      any of the subprograms.  
--
--      Each of the subprograms raises a different exception, based on the
--      value of an input parameter.  Exceptions are 1) raised, handled with
--      an others handler, reraised and propagated to main to be handled in
--      a specific handler; 2) raised, handled in a specific handler, reraised 
--      and propagated to the main to be handled in an others handler there,
--      and 3) raised and propagated directly to the caller by the subprogram.
--
--      Boolean variables are set throughout the test to ensure that correct
--      exception processing has occurred, and these variables are verified at
--      the conclusion of the test.
--
--       
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

package CB20003_0 is                          -- package Push_Buttons 


   Non_Default_Priority,
   Non_Alert_Priority,
   Non_Emergency_Priority : exception;

   Handled_With_Others,
   Reraised_In_Subprogram,
   Handled_In_Caller      : Boolean := False;

   subtype Priority_Type is Integer range 1 .. 10;

   Default_Priority   : Priority_Type := 1;
   Alert_Priority     : Priority_Type := 3;
   Emergency_Priority : Priority_Type := 5;


   type Button is tagged private;                  -- Private tagged type.

   type Button_Response_Ptr is access procedure (P : in     Priority_Type;
                                                 B : in out Button);


   -- Procedures accessible with Button_Response_Ptr type.

   procedure Default_Response   (P : in     Priority_Type;
                                 B : in out Button);

   procedure Alert_Response     (P : in     Priority_Type;
                                 B : in out Button);

   procedure Emergency_Response (P : in     Priority_Type;
                                 B : in out Button);



   procedure Push (B : in out Button;
                   P : in     Priority_Type);

   procedure Set_Response (B : in out Button;       
                           R : in     Button_Response_Ptr);

private

   type Button is tagged                   
      record
         Priority :  Priority_Type       := Default_Priority;
         Response :  Button_Response_Ptr := Default_Response'Access;   
      end record;


end CB20003_0;                                -- package Push_Buttons


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


with Report;

package body CB20003_0 is                     -- package Push_Buttons 


   procedure Push (B : in out Button;
                   P : in     Priority_Type) is
   begin                                  -- Invoking subprogram designated 
      B.Response (P, B);                  -- by access value.
   end Push;


   procedure Set_Response (B : in out Button;
                           R : in     Button_Response_Ptr) is
   begin
      B.Response := R;      -- Set procedure value in record
   end Set_Response;


   procedure Default_Response (P : in     Priority_Type;
                               B : in out Button) is
   begin
      if (P > Default_Priority) then
         raise Non_Default_Priority;
         Report.Failed ("Exception not raised in procedure body");
      else
         B.Priority := P;
      end if;
   exception
      when others =>                    -- Catch exception with others handler
         Handled_With_Others := True;   -- Successfully caught with "others"
         raise;
         Report.Failed ("Exception not reraised in handler");
   end Default_Response;



   procedure Alert_Response (P : in     Priority_Type;
                             B : in out Button) is
   begin
      if (P > Alert_Priority) then
         raise Non_Alert_Priority;
         Report.Failed ("Exception not raised in procedure body");
      else
         B.Priority := P;
      end if;
   exception
      when Non_Alert_Priority =>
         Reraised_In_Subprogram := True;
         raise;                                  -- Propagate to caller.
         Report.Failed ("Exception not reraised in procedure excpt handler");
      when others =>
         Report.Failed ("Incorrect exception raised/handled");
   end Alert_Response;



   procedure Emergency_Response (P : in     Priority_type;
                                 B : in out Button) is
   begin
      if (P > Emergency_Priority) then
         raise Non_Emergency_Priority;
         Report.Failed ("Exception not raised in procedure body");
      else
         B.Priority := P;
      end if;
      -- No exception handler here, exception will be propagated to caller.
   end Emergency_Response;


end CB20003_0;                                -- package Push_Buttons


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


with Report;
with CB20003_0;                               -- package Push_Buttons

procedure CB20003 is
      
   package Push_Buttons renames CB20003_0;

   Console_Button : Push_Buttons.Button;

begin

   Report.Test ("CB20003", "Check that exceptions can be raised, "  &
                           "reraised, and handled in a subprogram " &
                           "referenced by an access to subprogram value");


   Default_Response_Processing:                 -- The exception
                                                -- Handled_With_Others is to 
                                                -- be caught with an others
                                                -- handler in Default_Resp.,
                                                -- reraised, and handled with
                                                -- a specific handler here.
   begin
   
      Push_Buttons.Push (Console_Button,        -- Raise exception that will
                         Report.Ident_Int(2));  -- be handled in procedure.
   exception
      when Push_Buttons.Non_Default_Priority =>
         if not Push_Buttons.Handled_With_Others then   -- Not reraised in 
                                                        -- procedure.
            Report.Failed 
              ("Exception not handled/reraised in procedure");
         end if;
      when others =>
         Report.Failed ("Exception handled in " &
                        " Default_Response_Processing block");
   end Default_Response_Processing;



   Alert_Response_Processing:
   begin
   
      Push_Buttons.Set_Response (Console_Button,
                                 Push_Buttons.Alert_Response'access);

      Push_Buttons.Push (Console_Button,        -- Raise exception that will
                         Report.Ident_Int(4));  -- be handled in procedure, 
                                                -- reraised, and propagated
                                                -- to caller.
      Report.Failed ("Exception not propagated to caller " &
                     "in Alert_Response_Processing block");

   exception                                    
      when Push_Buttons.Non_Alert_Priority =>
         if not Push_Buttons.Reraised_In_Subprogram then  -- Not reraised in 
                                                          -- procedure.
            Report.Failed ("Exception not reraised in procedure");
         end if;
      when others =>
         Report.Failed ("Exception handled in " &
                        " Alert_Response_Processing block");
   end Alert_Response_Processing;



   Emergency_Response_Processing:
   begin
   
      Push_Buttons.Set_Response (Console_Button,
                                 Push_Buttons.Emergency_Response'access);

      Push_Buttons.Push (Console_Button,        -- Raise exception that will
                         Report.Ident_Int(6));  -- be propagated directly to
                                                -- caller.
      Report.Failed ("Exception not propagated to caller " &
                     "in Emergency_Response_Processing block");

   exception                                   
      when Push_Buttons.Non_Emergency_Priority =>
         Push_Buttons.Handled_In_Caller := True;
      when others =>
         Report.Failed ("Exception handled in " &
                        " Emergency_Response_Processing block");
   end Emergency_Response_Processing;



   if not (Push_Buttons.Handled_With_Others and
           Push_Buttons.Reraised_In_Subprogram and
           Push_Buttons.Handled_In_Caller ) 
   then
      Report.Failed ("Incorrect exception handling in referenced subprograms");
   end if;


   Report.Result;

end CB20003;