-- 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;