Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--  A D A . E X C E P T I O N S . E X C E P T I O N _ P R O P A G A T I O N --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  This is the version using the GCC EH mechanism

with Ada.Unchecked_Conversion;

with Ada.Unchecked_Deallocation;

with System.Storage_Elements;  use System.Storage_Elements;

separate (Ada.Exceptions)

package body Exception_Propagation is

   ------------------------------------------------

   -- Entities to interface with the GCC runtime --

   ------------------------------------------------

   --  These come from "C++ ABI for Itanium: Exception handling", which is

   --  the reference for GCC. They are used only when we are relying on

   --  back-end tables for exception propagation, which in turn is currently

   --  only the case for Zero_Cost_Exceptions in GNAT5.

   --  Return codes from the GCC runtime functions used to propagate

   --  an exception.

   type Unwind_Reason_Code is

     (URC_NO_REASON,

      URC_FOREIGN_EXCEPTION_CAUGHT,

      URC_PHASE2_ERROR,

      URC_PHASE1_ERROR,

      URC_NORMAL_STOP,

      URC_END_OF_STACK,

      URC_HANDLER_FOUND,

      URC_INSTALL_CONTEXT,

      URC_CONTINUE_UNWIND);

   pragma Unreferenced

     (URC_FOREIGN_EXCEPTION_CAUGHT,

      URC_PHASE2_ERROR,

      URC_PHASE1_ERROR,

      URC_NORMAL_STOP,

      URC_END_OF_STACK,

      URC_HANDLER_FOUND,

      URC_INSTALL_CONTEXT,

      URC_CONTINUE_UNWIND);

   pragma Convention (C, Unwind_Reason_Code);

   --  Phase identifiers

   type Unwind_Action is

     (UA_SEARCH_PHASE,

      UA_CLEANUP_PHASE,

      UA_HANDLER_FRAME,

      UA_FORCE_UNWIND);

   for Unwind_Action use

      (UA_SEARCH_PHASE  => 1,

       UA_CLEANUP_PHASE => 2,

       UA_HANDLER_FRAME => 4,

       UA_FORCE_UNWIND  => 8);

   pragma Convention (C, Unwind_Action);

   --  Mandatory common header for any exception object handled by the

   --  GCC unwinding runtime.

   type Exception_Class is mod 2 ** 64;

   GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;

   --  "GNU-Ada\0"

   type Unwind_Word is mod 2 ** System.Word_Size;

   for Unwind_Word'Size use System.Word_Size;

   --  Map the corresponding C type used in Unwind_Exception below

   type Unwind_Exception is record

      Class    : Exception_Class := GNAT_Exception_Class;

      Cleanup  : System.Address  := System.Null_Address;

      Private1 : Unwind_Word;

      Private2 : Unwind_Word;

   end record;

   --  Map the GCC struct used for exception handling

   for Unwind_Exception'Alignment use Standard'Maximum_Alignment;

   --  The C++ ABI mandates the common exception header to be at least

   --  doubleword aligned, and the libGCC implementation actually makes it

   --  maximally aligned (see unwind.h). See additional comments on the

   --  alignment below.

   --------------------------------------------------------------

   -- GNAT Specific Entities To Deal With The GCC EH Circuitry --

   --------------------------------------------------------------

   --  A GNAT exception object to be dealt with by the personality routine

   --  called by the GCC unwinding runtime.

   type GNAT_GCC_Exception is record

      Header : Unwind_Exception;

      --  ABI Exception header first

      Id : Exception_Id;

      --  GNAT Exception identifier.  This is filled by Propagate_Exception

      --  and then used by the personality routine to determine if the context

      --  it examines contains a handler for the exception being propagated.

      N_Cleanups_To_Trigger : Integer;

      --  Number of cleanup only frames encountered in SEARCH phase.  This is

      --  initialized to 0 by Propagate_Exception and maintained by the

      --  personality routine to control a forced unwinding phase triggering

      --  all the cleanups before calling Unhandled_Exception_Terminate when

      --  an exception is not handled.

      Next_Exception : EOA;

      --  Used to create a linked list of exception occurrences

   end record;

   pragma Convention (C, GNAT_GCC_Exception);

   --  There is a subtle issue with the common header alignment, since the C

   --  version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on

   --  Standard'Maximum_Alignment, and those two values don't quite represent

   --  the same concepts and so may be decoupled someday. One typical reason

   --  is that BIGGEST_ALIGNMENT may be larger than what the underlying system

   --  allocator guarantees, and there are extra costs involved in allocating

   --  objects aligned to such factors.

   --  To deal with the potential alignment differences between the C and Ada

   --  representations, the Ada part of the whole structure is only accessed

   --  by the personality routine through the accessors declared below.  Ada

   --  specific fields are thus always accessed through consistent layout, and

   --  we expect the actual alignment to always be large enough to avoid traps

   --  from the C accesses to the common header. Besides, accessors alleviate

   --  the need for a C struct whole counterpart, both painful and error-prone

   --  to maintain anyway.

   type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;

   function To_GNAT_GCC_Exception is new

     Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access);

   procedure Free is new Unchecked_Deallocation

     (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);

   procedure Free is new Unchecked_Deallocation

     (Exception_Occurrence, EOA);

   function CleanupUnwind_Handler

     (UW_Version   : Integer;

      UW_Phases    : Unwind_Action;

      UW_Eclass    : Exception_Class;

      UW_Exception : not null access GNAT_GCC_Exception;

      UW_Context   : System.Address;

      UW_Argument  : System.Address) return Unwind_Reason_Code;

   --  Hook called at each step of the forced unwinding we perform to

   --  trigger cleanups found during the propagation of an unhandled

   --  exception.

   --  GCC runtime functions used. These are C non-void functions, actually,

   --  but we ignore the return values. See raise.c as to why we are using

   --  __gnat stubs for these.

   procedure Unwind_RaiseException

     (UW_Exception : not null access GNAT_GCC_Exception);

   pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");

   procedure Unwind_ForcedUnwind

     (UW_Exception : not null access GNAT_GCC_Exception;

      UW_Handler   : System.Address;

      UW_Argument  : System.Address);

   pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");

   ------------------------------------------------------------------

   -- Occurrence Stack Management Facilities for the GCC-EH Scheme --

   ------------------------------------------------------------------

   function Remove

     (Top   : EOA;

      Excep : GNAT_GCC_Exception_Access) return Boolean;

   --  Remove Excep from the stack starting at Top.

   --  Return True if Excep was found and removed, false otherwise.

   --  Hooks called when entering/leaving an exception handler for a given

   --  occurrence, aimed at handling the stack of active occurrences. The

   --  calls are generated by gigi in tree_transform/N_Exception_Handler.

   procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);

   pragma Export (C, Begin_Handler, "__gnat_begin_handler");

   procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);

   pragma Export (C, End_Handler, "__gnat_end_handler");

   Setup_Key : constant := 16#DEAD#;

   --  To handle the case of a task "transferring" an exception occurrence to

   --  another task, for instance via Exceptional_Complete_Rendezvous, we need

   --  to be able to identify occurrences which have been Setup and not yet

   --  Propagated. We hijack one of the common header fields for that purpose,

   --  setting it to a special key value during the setup process, clearing it

   --  at the very beginning of the propagation phase, and expecting it never

   --  to be reset to the special value later on. A 16-bit value is used rather

   --  than a 32-bit value for static compatibility with 16-bit targets such as

   --  AAMP (where type Unwind_Word will be 16 bits).

   function Is_Setup_And_Not_Propagated (E : EOA) return Boolean;

   procedure Set_Setup_And_Not_Propagated (E : EOA);

   procedure Clear_Setup_And_Not_Propagated (E : EOA);

   procedure Save_Occurrence_And_Private

     (Target : out Exception_Occurrence;

      Source : Exception_Occurrence);

   --  Copy all the components of Source to Target as well as the

   --  Private_Data pointer.

   --------------------------------------------------------------------

   -- Accessors to Basic Components of a GNAT Exception Data Pointer --

   --------------------------------------------------------------------

   --  As of today, these are only used by the C implementation of the GCC

   --  propagation personality routine to avoid having to rely on a C

   --  counterpart of the whole exception_data structure, which is both

   --  painful and error prone. These subprograms could be moved to a more

   --  widely visible location if need be.

   function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;

   pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");

   pragma Warnings (Off, Is_Handled_By_Others);

   function Language_For (E : Exception_Data_Ptr) return Character;

   pragma Export (C, Language_For, "__gnat_language_for");

   function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;

   pragma Export (C, Import_Code_For, "__gnat_import_code_for");

   function EID_For (GNAT_Exception : GNAT_GCC_Exception_Access)

     return Exception_Id;

   pragma Export (C, EID_For, "__gnat_eid_for");

   procedure Adjust_N_Cleanups_For

     (GNAT_Exception : GNAT_GCC_Exception_Access;

      Adjustment     : Integer);

   pragma Export (C, Adjust_N_Cleanups_For, "__gnat_adjust_n_cleanups_for");

   ---------------------------------------------------------------------------

   -- Objects to materialize "others" and "all others" in the GCC EH tables --

   ---------------------------------------------------------------------------

   --  Currently, these only have their address taken and compared so there is

   --  no real point having whole exception data blocks allocated. In any case

   --  the types should match what gigi and the personality routine expect.

   --  The initial value is an arbitrary value that will not exceed the range

   --  of Integer on 16-bit targets (such as AAMP).

   Others_Value : constant Integer := 16#7FFF#;

   pragma Export (C, Others_Value, "__gnat_others_value");

   All_Others_Value : constant Integer := 16#7FFF#;

   pragma Export (C, All_Others_Value, "__gnat_all_others_value");

   ------------

   -- Remove --

   ------------

   function Remove

     (Top   : EOA;

      Excep : GNAT_GCC_Exception_Access) return Boolean

   is

      Prev          : GNAT_GCC_Exception_Access := null;

      Iter          : EOA := Top;

      GCC_Exception : GNAT_GCC_Exception_Access;

   begin

      --  Pop stack

      loop

         pragma Assert (Iter.Private_Data /= System.Null_Address);

         GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data);

         if GCC_Exception = Excep then

            if Prev = null then

               --  Special case for the top of the stack: shift the contents

               --  of the next item to the top, since top is at a fixed

               --  location and can't be changed.

               Iter := GCC_Exception.Next_Exception;

               if Iter = null then

                  --  Stack is now empty

                  Top.Private_Data := System.Null_Address;

               else

                  Save_Occurrence_And_Private (Top.all, Iter.all);

                  Free (Iter);

               end if;

            else

               Prev.Next_Exception := GCC_Exception.Next_Exception;

               Free (Iter);

            end if;

            Free (GCC_Exception);

            return True;

         end if;

         exit when GCC_Exception.Next_Exception = null;

         Prev := GCC_Exception;

         Iter := GCC_Exception.Next_Exception;

      end loop;

      return False;

   end Remove;

   ---------------------------

   -- CleanupUnwind_Handler --

   ---------------------------

   function CleanupUnwind_Handler

     (UW_Version   : Integer;

      UW_Phases    : Unwind_Action;

      UW_Eclass    : Exception_Class;

      UW_Exception : not null access GNAT_GCC_Exception;

      UW_Context   : System.Address;

      UW_Argument  : System.Address) return Unwind_Reason_Code

   is

      pragma Unreferenced

        (UW_Version, UW_Phases, UW_Eclass, UW_Context, UW_Argument);

   begin

      --  Terminate as soon as we know there is nothing more to run. The

      --  count is maintained by the personality routine.

      if UW_Exception.N_Cleanups_To_Trigger = 0 then

         Unhandled_Exception_Terminate;

      end if;

      --  We know there is at least one cleanup further up. Return so that it

      --  is searched and entered, after which Unwind_Resume will be called

      --  and this hook will gain control (with an updated count) again.

      return URC_NO_REASON;

   end CleanupUnwind_Handler;

   ---------------------------------

   -- Is_Setup_And_Not_Propagated --

   ---------------------------------

   function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is

      GCC_E : constant GNAT_GCC_Exception_Access :=

                To_GNAT_GCC_Exception (E.Private_Data);

   begin

      return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key;

   end Is_Setup_And_Not_Propagated;

   ------------------------------------

   -- Clear_Setup_And_Not_Propagated --

   ------------------------------------

   procedure Clear_Setup_And_Not_Propagated (E : EOA) is

      GCC_E : constant GNAT_GCC_Exception_Access :=

                To_GNAT_GCC_Exception (E.Private_Data);

   begin

      pragma Assert (GCC_E /= null);

      GCC_E.Header.Private1 := 0;

   end Clear_Setup_And_Not_Propagated;

   ----------------------------------

   -- Set_Setup_And_Not_Propagated --

   ----------------------------------

   procedure Set_Setup_And_Not_Propagated (E : EOA) is

      GCC_E : constant GNAT_GCC_Exception_Access :=

                To_GNAT_GCC_Exception (E.Private_Data);

   begin

      pragma Assert (GCC_E /= null);

      GCC_E.Header.Private1 := Setup_Key;

   end Set_Setup_And_Not_Propagated;

   --------------------------------

   -- Save_Occurrence_And_Private --

   --------------------------------

   procedure Save_Occurrence_And_Private

     (Target : out Exception_Occurrence;

      Source : Exception_Occurrence)

   is

   begin

      Save_Occurrence_No_Private (Target, Source);

      Target.Private_Data := Source.Private_Data;

   end Save_Occurrence_And_Private;

   ---------------------

   -- Setup_Exception --

   ---------------------

   --  In the GCC-EH implementation of the propagation scheme, this

   --  subprogram should be understood as: Setup the exception occurrence

   --  stack headed at Current for a forthcoming raise of Excep.

   procedure Setup_Exception

     (Excep    : EOA;

      Current  : EOA;

      Reraised : Boolean := False)

   is

      Top           : constant EOA := Current;

      Next          : EOA;

      GCC_Exception : GNAT_GCC_Exception_Access;

   begin

      --  The exception Excep is soon to be propagated, and the

      --  storage used for that will be the occurrence statically allocated

      --  for the current thread. This storage might currently be used for a

      --  still active occurrence, so we need to push it on the thread's

      --  occurrence stack (headed at that static occurrence) before it gets

      --  clobbered.

      --  What we do here is to trigger this push when need be, and allocate a

      --  Private_Data block for the forthcoming Propagation.

      --  Some tasking rendez-vous attempts lead to an occurrence transfer

      --  from the server to the client (see Exceptional_Complete_Rendezvous).

      --  In those cases Setup is called twice for the very same occurrence

      --  before it gets propagated: once from the server, because this is

      --  where the occurrence contents is elaborated and known, and then

      --  once from the client when it detects the case and actually raises

      --  the exception in its own context.

      --  The Is_Setup_And_Not_Propagated predicate tells us when we are in

      --  the second call to Setup for a Transferred occurrence, and there is

      --  nothing to be done here in this situation. This predicate cannot be

      --  True if we are dealing with a Reraise, and we may even be called

      --  with a raw uninitialized Excep occurrence in this case so we should

      --  not check anyway. Observe the front-end expansion for a "raise;" to

      --  see that happening. We get a local occurrence and a direct call to

      --  Save_Occurrence without the intermediate init-proc call.

      if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then

         return;

      end if;

      --  Allocate what will be the Private_Data block for the exception

      --  to be propagated.

      GCC_Exception := new GNAT_GCC_Exception;

      --  If the Top of the occurrence stack is not currently used for an

      --  active exception (the stack is empty) we just need to setup the

      --  Private_Data pointer.

      --  Otherwise, we also need to shift the contents of the Top of the

      --  stack in a freshly allocated entry and link everything together.

      if Top.Private_Data /= System.Null_Address then

         Next := new Exception_Occurrence;

         Save_Occurrence_And_Private (Next.all, Top.all);

         GCC_Exception.Next_Exception := Next;

         Top.Private_Data := GCC_Exception.all'Address;

      end if;

      Top.Private_Data := GCC_Exception.all'Address;

      Set_Setup_And_Not_Propagated (Top);

   end Setup_Exception;

   -------------------

   -- Begin_Handler --

   -------------------

   procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is

      pragma Unreferenced (GCC_Exception);

   begin

      --  Every necessary operation related to the occurrence stack has

      --  already been performed by Propagate_Exception. This hook remains for

      --  potential future necessity in optimizing the overall scheme, as well

      --  a useful debugging tool.

      null;

   end Begin_Handler;

   -----------------

   -- End_Handler --

   -----------------

   procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is

      Removed : Boolean;

   begin

      Removed := Remove (Get_Current_Excep.all, GCC_Exception);

      pragma Assert (Removed);

   end End_Handler;

   -------------------------

   -- Propagate_Exception --

   -------------------------

   --  Build an object suitable for the libgcc processing and call

   --  Unwind_RaiseException to actually throw, taking care of handling

   --  the two phase scheme it implements.

   procedure Propagate_Exception

     (E                   : Exception_Id;

      From_Signal_Handler : Boolean)

   is

      pragma Inspection_Point (E);

      pragma Unreferenced (From_Signal_Handler);

      Excep         : constant EOA := Get_Current_Excep.all;

      GCC_Exception : GNAT_GCC_Exception_Access;

   begin

      pragma Assert (Excep.Private_Data /= System.Null_Address);

      --  Retrieve the Private_Data for this occurrence and set the useful

      --  flags for the personality routine, which will be called for each

      --  frame via Unwind_RaiseException below.

      GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);

      Clear_Setup_And_Not_Propagated (Excep);

      GCC_Exception.Id := Excep.Id;

      GCC_Exception.N_Cleanups_To_Trigger := 0;

      --  Compute the backtrace for this occurrence if the corresponding

      --  binder option has been set. Call_Chain takes care of the reraise

      --  case.

      --  ??? Using Call_Chain here means we are going to walk up the stack

      --  once only for backtracing purposes before doing it again for the

      --  propagation per se.

      --  The first inspection is much lighter, though, as it only requires

      --  partial unwinding of each frame. Additionally, although we could use

      --  the personality routine to record the addresses while propagating,

      --  this method has two drawbacks:

      --  1) the trace is incomplete if the exception is handled since we

      --  don't walk past the frame with the handler,

      --    and

      --  2) we would miss the frames for which our personality routine is not

      --  called, e.g. if C or C++ calls are on the way.

      Call_Chain (Excep);

      --  Perform a standard raise first. If a regular handler is found, it

      --  will be entered after all the intermediate cleanups have run. If

      --  there is no regular handler, control will get back to after the

      --  call, with N_Cleanups_To_Trigger set to the number of frames with

      --  cleanups found on the way up, and none of these already run.

      Unwind_RaiseException (GCC_Exception);

      --  If we get here we know the exception is not handled, as otherwise

      --  Unwind_RaiseException arranges for the handler to be entered. Take

      --  the necessary steps to enable the debugger to gain control while the

      --  stack is still intact.

      Notify_Unhandled_Exception;

      --  Now, if cleanups have been found, run a forced unwind to trigger

      --  them. Control should not resume there, as the unwinding hook calls

      --  Unhandled_Exception_Terminate as soon as the last cleanup has been

      --  triggered.

      if GCC_Exception.N_Cleanups_To_Trigger /= 0 then

         Unwind_ForcedUnwind (GCC_Exception,

                              CleanupUnwind_Handler'Address,

                              System.Null_Address);

      end if;

      --  We get here when there is no handler or cleanup to be run at all.

      --  The debugger has been notified before the second step above.

      Unhandled_Exception_Terminate;

   end Propagate_Exception;

   ---------------------------

   -- Adjust_N_Cleanups_For --

   ---------------------------

   procedure Adjust_N_Cleanups_For

     (GNAT_Exception : GNAT_GCC_Exception_Access;

      Adjustment     : Integer)

   is

   begin

      GNAT_Exception.N_Cleanups_To_Trigger :=

        GNAT_Exception.N_Cleanups_To_Trigger + Adjustment;

   end Adjust_N_Cleanups_For;

   -------------

   -- EID_For --

   -------------

   function EID_For

     (GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id

   is

   begin

      return GNAT_Exception.Id;

   end EID_For;

   ---------------------

   -- Import_Code_For --

   ---------------------

   function Import_Code_For

     (E : SSL.Exception_Data_Ptr) return Exception_Code

   is

   begin

      return E.all.Import_Code;

   end Import_Code_For;

   --------------------------

   -- Is_Handled_By_Others --

   --------------------------

   function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is

   begin

      return not E.all.Not_Handled_By_Others;

   end Is_Handled_By_Others;

   ------------------

   -- Language_For --

   ------------------

   function Language_For (E : SSL.Exception_Data_Ptr) return Character is

   begin

      return E.all.Lang;

   end Language_For;

   -----------

   -- Notes --

   -----------

   --  The current model implemented for the stack of occurrences is a

   --  simplification of previous attempts, which all proved to be flawed or

   --  would have needed significant additional circuitry to be made to work

   --  correctly.

   --  We now represent every propagation by a new entry on the stack, which

   --  means that an exception occurrence may appear more than once (e.g. when

   --  it is reraised during the course of its own handler).

   --  This may seem overcostly compared to the C++ model as implemented in

   --  the g++ v3 libstd. This is actually understandable when one considers

   --  the extra variations of possible run-time configurations induced by the

   --  freedom offered by the Save_Occurrence/Reraise_Occurrence public

   --  interface.

   --  The basic point is that arranging for an occurrence to always appear at

   --  most once on the stack requires a way to determine if a given occurrence

   --  is already there, which is not as easy as it might seem.

   --  An attempt was made to use the Private_Data pointer for this purpose.

   --  It did not work because:

   --  1) The Private_Data has to be saved by Save_Occurrence to be usable

   --     as a key in case of a later reraise,

   --  2) There is no easy way to synchronize End_Handler for an occurrence

   --     and the data attached to potential copies, so these copies may end

   --     up pointing to stale data. Moreover ...

   --  3) The same address may be reused for different occurrences, which

   --     defeats the idea of using it as a key.

   --  The example below illustrates:

   --  Saved_CE : Exception_Occurrence;

   --  begin

   --    raise Constraint_Error;

   --  exception

   --    when CE: others =>

   --      Save_Occurrence (Saved_CE, CE);      <= Saved_CE.PDA = CE.PDA

   --  end;

   --                                           <= Saved_CE.PDA is stale (!)

   --  begin

   --    raise Program_Error;                   <= Saved_CE.PDA = PE.PDA (!!)

   --  exception

   --    when others =>

   --      Reraise_Occurrence (Saved_CE);

   --  end;

   --  Not releasing the Private_Data via End_Handler could be an option,

   --  but making this to work while still avoiding memory leaks is far

   --  from trivial.

   --  The current scheme has the advantage of being simple, and induces

   --  extra costs only in reraise cases which is acceptable.

end Exception_Propagation;