gcc/ada/libgnat/a-exexpr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --  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 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2024, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This is the version using the GCC EH mechanism, which could rely on
  33 --  different underlying unwinding engines, for example DWARF or ARM unwind
  34 --  info based. Here is a sketch of the most prominent data structures
  35 --  involved:
  36
  37 --      (s-excmac.ads)
  38 --      GNAT_GCC_Exception:
  39 --      *-----------------------------------*
  40 --  o-->|          (s-excmac.ads)           |
  41 --  |   | Header : <gcc occurrence type>    |
  42 --  |   |   - Class                         |
  43 --  |   |   ...                             |    Constraint_Error:
  44 --  |   |-----------------------------------*    Program_Error:
  45 --  |   |              (a-except.ads)       |    Foreign_Exception:
  46 --  |   | Occurrence : Exception_Occurrence |
  47 --  |   |                                   |    (s-stalib. ads)
  48 --  |   |   - Id : Exception_Id  --------------> Exception_Data
  49 --  o------ - Machine_Occurrence            |   *------------------------*
  50 --      |   - Msg                           |   | Not_Handled_By_Others  |
  51 --      |   - Traceback                     |   | Lang                   |
  52 --      |   ...                             |   | Foreign_Data --o       |
  53 --      *-----------------------------------*   | Full_Name      |       |
  54 --        ||                                    | ...            |       |
  55 --        ||          foreign rtti blob         *----------------|-------*
  56 --        ||          *---------------*                          |
  57 --        ||          |   ...   ...   |<-------------------------o
  58 --        ||          *---------------*
  59 --        ||
  60 --     Setup_Current_Excep()
  61 --        ||
  62 --        ||   Latch into ATCB or
  63 --        ||   environment Current Exception Buffer:
  64 --        ||
  65 --        vv
  66 --     <> : Exception_Occurrence
  67 --     *---------------------------*
  68 --     | ...  ...  ... ... ... ... * --- Get_Current_Excep() ---->
  69 --     *---------------------------*
  70
  71 --  On "raise" events, the runtime allocates a new GNAT_GCC_Exception
  72 --  instance and eventually calls into libgcc's Unwind_RaiseException.
  73 --  This part handles the object through the header part only.
  74
  75 --  During execution, Get_Current_Excep provides a pointer to the
  76 --  Exception_Occurrence being raised or last raised by the current task.
  77
  78 --  This is actually the address of a statically allocated
  79 --  Exception_Occurrence attached to the current ATCB or to the environment
  80 --  thread into which an occurrence being raised is synchronized at critical
  81 --  points during the raise process, via Setup_Current_Excep.
  82
  83 with Ada.Unchecked_Conversion;
  84 with Ada.Unchecked_Deallocation;
  85
  86 with System.Storage_Elements;   use System.Storage_Elements;
  87 with System.Exceptions.Machine; use System.Exceptions.Machine;
  88
  89 separate (Ada.Exceptions)
  90 package body Exception_Propagation is
  91
  92    use Exception_Traces;
  93
  94    type bool is new Boolean;
  95    pragma Convention (C, bool);
  96
  97    Foreign_Exception : aliased System.Standard_Library.Exception_Data;
  98    pragma Import (Ada, Foreign_Exception,
  99                   "system__exceptions__foreign_exception");
 100    --  Id for foreign exceptions
 101
 102    --------------------------------------------------------------
 103    -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
 104    --------------------------------------------------------------
 105
 106    --  Phase identifiers (Unwind Actions)
 107
 108    type Unwind_Action is new Integer;
 109    pragma Convention (C, Unwind_Action);
 110
 111    UA_SEARCH_PHASE  : constant Unwind_Action := 1;
 112    UA_CLEANUP_PHASE : constant Unwind_Action := 2;
 113    UA_HANDLER_FRAME : constant Unwind_Action := 4;
 114    UA_FORCE_UNWIND  : constant Unwind_Action := 8;
 115    UA_END_OF_STACK  : constant Unwind_Action := 16;  --  GCC extension
 116
 117    pragma Unreferenced
 118      (UA_HANDLER_FRAME,
 119       UA_FORCE_UNWIND,
 120       UA_END_OF_STACK);
 121
 122    procedure GNAT_GCC_Exception_Cleanup
 123      (Reason : Unwind_Reason_Code;
 124       Excep  : not null GNAT_GCC_Exception_Access);
 125    pragma Convention (C, GNAT_GCC_Exception_Cleanup);
 126    --  Procedure called when a GNAT GCC exception is free.
 127
 128    procedure Propagate_GCC_Exception
 129      (GCC_Exception : not null GCC_Exception_Access);
 130    pragma No_Return (Propagate_GCC_Exception);
 131    --  Propagate a GCC exception
 132
 133    procedure Reraise_GCC_Exception
 134      (GCC_Exception : not null GCC_Exception_Access);
 135    pragma No_Return (Reraise_GCC_Exception);
 136    pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
 137    --  Called to implement raise without exception, ie reraise. Called
 138    --  directly from gigi.
 139
 140    function Setup_Current_Excep
 141      (GCC_Exception : not null GCC_Exception_Access;
 142       Phase : Unwind_Action) return EOA;
 143    pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
 144    --  Acknowledge GCC_Exception as the current exception object being
 145    --  raised, which could be an Ada or a foreign exception object.  Return
 146    --  a pointer to the embedded Ada occurrence for an Ada exception object,
 147    --  to the current exception buffer otherwise.
 148    --
 149    --  Synchronize the current exception buffer as needed for possible
 150    --  accesses through Get_Current_Except.all afterwards, depending on the
 151    --  Phase bits, received either from the personality routine, from a
 152    --  forced_unwind cleanup handler, or just before the start of propagation
 153    --  for an Ada exception (Phase 0 in this case).
 154
 155    procedure Unhandled_Except_Handler
 156      (GCC_Exception : not null GCC_Exception_Access);
 157    pragma No_Return (Unhandled_Except_Handler);
 158    pragma Export (C, Unhandled_Except_Handler,
 159                   "__gnat_unhandled_except_handler");
 160    --  Called for handle unhandled exceptions, ie the last chance handler
 161    --  on platforms (such as SEH) that never returns after throwing an
 162    --  exception. Called directly by gigi.
 163
 164    function CleanupUnwind_Handler
 165      (UW_Version   : Integer;
 166       UW_Phases    : Unwind_Action;
 167       UW_Eclass    : Exception_Class;
 168       UW_Exception : not null GCC_Exception_Access;
 169       UW_Context   : System.Address;
 170       UW_Argument  : System.Address) return Unwind_Reason_Code;
 171    pragma Import (C, CleanupUnwind_Handler,
 172                   "__gnat_cleanupunwind_handler");
 173    --  Hook called at each step of the forced unwinding we perform to trigger
 174    --  cleanups found during the propagation of an unhandled exception.
 175
 176    --  GCC runtime functions used. These are C non-void functions, actually,
 177    --  but we ignore the return values. See raise.c as to why we are using
 178    --  __gnat stubs for these.
 179
 180    procedure Unwind_RaiseException
 181      (UW_Exception : not null GCC_Exception_Access);
 182    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 183
 184    procedure Unwind_ForcedUnwind
 185      (UW_Exception : not null GCC_Exception_Access;
 186       UW_Handler   : System.Address;
 187       UW_Argument  : System.Address);
 188    pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
 189
 190    procedure Set_Exception_Parameter
 191      (Excep         : EOA;
 192       GCC_Exception : not null GCC_Exception_Access);
 193    pragma Export
 194      (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
 195    --  Called inserted by gigi to set the exception choice parameter from the
 196    --  gcc occurrence.
 197
 198    procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
 199    --  Utility routine to initialize occurrence Excep from a foreign exception
 200    --  whose machine occurrence is Mo. The message is empty, the backtrace
 201    --  is empty too and the exception identity is Foreign_Exception.
 202
 203    --  Hooks called when entering/leaving an exception handler for a
 204    --  given occurrence.  The calls are generated by gigi in
 205    --  Exception_Handler_to_gnu_gcc.
 206
 207    --  Begin_Handler_v1, called when entering an exception handler,
 208    --  claims responsibility for the handler to release the
 209    --  GCC_Exception occurrence.  End_Handler_v1, called when
 210    --  leaving the handler, releases the occurrence, unless the
 211    --  occurrence is propagating further up, or the handler is
 212    --  dynamically nested in the context of another handler that
 213    --  claimed responsibility for releasing that occurrence.
 214
 215    --  Responsibility is claimed by changing the Cleanup field to
 216    --  Claimed_Cleanup, which enables claimed exceptions to be
 217    --  recognized, and avoids accidental releases even by foreign
 218    --  handlers.
 219
 220    function Begin_Handler_v1
 221      (GCC_Exception : not null GCC_Exception_Access)
 222      return System.Address;
 223    pragma Export (C, Begin_Handler_v1, "__gnat_begin_handler_v1");
 224    --  Called when entering an exception handler.  Claim
 225    --  responsibility for releasing GCC_Exception, by setting the
 226    --  cleanup/release function to Claimed_Cleanup, and return the
 227    --  address of the previous cleanup/release function.
 228
 229    procedure End_Handler_v1
 230      (GCC_Exception : not null GCC_Exception_Access;
 231       Saved_Cleanup : System.Address;
 232       Propagating_Exception : GCC_Exception_Access);
 233    pragma Export (C, End_Handler_v1, "__gnat_end_handler_v1");
 234    --  Called when leaving an exception handler.  Restore the
 235    --  Saved_Cleanup in the GCC_Exception occurrence, and then release
 236    --  it, unless it remains claimed by an enclosing handler, or
 237    --  GCC_Exception and Propagating_Exception are the same
 238    --  occurrence.  Propagating_Exception could be either an
 239    --  occurrence (re)raised within the handler of GCC_Exception, when
 240    --  we're executing as an exceptional cleanup, or null, if we're
 241    --  completing the handler of GCC_Exception normally.
 242
 243    procedure Claimed_Cleanup
 244      (Reason : Unwind_Reason_Code;
 245       GCC_Exception : not null GCC_Exception_Access);
 246    pragma Export (C, Claimed_Cleanup, "__gnat_claimed_cleanup");
 247    --  A do-nothing placeholder installed as GCC_Exception.Cleanup
 248    --  while handling GCC_Exception, to claim responsibility for
 249    --  releasing it, and to stop it from being accidentally released.
 250
 251    --  The following are version 0 implementations of the version 1
 252    --  hooks above.  They remain in place for compatibility with the
 253    --  output of compilers that still use version 0, such as those
 254    --  used during bootstrap.  They are interoperable with the v1
 255    --  hooks, except that the older versions may malfunction when
 256    --  handling foreign exceptions passed to Reraise_Occurrence.
 257
 258    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
 259    pragma Export (C, Begin_Handler, "__gnat_begin_handler");
 260    --  Called when entering an exception handler translated by an old
 261    --  compiler.  It does nothing.
 262
 263    procedure End_Handler (GCC_Exception : GCC_Exception_Access);
 264    pragma Export (C, End_Handler, "__gnat_end_handler");
 265    --  Called when leaving an exception handler translated by an old
 266    --  compiler.  It releases GCC_Exception, unless it is null.  It is
 267    --  only ever null when the handler has a 'raise;' translated by a
 268    --  v0-using compiler.  The artificial handler variable passed to
 269    --  End_Handler was set to null to tell End_Handler to refrain from
 270    --  releasing the reraised exception.  In v1 safer ways are used to
 271    --  accomplish that.
 272
 273    --------------------------------------------------------------------
 274    -- Accessors to Basic Components of a GNAT Exception Data Pointer --
 275    --------------------------------------------------------------------
 276
 277    --  As of today, these are only used by the C implementation of the GCC
 278    --  propagation personality routine to avoid having to rely on a C
 279    --  counterpart of the whole exception_data structure, which is both
 280    --  painful and error prone. These subprograms could be moved to a more
 281    --  widely visible location if need be.
 282
 283    function Is_Handled_By_Others (E : Exception_Data_Ptr) return bool;
 284    pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
 285
 286    function Language_For (E : Exception_Data_Ptr) return Character;
 287    pragma Export (C, Language_For, "__gnat_language_for");
 288
 289    function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
 290    pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
 291
 292    function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
 293      return Exception_Id;
 294    pragma Export (C, EID_For, "__gnat_eid_for");
 295
 296    ---------------------------------------------------------------------------
 297    -- Objects to materialize "others" and "all others" in the GCC EH tables --
 298    ---------------------------------------------------------------------------
 299
 300    --  Currently, these only have their address taken and compared so there is
 301    --  no real point having whole exception data blocks allocated. Note that
 302    --  there are corresponding declarations in gigi (trans.c) which must be
 303    --  kept properly synchronized.
 304
 305    Others_Value : constant Character := 'O';
 306    pragma Export (C, Others_Value, "__gnat_others_value");
 307
 308    All_Others_Value : constant Character := 'A';
 309    pragma Export (C, All_Others_Value, "__gnat_all_others_value");
 310
 311    Unhandled_Others_Value : constant Character := 'U';
 312    pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
 313    --  Special choice (emitted by gigi) to catch and notify unhandled
 314    --  exceptions on targets which always handle exceptions (such as SEH).
 315    --  The handler will simply call Unhandled_Except_Handler.
 316
 317    -------------------------
 318    -- Allocate_Occurrence --
 319    -------------------------
 320
 321    function Allocate_Occurrence return EOA is
 322       Res : GNAT_GCC_Exception_Access;
 323
 324    begin
 325       Res := New_Occurrence;
 326       Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address;
 327       Res.Occurrence.Machine_Occurrence := Res.all'Address;
 328
 329       return Res.Occurrence'Access;
 330    end Allocate_Occurrence;
 331
 332    --------------------------------
 333    -- GNAT_GCC_Exception_Cleanup --
 334    --------------------------------
 335
 336    procedure GNAT_GCC_Exception_Cleanup
 337      (Reason : Unwind_Reason_Code;
 338       Excep  : not null GNAT_GCC_Exception_Access)
 339    is
 340       pragma Unreferenced (Reason);
 341
 342       procedure Free is new Unchecked_Deallocation
 343         (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 344
 345       Copy : GNAT_GCC_Exception_Access := Excep;
 346
 347    begin
 348       --  Simply free the memory
 349
 350       Free (Copy);
 351    end GNAT_GCC_Exception_Cleanup;
 352
 353    ----------------------------
 354    -- Set_Foreign_Occurrence --
 355    ----------------------------
 356
 357    procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
 358    begin
 359       Excep.all := (
 360         Id                 => Foreign_Exception'Access,
 361         Machine_Occurrence => Mo,
 362         Msg                => <>,
 363         Msg_Length         => 0,
 364         Exception_Raised   => True,
 365         Pid                => Local_Partition_ID,
 366         Num_Tracebacks     => 0,
 367         Tracebacks         => <>);
 368    end Set_Foreign_Occurrence;
 369
 370    -------------------------
 371    -- Setup_Current_Excep --
 372    -------------------------
 373
 374    function Setup_Current_Excep
 375      (GCC_Exception : not null GCC_Exception_Access;
 376       Phase : Unwind_Action) return EOA
 377    is
 378       Excep : constant EOA := Get_Current_Excep.all;
 379
 380    begin
 381
 382       if GCC_Exception.Class = GNAT_Exception_Class then
 383
 384          --  Ada exception : latch the occurrence data in the Current
 385          --  Exception Buffer if needed and return a pointer to the original
 386          --  Ada exception object. This particular object was specifically
 387          --  allocated for this raise and is thus more precise than the fixed
 388          --  Current Exception Buffer address.
 389
 390          declare
 391             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 392                                 To_GNAT_GCC_Exception (GCC_Exception);
 393          begin
 394
 395             --  When reaching here during SEARCH_PHASE, no need to
 396             --  replicate the copy performed at the propagation start.
 397
 398             if Phase /= UA_SEARCH_PHASE then
 399                Excep.all := GNAT_Occurrence.Occurrence;
 400             end if;
 401             return GNAT_Occurrence.Occurrence'Access;
 402          end;
 403
 404       else
 405
 406          --  Foreign exception (caught by Ada handler, reaching here from
 407          --  personality routine) : The original exception object doesn't hold
 408          --  an Ada occurrence info.  Set the foreign data pointer in the
 409          --  Current Exception Buffer and return the address of the latter.
 410
 411          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 412
 413          return Excep;
 414       end if;
 415    end Setup_Current_Excep;
 416
 417    ----------------------
 418    -- Begin_Handler_v1 --
 419    ----------------------
 420
 421    function Begin_Handler_v1
 422      (GCC_Exception : not null GCC_Exception_Access)
 423      return System.Address is
 424       Saved_Cleanup : constant System.Address := GCC_Exception.Cleanup;
 425    begin
 426       --  Claim responsibility for releasing this exception, and stop
 427       --  others from releasing it.
 428       GCC_Exception.Cleanup := Claimed_Cleanup'Address;
 429       return Saved_Cleanup;
 430    end Begin_Handler_v1;
 431
 432    --------------------
 433    -- End_Handler_v1 --
 434    --------------------
 435
 436    procedure End_Handler_v1
 437      (GCC_Exception : not null GCC_Exception_Access;
 438       Saved_Cleanup : System.Address;
 439       Propagating_Exception : GCC_Exception_Access) is
 440    begin
 441       GCC_Exception.Cleanup := Saved_Cleanup;
 442       --  Restore the Saved_Cleanup, so that it is either used to
 443       --  release GCC_Exception below, or transferred to the next
 444       --  handler of the Propagating_Exception occurrence.  The
 445       --  following test ensures that an occurrence is only released
 446       --  once, even after reraises.
 447       --
 448       --  The idea is that the GCC_Exception is not to be released
 449       --  unless it had an unclaimed Cleanup when the handler started
 450       --  (see Begin_Handler_v1 above), but if we propagate across its
 451       --  handler a reraise of the same exception, we transfer to the
 452       --  Propagating_Exception the responsibility for running the
 453       --  Saved_Cleanup when its handler completes.
 454       --
 455       --  This ownership transfer mechanism ensures safety, as in
 456       --  single release and no dangling pointers, because there is no
 457       --  way to hold on to the Machine_Occurrence of an
 458       --  Exception_Occurrence: the only situations in which another
 459       --  Exception_Occurrence gets the same Machine_Occurrence are
 460       --  through Reraise_Occurrence, and plain reraise, and so we
 461       --  have the following possibilities:
 462       --
 463       --  - Reraise_Occurrence is handled within the running handler,
 464       --  and so when completing the dynamically nested handler, we
 465       --  must NOT release the exception.  A Claimed_Cleanup upon
 466       --  entry of the nested handler, installed when entering the
 467       --  enclosing handler, ensures the exception will not be
 468       --  released by the nested handler, but rather by the enclosing
 469       --  handler.
 470       --
 471       --  - Reraise_Occurrence/reraise escapes the running handler,
 472       --  and we run as an exceptional cleanup for GCC_Exception.  The
 473       --  Saved_Cleanup was reinstalled, but since we're propagating
 474       --  the same machine occurrence, we do not release it.  Instead,
 475       --  we transfer responsibility for releasing it to the eventual
 476       --  handler of the propagating exception.
 477       --
 478       --  - An unrelated exception propagates through the running
 479       --  handler.  We restored GCC_Exception.Saved_Cleanup above.
 480       --  Since we're propagating a different exception, we proceed to
 481       --  release GCC_Exception, unless Saved_Cleanup was
 482       --  Claimed_Cleanup, because then we know we're not in the
 483       --  outermost handler for GCC_Exception.
 484       --
 485       --  - The handler completes normally, so it reinstalls the
 486       --  Saved_Cleanup and runs it, unless it was Claimed_Cleanup.
 487       --  If Saved_Cleanup is null, Unwind_DeleteException (currently)
 488       --  has no effect, so we could skip it, but if it is ever
 489       --  changed to do more in this case, we're ready for that,
 490       --  calling it exactly once.
 491       if Saved_Cleanup /= Claimed_Cleanup'Address
 492         and then
 493         Propagating_Exception /= GCC_Exception
 494       then
 495          declare
 496             Current : constant EOA := Get_Current_Excep.all;
 497             Cur_Occ : constant GCC_Exception_Access :=
 498               To_GCC_Exception (Current.Machine_Occurrence);
 499          begin
 500             --  If we are releasing the Machine_Occurrence of the current
 501             --  exception, reset the access to it, so that it is no
 502             --  longer accessible.
 503             if Cur_Occ = GCC_Exception then
 504                Current.Machine_Occurrence := System.Null_Address;
 505             end if;
 506          end;
 507          Unwind_DeleteException (GCC_Exception);
 508       end if;
 509    end End_Handler_v1;
 510
 511    ---------------------
 512    -- Claimed_Cleanup --
 513    ---------------------
 514
 515    procedure Claimed_Cleanup
 516      (Reason : Unwind_Reason_Code;
 517       GCC_Exception : not null GCC_Exception_Access) is
 518       pragma Unreferenced (Reason);
 519       pragma Unreferenced (GCC_Exception);
 520    begin
 521       --  This procedure should never run.  If it does, it's either a
 522       --  version 0 handler or a foreign handler, attempting to
 523       --  release an exception while a version 1 handler that claimed
 524       --  responsibility for releasing the exception remains still
 525       --  active.  This placeholder stops GCC_Exception from being
 526       --  released by them.
 527
 528       --  We could get away with just Null_Address instead, with
 529       --  nearly the same effect, but with this placeholder we can
 530       --  detect and report unexpected releases, and we can tell apart
 531       --  a GCC_Exception without a Cleanup, from one with another
 532       --  active handler, so as to still call Unwind_DeleteException
 533       --  exactly once: currently, Unwind_DeleteException does nothing
 534       --  when the Cleanup is null, but should it ever be changed to
 535       --  do more, we'll still be safe.
 536       null;
 537    end Claimed_Cleanup;
 538
 539    -------------------
 540    -- Begin_Handler --
 541    -------------------
 542
 543    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
 544       pragma Unreferenced (GCC_Exception);
 545    begin
 546       null;
 547    end Begin_Handler;
 548
 549    -----------------
 550    -- End_Handler --
 551    -----------------
 552
 553    procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
 554    begin
 555       if GCC_Exception /= null then
 556
 557          --  The exception might have been reraised, in this case the cleanup
 558          --  mustn't be called.
 559
 560          Unwind_DeleteException (GCC_Exception);
 561       end if;
 562    end End_Handler;
 563
 564    -----------------------------
 565    -- Reraise_GCC_Exception --
 566    -----------------------------
 567
 568    procedure Reraise_GCC_Exception
 569      (GCC_Exception : not null GCC_Exception_Access)
 570    is
 571    begin
 572       --  Simply propagate it
 573
 574       Propagate_GCC_Exception (GCC_Exception);
 575    end Reraise_GCC_Exception;
 576
 577    -----------------------------
 578    -- Propagate_GCC_Exception --
 579    -----------------------------
 580
 581    --  Call Unwind_RaiseException to actually throw, taking care of handling
 582    --  the two phase scheme it implements.
 583
 584    procedure Propagate_GCC_Exception
 585      (GCC_Exception : not null GCC_Exception_Access)
 586    is
 587       --  Acknowledge the current exception info now, before unwinding
 588       --  starts so it is available even from C++ handlers involved before
 589       --  our personality routine.
 590
 591       Excep : constant EOA :=
 592         Setup_Current_Excep (GCC_Exception, Phase => 0);
 593
 594    begin
 595       --  Perform a standard raise first. If a regular handler is found, it
 596       --  will be entered after all the intermediate cleanups have run. If
 597       --  there is no regular handler, it will return.
 598
 599       Unwind_RaiseException (GCC_Exception);
 600
 601       --  If we get here we know the exception is not handled, as otherwise
 602       --  Unwind_RaiseException arranges for the handler to be entered. Take
 603       --  the necessary steps to enable the debugger to gain control while the
 604       --  stack is still intact.
 605
 606       Notify_Unhandled_Exception (Excep);
 607
 608       --  Now, un a forced unwind to trigger cleanups. Control should not
 609       --  resume there, if there are cleanups and in any cases as the
 610       --  unwinding hook calls Unhandled_Exception_Terminate when end of
 611       --  stack is reached.
 612
 613       Unwind_ForcedUnwind
 614         (GCC_Exception,
 615          CleanupUnwind_Handler'Address,
 616          System.Null_Address);
 617
 618       --  We get here in case of error. The debugger has been notified before
 619       --  the second step above.
 620
 621       Unhandled_Except_Handler (GCC_Exception);
 622    end Propagate_GCC_Exception;
 623
 624    -------------------------
 625    -- Propagate_Exception --
 626    -------------------------
 627
 628    procedure Propagate_Exception (Excep : Exception_Occurrence) is
 629    begin
 630       Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
 631    end Propagate_Exception;
 632
 633    -----------------------------
 634    -- Set_Exception_Parameter --
 635    -----------------------------
 636
 637    procedure Set_Exception_Parameter
 638      (Excep         : EOA;
 639       GCC_Exception : not null GCC_Exception_Access)
 640    is
 641    begin
 642       --  Setup the exception occurrence
 643
 644       if GCC_Exception.Class = GNAT_Exception_Class then
 645
 646          --  From the GCC exception
 647
 648          declare
 649             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 650                                 To_GNAT_GCC_Exception (GCC_Exception);
 651          begin
 652             Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
 653          end;
 654
 655       else
 656          --  A default one
 657
 658          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 659       end if;
 660    end Set_Exception_Parameter;
 661
 662    ------------------------------
 663    -- Unhandled_Except_Handler --
 664    ------------------------------
 665
 666    procedure Unhandled_Except_Handler
 667      (GCC_Exception : not null GCC_Exception_Access)
 668    is
 669       Excep : EOA;
 670    begin
 671       Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE);
 672       Unhandled_Exception_Terminate (Excep);
 673    end Unhandled_Except_Handler;
 674
 675    -------------
 676    -- EID_For --
 677    -------------
 678
 679    function EID_For
 680      (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
 681    is
 682    begin
 683       return GNAT_Exception.Occurrence.Id;
 684    end EID_For;
 685
 686    ----------------------
 687    -- Foreign_Data_For --
 688    ----------------------
 689
 690    function Foreign_Data_For (E : Exception_Data_Ptr) return Address is
 691    begin
 692       return E.Foreign_Data;
 693    end Foreign_Data_For;
 694
 695    --------------------------
 696    -- Is_Handled_By_Others --
 697    --------------------------
 698
 699    function Is_Handled_By_Others (E : Exception_Data_Ptr) return bool is
 700    begin
 701       return not bool (E.all.Not_Handled_By_Others);
 702    end Is_Handled_By_Others;
 703
 704    ------------------
 705    -- Language_For --
 706    ------------------
 707
 708    function Language_For (E : Exception_Data_Ptr) return Character is
 709    begin
 710       return E.all.Lang;
 711    end Language_For;
 712
 713 end Exception_Propagation;