diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cb/cb40005.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb40005.a | 339 |
1 files changed, 0 insertions, 339 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40005.a b/gcc/testsuite/ada/acats/tests/cb/cb40005.a deleted file mode 100644 index 681ec18ff28..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb40005.a +++ /dev/null @@ -1,339 +0,0 @@ --- CB40005.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 raised in non-generic code can be handled by --- a procedure in a generic package. Check that the exception identity --- can be properly retrieved from the generic code and used by the --- non-generic code. --- --- TEST DESCRIPTION: --- This test models a possible usage paradigm for the type: --- Ada.Exceptions.Exception_Occurrence. --- --- A generic package takes access to procedure types (allowing it to --- be used at any accessibility level) and defines a "fail soft" --- procedure that takes designators to a procedure to call, a --- procedure to call in the event that it fails, and a function to --- call to determine the next action. --- --- In the event an exception occurs on the call to the first procedure, --- the exception is stored in a stack; along with the designator to the --- procedure that caused it; allowing the procedure to be called again, --- or the exception to be re-raised. --- --- A full implementation of such a tool would use a more robust storage --- mechanism, and would provide a more flexible interface. --- --- --- CHANGE HISTORY: --- 29 MAR 96 SAIC Initial version --- 12 NOV 96 SAIC Revised for 2.1 release --- ---! - ------------------------------------------------------------------ CB40005_0 - -with Ada.Exceptions; -generic - type Proc_Pointer is access procedure; - type Func_Pointer is access function return Proc_Pointer; -package CB40005_0 is -- Fail_Soft - - - procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer; - Proc_To_Call_On_Exception : Proc_Pointer := null; - Retry_Routine : Func_Pointer := null ); - - function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence; - - function Top_Event_Procedure return Proc_Pointer; - - procedure Pop_Event; - - function Event_Stack_Size return Natural; - -end CB40005_0; -- Fail_Soft - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CB40005_0 - -with Report; -package body CB40005_0 is - - type History_Event is record - Exception_Event : Ada.Exceptions.Exception_Occurrence_Access; - Procedure_Called : Proc_Pointer; - end record; - - procedure Store_Event( Proc_Called : Proc_Pointer; - Error : Ada.Exceptions.Exception_Occurrence ); - - procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer; - Proc_To_Call_On_Exception : Proc_Pointer := null; - Retry_Routine : Func_Pointer := null ) is - - Current_Proc_To_Call : Proc_Pointer := Proc_To_Call; - - begin - while Current_Proc_To_Call /= null loop - begin - Current_Proc_To_Call.all; -- call procedure through pointer - Current_Proc_To_Call := null; - exception - when Capture: others => - Store_Event( Current_Proc_To_Call, Capture ); - if Proc_To_Call_On_Exception /= null then - Proc_To_Call_On_Exception.all; - end if; - if Retry_Routine /= null then - Current_Proc_To_Call := Retry_Routine.all; - else - Current_Proc_To_Call := null; - end if; - end; - end loop; - end Fail_Soft_Call; - - Stack : array(1..10) of History_Event; -- minimal, sufficient for testing - - Stack_Top : Natural := 0; - - procedure Store_Event( Proc_Called : Proc_Pointer; - Error : Ada.Exceptions.Exception_Occurrence ) - is - begin - Stack_Top := Stack_Top +1; - Stack(Stack_Top) := ( Ada.Exceptions.Save_Occurrence(Error), - Proc_Called ); - end Store_Event; - - function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence is - begin - if Stack_Top > 0 then - return Stack(Stack_Top).Exception_Event.all; - else - return Ada.Exceptions.Null_Occurrence; - end if; - end Top_Event_Exception; - - function Top_Event_Procedure return Proc_Pointer is - begin - if Stack_Top > 0 then - return Stack(Stack_Top).Procedure_Called; - else - return null; - end if; - end Top_Event_Procedure; - - procedure Pop_Event is - begin - if Stack_Top > 0 then - Stack_Top := Stack_Top -1; - else - Report.Failed("Stack Error"); - end if; - end Pop_Event; - - function Event_Stack_Size return Natural is - begin - return Stack_Top; - end Event_Stack_Size; - -end CB40005_0; - -------------------------------------------------------------------- CB40005 - -with Report; -with TCTouch; -with CB40005_0; -with Ada.Exceptions; -procedure CB40005 is - - type Proc_Pointer is access procedure; - type Func_Pointer is access function return Proc_Pointer; - - package Fail_Soft is new CB40005_0(Proc_Pointer, Func_Pointer); - - procedure Cause_Standard_Exception; - - procedure Cause_Visible_Exception; - - procedure Cause_Invisible_Exception; - - Exception_Procedure_Pointer : Proc_Pointer; - - Visible_Exception : exception; - - procedure Action_On_Exception; - - function Retry_Procedure return Proc_Pointer; - - Raise_Error : Boolean; - - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - procedure Cause_Standard_Exception is - begin - TCTouch.Touch('S'); --------------------------------------------------- S - if Raise_Error then - raise Constraint_Error; - end if; - end Cause_Standard_Exception; - - procedure Cause_Visible_Exception is - begin - TCTouch.Touch('V'); --------------------------------------------------- V - if Raise_Error then - raise Visible_Exception; - end if; - end Cause_Visible_Exception; - - procedure Cause_Invisible_Exception is - Invisible_Exception : exception; - begin - TCTouch.Touch('I'); --------------------------------------------------- I - if Raise_Error then - raise Invisible_Exception; - end if; - end Cause_Invisible_Exception; - - procedure Action_On_Exception is - begin - TCTouch.Touch('A'); --------------------------------------------------- A - end Action_On_Exception; - - function Retry_Procedure return Proc_Pointer is - begin - TCTouch.Touch('R'); --------------------------------------------------- R - return Action_On_Exception'Access; - end Retry_Procedure; - - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -begin -- Main test procedure. - - Report.Test ("CB40005", "Check that exceptions raised in non-generic " & - "code can be handled by a procedure in a generic " & - "package. Check that the exception identity can " & - "be properly retrieved from the generic code and " & - "used by the non-generic code" ); - - -- first, check that the no exception cases cause no action on the stack - Raise_Error := False; - - Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S - - Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V - Action_On_Exception'Access, - Retry_Procedure'Access ); - - Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I - null, - Retry_Procedure'Access ); - - TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Empty stack"); - - TCTouch.Validate( "SVI", "Non error case check" ); - - -- second, check that error cases add to the stack - Raise_Error := True; - - Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S - - Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V - Action_On_Exception'Access, -- A - Retry_Procedure'Access ); -- RA - - Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I - null, - Retry_Procedure'Access ); -- RA - - TCTouch.Assert( Fail_Soft.Event_Stack_Size = 3, "Stack = 3"); - - TCTouch.Validate( "SVARAIRA", "Error case check" ); - - -- check that the exceptions and procedure were stored correctly - -- on the stack - Raise_Error := False; - - -- return procedure pointer from top of stack and call the procedure - -- through that pointer: - - Fail_Soft.Top_Event_Procedure.all; - - TCTouch.Validate( "I", "Invisible case unwind" ); - - begin - Ada.Exceptions.Raise_Exception( - Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); - Report.Failed("1: Exception not raised"); - exception - when Constraint_Error => Report.Failed("1: Raised Constraint_Error"); - when Visible_Exception => Report.Failed("1: Raised Visible_Exception"); - when others => null; -- expected case - end; - - Fail_Soft.Pop_Event; - - -- return procedure pointer from top of stack and call the procedure - -- through that pointer: - - Fail_Soft.Top_Event_Procedure.all; - - TCTouch.Validate( "V", "Visible case unwind" ); - - begin - Ada.Exceptions.Raise_Exception( - Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); - Report.Failed("2: Exception not raised"); - exception - when Constraint_Error => Report.Failed("2: Raised Constraint_Error"); - when Visible_Exception => null; -- expected case - when others => Report.Failed("2: Raised Invisible_Exception"); - end; - - Fail_Soft.Pop_Event; - - Fail_Soft.Top_Event_Procedure.all; - - TCTouch.Validate( "S", "Standard case unwind" ); - - begin - Ada.Exceptions.Raise_Exception( - Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); - Report.Failed("3: Exception not raised"); - exception - when Constraint_Error => null; -- expected case - when Visible_Exception => Report.Failed("3: Raised Visible_Exception"); - when others => Report.Failed("3: Raised Invisible_Exception"); - end; - - Fail_Soft.Pop_Event; - - TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Stack empty after pops"); - - Report.Result; - -end CB40005; |