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