Subversion Repositories openrisc_me

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