diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cb/cb20003.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb20003.a | 286 |
1 files changed, 0 insertions, 286 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20003.a b/gcc/testsuite/ada/acats/tests/cb/cb20003.a deleted file mode 100644 index daaf9ffe5c5..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb20003.a +++ /dev/null @@ -1,286 +0,0 @@ --- 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; |