path: root/gcc/testsuite/ada/acats/tests/cb/cb40005.a

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