gcc/ada/a-except.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       A D A . E X C E P T I O N S                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, 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 version of Ada.Exceptions is a full Ada 95 version, and Ada 2005
  33 --  features such as the additional definitions of Exception_Name returning
  34 --  Wide_[Wide_]String.
  35
  36 --  It is used for building the compiler and the basic tools, since these
  37 --  builds may be done with bootstrap compilers that cannot handle these
  38 --  additions. The full version of Ada.Exceptions can be found in the files
  39 --  a-except-2005.ads/adb, and is used for all other builds where full Ada
  40 --  2005 functionality is required. In particular, it is used for building
  41 --  run times on all targets.
  42
  43 pragma Compiler_Unit;
  44
  45 pragma Style_Checks (All_Checks);
  46 --  No subprogram ordering check, due to logical grouping
  47
  48 pragma Polling (Off);
  49 --  We must turn polling off for this unit, because otherwise we get
  50 --  elaboration circularities with System.Exception_Tables.
  51
  52 with System;                  use System;
  53 with System.Exceptions_Debug; use System.Exceptions_Debug;
  54 with System.Standard_Library; use System.Standard_Library;
  55 with System.Soft_Links;       use System.Soft_Links;
  56
  57 package body Ada.Exceptions is
  58
  59    pragma Suppress (All_Checks);
  60    --  We definitely do not want exceptions occurring within this unit, or we
  61    --  are in big trouble. If an exceptional situation does occur, better that
  62    --  it not be raised, since raising it can cause confusing chaos.
  63
  64    -----------------------
  65    -- Local Subprograms --
  66    -----------------------
  67
  68    --  Note: the exported subprograms in this package body are called directly
  69    --  from C clients using the given external name, even though they are not
  70    --  technically visible in the Ada sense.
  71
  72    procedure Process_Raise_Exception (E : Exception_Id);
  73    pragma No_Return (Process_Raise_Exception);
  74    --  This is the lowest level raise routine. It raises the exception
  75    --  referenced by Current_Excep.all in the TSD, without deferring abort
  76    --  (the caller must ensure that abort is deferred on entry).
  77
  78    procedure To_Stderr (S : String);
  79    pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
  80    --  Little routine to output string to stderr that is also used in the
  81    --  tasking run time.
  82
  83    procedure To_Stderr (C : Character);
  84    pragma Inline (To_Stderr);
  85    pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
  86    --  Little routine to output a character to stderr, used by some of the
  87    --  separate units below.
  88
  89    package Exception_Data is
  90
  91       ---------------------------------
  92       -- Exception messages routines --
  93       ---------------------------------
  94
  95       procedure Set_Exception_C_Msg
  96         (Id     : Exception_Id;
  97          Msg1   : System.Address;
  98          Line   : Integer        := 0;
  99          Column : Integer        := 0;
 100          Msg2   : System.Address := System.Null_Address);
 101       --  This routine is called to setup the exception referenced by the
 102       --  Current_Excep field in the TSD to contain the indicated Id value
 103       --  and message. Msg1 is a null terminated string which is generated
 104       --  as the exception message. If line is non-zero, then a colon and
 105       --  the decimal representation of this integer is appended to the
 106       --  message. Ditto for Column. When Msg2 is non-null, a space and this
 107       --  additional null terminated string is added to the message.
 108
 109       procedure Set_Exception_Msg
 110         (Id      : Exception_Id;
 111          Message : String);
 112       --  This routine is called to setup the exception referenced by the
 113       --  Current_Excep field in the TSD to contain the indicated Id value and
 114       --  message. Message is a string which is generated as the exception
 115       --  message.
 116
 117       --------------------------------------
 118       -- Exception information subprogram --
 119       --------------------------------------
 120
 121       function Exception_Information (X : Exception_Occurrence) return String;
 122       --  The format of the exception information is as follows:
 123       --
 124       --    Exception_Name: <exception name> (as in Exception_Name)
 125       --    Message: <message> (only if Exception_Message is empty)
 126       --    PID=nnnn (only if != 0)
 127       --    Call stack traceback locations:  (only if at least one location)
 128       --    <0xyyyyyyyy 0xyyyyyyyy ...>      (is recorded)
 129       --
 130       --  The lines are separated by a ASCII.LF character
 131       --
 132       --  The nnnn is the partition Id given as decimal digits
 133       --
 134       --  The 0x... line represents traceback program counter locations, in
 135       --  execution order with the first one being the exception location. It
 136       --  is present only
 137       --
 138       --  The Exception_Name and Message lines are omitted in the abort signal
 139       --  case, since this is not really an exception.
 140
 141       --  Note: If the format of the generated string is changed, please note
 142       --  that an equivalent modification to the routine String_To_EO must be
 143       --  made to preserve proper functioning of the stream attributes.
 144
 145       ---------------------------------------
 146       -- Exception backtracing subprograms --
 147       ---------------------------------------
 148
 149       --  What is automatically output when exception tracing is on is the
 150       --  usual exception information with the call chain backtrace possibly
 151       --  tailored by a backtrace decorator. Modifying Exception_Information
 152       --  itself is not a good idea because the decorated output is completely
 153       --  out of control and would break all our code related to the streaming
 154       --  of exceptions.  We then provide an alternative function to compute
 155       --  the possibly tailored output, which is equivalent if no decorator is
 156       --  currently set:
 157
 158       function Tailored_Exception_Information
 159         (X : Exception_Occurrence) return String;
 160       --  Exception information to be output in the case of automatic tracing
 161       --  requested through GNAT.Exception_Traces.
 162       --
 163       --  This is the same as Exception_Information if no backtrace decorator
 164       --  is currently in place. Otherwise, this is Exception_Information with
 165       --  the call chain raw addresses replaced by the result of a call to the
 166       --  current decorator provided with the call chain addresses.
 167
 168       pragma Export
 169         (Ada, Tailored_Exception_Information,
 170            "__gnat_tailored_exception_information");
 171       --  This is currently used by System.Tasking.Stages
 172
 173    end Exception_Data;
 174
 175    package Exception_Traces is
 176
 177       use Exception_Data;
 178       --  Imports Tailored_Exception_Information
 179
 180       ----------------------------------------------
 181       -- Run-Time Exception Notification Routines --
 182       ----------------------------------------------
 183
 184       --  These subprograms provide a common run-time interface to trigger the
 185       --  actions required when an exception is about to be propagated (e.g.
 186       --  user specified actions or output of exception information). They are
 187       --  exported to be usable by the Ada exception handling personality
 188       --  routine when the GCC 3 mechanism is used.
 189
 190       procedure Notify_Handled_Exception;
 191       pragma Export
 192         (C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
 193       --  This routine is called for a handled occurrence is about to be
 194       --  propagated.
 195
 196       procedure Notify_Unhandled_Exception;
 197       pragma Export
 198         (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
 199       --  This routine is called when an unhandled occurrence is about to be
 200       --  propagated.
 201
 202       procedure Unhandled_Exception_Terminate;
 203       pragma No_Return (Unhandled_Exception_Terminate);
 204       --  This procedure is called to terminate program execution following an
 205       --  unhandled exception. The exception information, including traceback
 206       --  if available is output, and execution is then terminated. Note that
 207       --  at the point where this routine is called, the stack has typically
 208       --  been destroyed.
 209
 210    end Exception_Traces;
 211
 212    package Stream_Attributes is
 213
 214       --------------------------------
 215       -- Stream attributes routines --
 216       --------------------------------
 217
 218       function EId_To_String (X : Exception_Id) return String;
 219       function String_To_EId (S : String) return Exception_Id;
 220       --  Functions for implementing Exception_Id stream attributes
 221
 222       function EO_To_String (X : Exception_Occurrence) return String;
 223       function String_To_EO (S : String) return Exception_Occurrence;
 224       --  Functions for implementing Exception_Occurrence stream
 225       --  attributes
 226
 227    end Stream_Attributes;
 228
 229    procedure Raise_Current_Excep (E : Exception_Id);
 230    pragma No_Return (Raise_Current_Excep);
 231    pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
 232    --  This is a simple wrapper to Process_Raise_Exception.
 233    --
 234    --  This external name for Raise_Current_Excep is historical, and probably
 235    --  should be changed but for now we keep it, because gdb and gigi know
 236    --  about it.
 237
 238    procedure Raise_Exception_No_Defer
 239       (E : Exception_Id; Message : String := "");
 240    pragma Export
 241     (Ada, Raise_Exception_No_Defer,
 242      "ada__exceptions__raise_exception_no_defer");
 243    pragma No_Return (Raise_Exception_No_Defer);
 244    --  Similar to Raise_Exception, but with no abort deferral
 245
 246    procedure Raise_With_Msg (E : Exception_Id);
 247    pragma No_Return (Raise_With_Msg);
 248    pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
 249    --  Raises an exception with given exception id value. A message is
 250    --  associated with the raise, and has already been stored in the exception
 251    --  occurrence referenced by the Current_Excep in the TSD. Abort is deferred
 252    --  before the raise call.
 253
 254    procedure Raise_With_Location_And_Msg
 255      (E : Exception_Id;
 256       F : System.Address;
 257       L : Integer;
 258       M : System.Address := System.Null_Address);
 259    pragma No_Return (Raise_With_Location_And_Msg);
 260    --  Raise an exception with given exception id value. A filename and line
 261    --  number is associated with the raise and is stored in the exception
 262    --  occurrence and in addition a string message M is appended to this
 263    --  if M is not null.
 264
 265    procedure Raise_Constraint_Error
 266      (File : System.Address;
 267       Line : Integer);
 268    pragma No_Return (Raise_Constraint_Error);
 269    pragma Export
 270      (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
 271    --  Raise constraint error with file:line information
 272
 273    procedure Raise_Constraint_Error_Msg
 274      (File : System.Address;
 275       Line : Integer;
 276       Msg  : System.Address);
 277    pragma No_Return (Raise_Constraint_Error_Msg);
 278    pragma Export
 279      (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
 280    --  Raise constraint error with file:line + msg information
 281
 282    procedure Raise_Program_Error
 283      (File : System.Address;
 284       Line : Integer);
 285    pragma No_Return (Raise_Program_Error);
 286    pragma Export
 287      (C, Raise_Program_Error, "__gnat_raise_program_error");
 288    --  Raise program error with file:line information
 289
 290    procedure Raise_Program_Error_Msg
 291      (File : System.Address;
 292       Line : Integer;
 293       Msg  : System.Address);
 294    pragma No_Return (Raise_Program_Error_Msg);
 295    pragma Export
 296      (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
 297    --  Raise program error with file:line + msg information
 298
 299    procedure Raise_Storage_Error
 300      (File : System.Address;
 301       Line : Integer);
 302    pragma No_Return (Raise_Storage_Error);
 303    pragma Export
 304      (C, Raise_Storage_Error, "__gnat_raise_storage_error");
 305    --  Raise storage error with file:line information
 306
 307    procedure Raise_Storage_Error_Msg
 308      (File : System.Address;
 309       Line : Integer;
 310       Msg  : System.Address);
 311    pragma No_Return (Raise_Storage_Error_Msg);
 312    pragma Export
 313      (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
 314    --  Raise storage error with file:line + reason msg information
 315
 316    --  The exception raising process and the automatic tracing mechanism rely
 317    --  on some careful use of flags attached to the exception occurrence. The
 318    --  graph below illustrates the relations between the Raise_ subprograms
 319    --  and identifies the points where basic flags such as Exception_Raised
 320    --  are initialized.
 321    --
 322    --  (i) signs indicate the flags initialization points. R stands for Raise,
 323    --  W for With, and E for Exception.
 324    --
 325    --                   R_No_Msg    R_E   R_Pe  R_Ce  R_Se
 326    --                       |        |     |     |     |
 327    --                       +--+  +--+     +---+ | +---+
 328    --                          |  |            | | |
 329    --     R_E_No_Defer(i)    R_W_Msg(i)       R_W_Loc
 330    --           |               |              |   |
 331    --           +------------+  |  +-----------+   +--+
 332    --                        |  |  |                  |
 333    --                        |  |  |             Set_E_C_Msg(i)
 334    --                        |  |  |
 335    --                   Raise_Current_Excep
 336
 337    procedure Reraise;
 338    pragma No_Return (Reraise);
 339    pragma Export (C, Reraise, "__gnat_reraise");
 340    --  Reraises the exception referenced by the Current_Excep field of the TSD
 341    --  (all fields of this exception occurrence are set). Abort is deferred
 342    --  before the reraise operation.
 343
 344    procedure Transfer_Occurrence
 345      (Target : Exception_Occurrence_Access;
 346       Source : Exception_Occurrence);
 347    pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
 348    --  Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous
 349    --  to setup Target from Source as an exception to be propagated in the
 350    --  caller task. Target is expected to be a pointer to the fixed TSD
 351    --  occurrence for this task.
 352
 353    -----------------------------
 354    -- Run-Time Check Routines --
 355    -----------------------------
 356
 357    --  Routines to a specific exception with a reason message attached. The
 358    --  parameters are the file name and line number in each case. The names are
 359    --  keyed to the codes defined in types.ads and a-types.h (for example, the
 360    --  name Rcheck_05 refers to the Reason RT_Exception_Code'Val (5)).
 361
 362    procedure Rcheck_00 (File : System.Address; Line : Integer);
 363    procedure Rcheck_01 (File : System.Address; Line : Integer);
 364    procedure Rcheck_02 (File : System.Address; Line : Integer);
 365    procedure Rcheck_03 (File : System.Address; Line : Integer);
 366    procedure Rcheck_04 (File : System.Address; Line : Integer);
 367    procedure Rcheck_05 (File : System.Address; Line : Integer);
 368    procedure Rcheck_06 (File : System.Address; Line : Integer);
 369    procedure Rcheck_07 (File : System.Address; Line : Integer);
 370    procedure Rcheck_08 (File : System.Address; Line : Integer);
 371    procedure Rcheck_09 (File : System.Address; Line : Integer);
 372    procedure Rcheck_10 (File : System.Address; Line : Integer);
 373    procedure Rcheck_11 (File : System.Address; Line : Integer);
 374    procedure Rcheck_12 (File : System.Address; Line : Integer);
 375    procedure Rcheck_13 (File : System.Address; Line : Integer);
 376    procedure Rcheck_14 (File : System.Address; Line : Integer);
 377    procedure Rcheck_15 (File : System.Address; Line : Integer);
 378    procedure Rcheck_16 (File : System.Address; Line : Integer);
 379    procedure Rcheck_17 (File : System.Address; Line : Integer);
 380    procedure Rcheck_18 (File : System.Address; Line : Integer);
 381    procedure Rcheck_19 (File : System.Address; Line : Integer);
 382    procedure Rcheck_20 (File : System.Address; Line : Integer);
 383    procedure Rcheck_21 (File : System.Address; Line : Integer);
 384    procedure Rcheck_22 (File : System.Address; Line : Integer);
 385    procedure Rcheck_23 (File : System.Address; Line : Integer);
 386    procedure Rcheck_24 (File : System.Address; Line : Integer);
 387    procedure Rcheck_25 (File : System.Address; Line : Integer);
 388    procedure Rcheck_26 (File : System.Address; Line : Integer);
 389    procedure Rcheck_27 (File : System.Address; Line : Integer);
 390    procedure Rcheck_28 (File : System.Address; Line : Integer);
 391    procedure Rcheck_29 (File : System.Address; Line : Integer);
 392    procedure Rcheck_30 (File : System.Address; Line : Integer);
 393    procedure Rcheck_31 (File : System.Address; Line : Integer);
 394    procedure Rcheck_32 (File : System.Address; Line : Integer);
 395    procedure Rcheck_33 (File : System.Address; Line : Integer);
 396    procedure Rcheck_34 (File : System.Address; Line : Integer);
 397
 398    pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
 399    pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
 400    pragma Export (C, Rcheck_02, "__gnat_rcheck_02");
 401    pragma Export (C, Rcheck_03, "__gnat_rcheck_03");
 402    pragma Export (C, Rcheck_04, "__gnat_rcheck_04");
 403    pragma Export (C, Rcheck_05, "__gnat_rcheck_05");
 404    pragma Export (C, Rcheck_06, "__gnat_rcheck_06");
 405    pragma Export (C, Rcheck_07, "__gnat_rcheck_07");
 406    pragma Export (C, Rcheck_08, "__gnat_rcheck_08");
 407    pragma Export (C, Rcheck_09, "__gnat_rcheck_09");
 408    pragma Export (C, Rcheck_10, "__gnat_rcheck_10");
 409    pragma Export (C, Rcheck_11, "__gnat_rcheck_11");
 410    pragma Export (C, Rcheck_12, "__gnat_rcheck_12");
 411    pragma Export (C, Rcheck_13, "__gnat_rcheck_13");
 412    pragma Export (C, Rcheck_14, "__gnat_rcheck_14");
 413    pragma Export (C, Rcheck_15, "__gnat_rcheck_15");
 414    pragma Export (C, Rcheck_16, "__gnat_rcheck_16");
 415    pragma Export (C, Rcheck_17, "__gnat_rcheck_17");
 416    pragma Export (C, Rcheck_18, "__gnat_rcheck_18");
 417    pragma Export (C, Rcheck_19, "__gnat_rcheck_19");
 418    pragma Export (C, Rcheck_20, "__gnat_rcheck_20");
 419    pragma Export (C, Rcheck_21, "__gnat_rcheck_21");
 420    pragma Export (C, Rcheck_22, "__gnat_rcheck_22");
 421    pragma Export (C, Rcheck_23, "__gnat_rcheck_23");
 422    pragma Export (C, Rcheck_24, "__gnat_rcheck_24");
 423    pragma Export (C, Rcheck_25, "__gnat_rcheck_25");
 424    pragma Export (C, Rcheck_26, "__gnat_rcheck_26");
 425    pragma Export (C, Rcheck_27, "__gnat_rcheck_27");
 426    pragma Export (C, Rcheck_28, "__gnat_rcheck_28");
 427    pragma Export (C, Rcheck_29, "__gnat_rcheck_29");
 428    pragma Export (C, Rcheck_30, "__gnat_rcheck_30");
 429    pragma Export (C, Rcheck_31, "__gnat_rcheck_31");
 430    pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
 431    pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
 432    pragma Export (C, Rcheck_34, "__gnat_rcheck_34");
 433
 434    --  None of these procedures ever returns (they raise an exception!). By
 435    --  using pragma No_Return, we ensure that any junk code after the call,
 436    --  such as normal return epilog stuff, can be eliminated).
 437
 438    pragma No_Return (Rcheck_00);
 439    pragma No_Return (Rcheck_01);
 440    pragma No_Return (Rcheck_02);
 441    pragma No_Return (Rcheck_03);
 442    pragma No_Return (Rcheck_04);
 443    pragma No_Return (Rcheck_05);
 444    pragma No_Return (Rcheck_06);
 445    pragma No_Return (Rcheck_07);
 446    pragma No_Return (Rcheck_08);
 447    pragma No_Return (Rcheck_09);
 448    pragma No_Return (Rcheck_10);
 449    pragma No_Return (Rcheck_11);
 450    pragma No_Return (Rcheck_12);
 451    pragma No_Return (Rcheck_13);
 452    pragma No_Return (Rcheck_14);
 453    pragma No_Return (Rcheck_15);
 454    pragma No_Return (Rcheck_16);
 455    pragma No_Return (Rcheck_17);
 456    pragma No_Return (Rcheck_18);
 457    pragma No_Return (Rcheck_19);
 458    pragma No_Return (Rcheck_20);
 459    pragma No_Return (Rcheck_21);
 460    pragma No_Return (Rcheck_22);
 461    pragma No_Return (Rcheck_23);
 462    pragma No_Return (Rcheck_24);
 463    pragma No_Return (Rcheck_25);
 464    pragma No_Return (Rcheck_26);
 465    pragma No_Return (Rcheck_27);
 466    pragma No_Return (Rcheck_28);
 467    pragma No_Return (Rcheck_29);
 468    pragma No_Return (Rcheck_30);
 469    pragma No_Return (Rcheck_32);
 470    pragma No_Return (Rcheck_33);
 471    pragma No_Return (Rcheck_34);
 472
 473    ---------------------------------------------
 474    -- Reason Strings for Run-Time Check Calls --
 475    ---------------------------------------------
 476
 477    --  These strings are null-terminated and are used by Rcheck_nn. The
 478    --  strings correspond to the definitions for Types.RT_Exception_Code.
 479
 480    use ASCII;
 481
 482    Rmsg_00 : constant String := "access check failed"              & NUL;
 483    Rmsg_01 : constant String := "access parameter is null"         & NUL;
 484    Rmsg_02 : constant String := "discriminant check failed"        & NUL;
 485    Rmsg_03 : constant String := "divide by zero"                   & NUL;
 486    Rmsg_04 : constant String := "explicit raise"                   & NUL;
 487    Rmsg_05 : constant String := "index check failed"               & NUL;
 488    Rmsg_06 : constant String := "invalid data"                     & NUL;
 489    Rmsg_07 : constant String := "length check failed"              & NUL;
 490    Rmsg_08 : constant String := "null Exception_Id"                & NUL;
 491    Rmsg_09 : constant String := "null-exclusion check failed"      & NUL;
 492    Rmsg_10 : constant String := "overflow check failed"            & NUL;
 493    Rmsg_11 : constant String := "partition check failed"           & NUL;
 494    Rmsg_12 : constant String := "range check failed"               & NUL;
 495    Rmsg_13 : constant String := "tag check failed"                 & NUL;
 496    Rmsg_14 : constant String := "access before elaboration"        & NUL;
 497    Rmsg_15 : constant String := "accessibility check failed"       & NUL;
 498    Rmsg_16 : constant String := "attempt to take address of"       &
 499                                 " intrinsic subprogram"            & NUL;
 500    Rmsg_17 : constant String := "all guards closed"                & NUL;
 501    Rmsg_18 : constant String := "improper use of generic subtype"  &
 502                                 " with predicate"                  & NUL;
 503    Rmsg_19 : constant String := "Current_Task referenced in entry" &
 504                                 " body"                            & NUL;
 505    Rmsg_20 : constant String := "duplicated entry address"         & NUL;
 506    Rmsg_21 : constant String := "explicit raise"                   & NUL;
 507    Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL;
 508    Rmsg_23 : constant String := "implicit return with No_Return"   & NUL;
 509    Rmsg_24 : constant String := "misaligned address value"         & NUL;
 510    Rmsg_25 : constant String := "missing return"                   & NUL;
 511    Rmsg_26 : constant String := "overlaid controlled object"       & NUL;
 512    Rmsg_27 : constant String := "potentially blocking operation"   & NUL;
 513    Rmsg_28 : constant String := "stubbed subprogram called"        & NUL;
 514    Rmsg_29 : constant String := "unchecked union restriction"      & NUL;
 515    Rmsg_30 : constant String := "actual/returned class-wide"       &
 516                                 " value not transportable"         & NUL;
 517    Rmsg_31 : constant String := "empty storage pool"               & NUL;
 518    Rmsg_32 : constant String := "explicit raise"                   & NUL;
 519    Rmsg_33 : constant String := "infinite recursion"               & NUL;
 520    Rmsg_34 : constant String := "object too large"                 & NUL;
 521
 522    -----------------------
 523    -- Polling Interface --
 524    -----------------------
 525
 526    type Unsigned is mod 2 ** 32;
 527
 528    Counter : Unsigned := 0;
 529    pragma Warnings (Off, Counter);
 530    --  This counter is provided for convenience. It can be used in Poll to
 531    --  perform periodic but not systematic operations.
 532
 533    procedure Poll is separate;
 534    --  The actual polling routine is separate, so that it can easily be
 535    --  replaced with a target dependent version.
 536
 537    ------------------------------
 538    -- Current_Target_Exception --
 539    ------------------------------
 540
 541    function Current_Target_Exception return Exception_Occurrence is
 542    begin
 543       return Null_Occurrence;
 544    end Current_Target_Exception;
 545
 546    -------------------
 547    -- EId_To_String --
 548    -------------------
 549
 550    function EId_To_String (X : Exception_Id) return String
 551      renames Stream_Attributes.EId_To_String;
 552
 553    ------------------
 554    -- EO_To_String --
 555    ------------------
 556
 557    --  We use the null string to represent the null occurrence, otherwise we
 558    --  output the Exception_Information string for the occurrence.
 559
 560    function EO_To_String (X : Exception_Occurrence) return String
 561      renames Stream_Attributes.EO_To_String;
 562
 563    ------------------------
 564    -- Exception_Identity --
 565    ------------------------
 566
 567    function Exception_Identity
 568      (X : Exception_Occurrence) return Exception_Id
 569    is
 570    begin
 571       --  Note that the following test used to be here for the original Ada 95
 572       --  semantics, but these were modified by AI-241 to require returning
 573       --  Null_Id instead of raising Constraint_Error.
 574
 575       --  if X.Id = Null_Id then
 576       --     raise Constraint_Error;
 577       --  end if;
 578
 579       return X.Id;
 580    end Exception_Identity;
 581
 582    ---------------------------
 583    -- Exception_Information --
 584    ---------------------------
 585
 586    function Exception_Information (X : Exception_Occurrence) return String is
 587    begin
 588       if X.Id = Null_Id then
 589          raise Constraint_Error;
 590       end if;
 591
 592       return Exception_Data.Exception_Information (X);
 593    end Exception_Information;
 594
 595    -----------------------
 596    -- Exception_Message --
 597    -----------------------
 598
 599    function Exception_Message (X : Exception_Occurrence) return String is
 600    begin
 601       if X.Id = Null_Id then
 602          raise Constraint_Error;
 603       end if;
 604
 605       return X.Msg (1 .. X.Msg_Length);
 606    end Exception_Message;
 607
 608    --------------------
 609    -- Exception_Name --
 610    --------------------
 611
 612    function Exception_Name (Id : Exception_Id) return String is
 613    begin
 614       if Id = null then
 615          raise Constraint_Error;
 616       end if;
 617
 618       return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
 619    end Exception_Name;
 620
 621    function Exception_Name (X : Exception_Occurrence) return String is
 622    begin
 623       return Exception_Name (X.Id);
 624    end Exception_Name;
 625
 626    ---------------------------
 627    -- Exception_Name_Simple --
 628    ---------------------------
 629
 630    function Exception_Name_Simple (X : Exception_Occurrence) return String is
 631       Name : constant String := Exception_Name (X);
 632       P    : Natural;
 633
 634    begin
 635       P := Name'Length;
 636       while P > 1 loop
 637          exit when Name (P - 1) = '.';
 638          P := P - 1;
 639       end loop;
 640
 641       --  Return result making sure lower bound is 1
 642
 643       declare
 644          subtype Rname is String (1 .. Name'Length - P + 1);
 645       begin
 646          return Rname (Name (P .. Name'Length));
 647       end;
 648    end Exception_Name_Simple;
 649
 650    --------------------
 651    -- Exception_Data --
 652    --------------------
 653
 654    package body Exception_Data is separate;
 655    --  This package can be easily dummied out if we do not want the basic
 656    --  support for exception messages (such as in Ada 83).
 657
 658    ----------------------
 659    -- Exception_Traces --
 660    ----------------------
 661
 662    package body Exception_Traces is separate;
 663    --  Depending on the underlying support for IO the implementation will
 664    --  differ. Moreover we would like to dummy out this package in case we do
 665    --  not want any exception tracing support. This is why this package is
 666    --  separated.
 667
 668    -----------------------
 669    -- Stream Attributes --
 670    -----------------------
 671
 672    package body Stream_Attributes is separate;
 673    --  This package can be easily dummied out if we do not want the
 674    --  support for streaming Exception_Ids and Exception_Occurrences.
 675
 676    -----------------------------
 677    -- Process_Raise_Exception --
 678    -----------------------------
 679
 680    procedure Process_Raise_Exception (E : Exception_Id) is
 681       pragma Inspection_Point (E);
 682       --  This is so the debugger can reliably inspect the parameter
 683
 684       Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
 685       Excep       : constant EOA := Get_Current_Excep.all;
 686
 687       procedure builtin_longjmp (buffer : Address; Flag : Integer);
 688       pragma No_Return (builtin_longjmp);
 689       pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
 690
 691    begin
 692       --  WARNING: There should be no exception handler for this body because
 693       --  this would cause gigi to prepend a setup for a new jmpbuf to the
 694       --  sequence of statements in case of built-in sjljl. We would then
 695       --  always get this new buf in Jumpbuf_Ptr instead of the one for the
 696       --  exception we are handling, which would completely break the whole
 697       --  design of this procedure.
 698
 699       --  If the jump buffer pointer is non-null, transfer control using it.
 700       --  Otherwise announce an unhandled exception (note that this means that
 701       --  we have no finalizations to do other than at the outer level).
 702       --  Perform the necessary notification tasks in both cases.
 703
 704       if Jumpbuf_Ptr /= Null_Address then
 705          if not Excep.Exception_Raised then
 706             Excep.Exception_Raised := True;
 707             Exception_Traces.Notify_Handled_Exception;
 708          end if;
 709
 710          builtin_longjmp (Jumpbuf_Ptr, 1);
 711
 712       else
 713          Exception_Traces.Notify_Unhandled_Exception;
 714          Exception_Traces.Unhandled_Exception_Terminate;
 715       end if;
 716    end Process_Raise_Exception;
 717
 718    ----------------------------
 719    -- Raise_Constraint_Error --
 720    ----------------------------
 721
 722    procedure Raise_Constraint_Error
 723      (File : System.Address;
 724       Line : Integer)
 725    is
 726    begin
 727       Raise_With_Location_And_Msg
 728         (Constraint_Error_Def'Access, File, Line);
 729    end Raise_Constraint_Error;
 730
 731    --------------------------------
 732    -- Raise_Constraint_Error_Msg --
 733    --------------------------------
 734
 735    procedure Raise_Constraint_Error_Msg
 736      (File : System.Address;
 737       Line : Integer;
 738       Msg  : System.Address)
 739    is
 740    begin
 741       Raise_With_Location_And_Msg
 742         (Constraint_Error_Def'Access, File, Line, Msg);
 743    end Raise_Constraint_Error_Msg;
 744
 745    -------------------------
 746    -- Raise_Current_Excep --
 747    -------------------------
 748
 749    procedure Raise_Current_Excep (E : Exception_Id) is
 750
 751       pragma Inspection_Point (E);
 752       --  This is so the debugger can reliably inspect the parameter when
 753       --  inserting a breakpoint at the start of this procedure.
 754
 755       Id : Exception_Id := E;
 756       pragma Volatile (Id);
 757       pragma Warnings (Off, Id);
 758       --  In order to provide support for breakpoints on unhandled exceptions,
 759       --  the debugger will also need to be able to inspect the value of E from
 760       --  another (inner) frame. So we need to make sure that if E is passed in
 761       --  a register, its value is also spilled on stack. For this, we store
 762       --  the parameter value in a local variable, and add a pragma Volatile to
 763       --  make sure it is spilled. The pragma Warnings (Off) is needed because
 764       --  the compiler knows that Id is not referenced and that this use of
 765       --  pragma Volatile is peculiar!
 766
 767    begin
 768       Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
 769       Process_Raise_Exception (E);
 770    end Raise_Current_Excep;
 771
 772    ---------------------
 773    -- Raise_Exception --
 774    ---------------------
 775
 776    procedure Raise_Exception
 777      (E       : Exception_Id;
 778       Message : String := "")
 779    is
 780       EF : Exception_Id := E;
 781
 782    begin
 783       --  Raise CE if E = Null_ID (AI-446)
 784
 785       if E = null then
 786          EF := Constraint_Error'Identity;
 787       end if;
 788
 789       --  Go ahead and raise appropriate exception
 790
 791       Exception_Data.Set_Exception_Msg (EF, Message);
 792       Abort_Defer.all;
 793       Raise_Current_Excep (EF);
 794    end Raise_Exception;
 795
 796    ----------------------------
 797    -- Raise_Exception_Always --
 798    ----------------------------
 799
 800    procedure Raise_Exception_Always
 801      (E       : Exception_Id;
 802       Message : String := "")
 803    is
 804    begin
 805       Exception_Data.Set_Exception_Msg (E, Message);
 806       Abort_Defer.all;
 807       Raise_Current_Excep (E);
 808    end Raise_Exception_Always;
 809
 810    ------------------------------
 811    -- Raise_Exception_No_Defer --
 812    ------------------------------
 813
 814    procedure Raise_Exception_No_Defer
 815      (E       : Exception_Id;
 816       Message : String := "")
 817    is
 818    begin
 819       Exception_Data.Set_Exception_Msg (E, Message);
 820
 821       --  Do not call Abort_Defer.all, as specified by the spec
 822
 823       Raise_Current_Excep (E);
 824    end Raise_Exception_No_Defer;
 825
 826    -------------------------------------
 827    -- Raise_From_Controlled_Operation --
 828    -------------------------------------
 829
 830    procedure Raise_From_Controlled_Operation
 831      (X : Ada.Exceptions.Exception_Occurrence)
 832    is
 833       Prefix             : constant String := "adjust/finalize raised ";
 834       Orig_Msg           : constant String := Exception_Message (X);
 835       Orig_Prefix_Length : constant Natural :=
 836                              Integer'Min (Prefix'Length, Orig_Msg'Length);
 837       Orig_Prefix        : String renames Orig_Msg
 838                             (Orig_Msg'First ..
 839                              Orig_Msg'First + Orig_Prefix_Length - 1);
 840    begin
 841       --  Message already has proper prefix, just re-reraise
 842
 843       if Orig_Prefix = Prefix then
 844          Raise_Exception_No_Defer
 845            (E       => Program_Error'Identity,
 846             Message => Orig_Msg);
 847
 848       else
 849          declare
 850             New_Msg  : constant String := Prefix & Exception_Name (X);
 851
 852          begin
 853             --  No message present, just provide our own
 854
 855             if Orig_Msg = "" then
 856                Raise_Exception_No_Defer
 857                  (E       => Program_Error'Identity,
 858                   Message => New_Msg);
 859
 860             --  Message present, add informational prefix
 861
 862             else
 863                Raise_Exception_No_Defer
 864                  (E       => Program_Error'Identity,
 865                   Message => New_Msg & ": " & Orig_Msg);
 866             end if;
 867          end;
 868       end if;
 869    end Raise_From_Controlled_Operation;
 870
 871    -------------------------------
 872    -- Raise_From_Signal_Handler --
 873    -------------------------------
 874
 875    procedure Raise_From_Signal_Handler
 876      (E : Exception_Id;
 877       M : System.Address)
 878    is
 879    begin
 880       Exception_Data.Set_Exception_C_Msg (E, M);
 881       Abort_Defer.all;
 882       Process_Raise_Exception (E);
 883    end Raise_From_Signal_Handler;
 884
 885    -------------------------
 886    -- Raise_Program_Error --
 887    -------------------------
 888
 889    procedure Raise_Program_Error
 890      (File : System.Address;
 891       Line : Integer)
 892    is
 893    begin
 894       Raise_With_Location_And_Msg
 895         (Program_Error_Def'Access, File, Line);
 896    end Raise_Program_Error;
 897
 898    -----------------------------
 899    -- Raise_Program_Error_Msg --
 900    -----------------------------
 901
 902    procedure Raise_Program_Error_Msg
 903      (File : System.Address;
 904       Line : Integer;
 905       Msg  : System.Address)
 906    is
 907    begin
 908       Raise_With_Location_And_Msg
 909         (Program_Error_Def'Access, File, Line, Msg);
 910    end Raise_Program_Error_Msg;
 911
 912    -------------------------
 913    -- Raise_Storage_Error --
 914    -------------------------
 915
 916    procedure Raise_Storage_Error
 917      (File : System.Address;
 918       Line : Integer)
 919    is
 920    begin
 921       Raise_With_Location_And_Msg
 922         (Storage_Error_Def'Access, File, Line);
 923    end Raise_Storage_Error;
 924
 925    -----------------------------
 926    -- Raise_Storage_Error_Msg --
 927    -----------------------------
 928
 929    procedure Raise_Storage_Error_Msg
 930      (File : System.Address;
 931       Line : Integer;
 932       Msg  : System.Address)
 933    is
 934    begin
 935       Raise_With_Location_And_Msg
 936         (Storage_Error_Def'Access, File, Line, Msg);
 937    end Raise_Storage_Error_Msg;
 938
 939    ---------------------------------
 940    -- Raise_With_Location_And_Msg --
 941    ---------------------------------
 942
 943    procedure Raise_With_Location_And_Msg
 944      (E : Exception_Id;
 945       F : System.Address;
 946       L : Integer;
 947       M : System.Address := System.Null_Address)
 948    is
 949    begin
 950       Exception_Data.Set_Exception_C_Msg (E, F, L, Msg2 => M);
 951       Abort_Defer.all;
 952       Raise_Current_Excep (E);
 953    end Raise_With_Location_And_Msg;
 954
 955    --------------------
 956    -- Raise_With_Msg --
 957    --------------------
 958
 959    procedure Raise_With_Msg (E : Exception_Id) is
 960       Excep : constant EOA := Get_Current_Excep.all;
 961
 962    begin
 963       Excep.Exception_Raised := False;
 964       Excep.Id               := E;
 965       Excep.Num_Tracebacks   := 0;
 966       Excep.Pid              := Local_Partition_ID;
 967       Abort_Defer.all;
 968       Raise_Current_Excep (E);
 969    end Raise_With_Msg;
 970
 971    --------------------------------------
 972    -- Calls to Run-Time Check Routines --
 973    --------------------------------------
 974
 975    procedure Rcheck_00 (File : System.Address; Line : Integer) is
 976    begin
 977       Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address);
 978    end Rcheck_00;
 979
 980    procedure Rcheck_01 (File : System.Address; Line : Integer) is
 981    begin
 982       Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address);
 983    end Rcheck_01;
 984
 985    procedure Rcheck_02 (File : System.Address; Line : Integer) is
 986    begin
 987       Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address);
 988    end Rcheck_02;
 989
 990    procedure Rcheck_03 (File : System.Address; Line : Integer) is
 991    begin
 992       Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address);
 993    end Rcheck_03;
 994
 995    procedure Rcheck_04 (File : System.Address; Line : Integer) is
 996    begin
 997       Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address);
 998    end Rcheck_04;
 999
1000    procedure Rcheck_05 (File : System.Address; Line : Integer) is
1001    begin
1002       Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address);
1003    end Rcheck_05;
1004
1005    procedure Rcheck_06 (File : System.Address; Line : Integer) is
1006    begin
1007       Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address);
1008    end Rcheck_06;
1009
1010    procedure Rcheck_07 (File : System.Address; Line : Integer) is
1011    begin
1012       Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address);
1013    end Rcheck_07;
1014
1015    procedure Rcheck_08 (File : System.Address; Line : Integer) is
1016    begin
1017       Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address);
1018    end Rcheck_08;
1019
1020    procedure Rcheck_09 (File : System.Address; Line : Integer) is
1021    begin
1022       Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address);
1023    end Rcheck_09;
1024
1025    procedure Rcheck_10 (File : System.Address; Line : Integer) is
1026    begin
1027       Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address);
1028    end Rcheck_10;
1029
1030    procedure Rcheck_11 (File : System.Address; Line : Integer) is
1031    begin
1032       Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address);
1033    end Rcheck_11;
1034
1035    procedure Rcheck_12 (File : System.Address; Line : Integer) is
1036    begin
1037       Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address);
1038    end Rcheck_12;
1039
1040    procedure Rcheck_13 (File : System.Address; Line : Integer) is
1041    begin
1042       Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address);
1043    end Rcheck_13;
1044
1045    procedure Rcheck_14 (File : System.Address; Line : Integer) is
1046    begin
1047       Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
1048    end Rcheck_14;
1049
1050    procedure Rcheck_15 (File : System.Address; Line : Integer) is
1051    begin
1052       Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
1053    end Rcheck_15;
1054
1055    procedure Rcheck_16 (File : System.Address; Line : Integer) is
1056    begin
1057       Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
1058    end Rcheck_16;
1059
1060    procedure Rcheck_17 (File : System.Address; Line : Integer) is
1061    begin
1062       Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
1063    end Rcheck_17;
1064
1065    procedure Rcheck_18 (File : System.Address; Line : Integer) is
1066    begin
1067       Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
1068    end Rcheck_18;
1069
1070    procedure Rcheck_19 (File : System.Address; Line : Integer) is
1071    begin
1072       Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
1073    end Rcheck_19;
1074
1075    procedure Rcheck_20 (File : System.Address; Line : Integer) is
1076    begin
1077       Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
1078    end Rcheck_20;
1079
1080    procedure Rcheck_21 (File : System.Address; Line : Integer) is
1081    begin
1082       Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
1083    end Rcheck_21;
1084
1085    procedure Rcheck_22 (File : System.Address; Line : Integer) is
1086       E : constant Exception_Id := Program_Error_Def'Access;
1087    begin
1088       --  This is "finalize/adjust raised exception".
1089       --  As this exception is only raised with aborts defered, it must
1090       --  call Raise_Exception_No_Defer, contrary to all other Rcheck
1091       --  subprograms (which defer aborts).
1092       --  This is coherent with Raise_From_Controlled_Operation.
1093
1094       Exception_Data.Set_Exception_C_Msg (E, File, Line, 0, Rmsg_22'Address);
1095       Raise_Current_Excep (E);
1096    end Rcheck_22;
1097
1098    procedure Rcheck_23 (File : System.Address; Line : Integer) is
1099    begin
1100       Raise_Program_Error_Msg (File, Line, Rmsg_23'Address);
1101    end Rcheck_23;
1102
1103    procedure Rcheck_24 (File : System.Address; Line : Integer) is
1104    begin
1105       Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
1106    end Rcheck_24;
1107
1108    procedure Rcheck_25 (File : System.Address; Line : Integer) is
1109    begin
1110       Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
1111    end Rcheck_25;
1112
1113    procedure Rcheck_26 (File : System.Address; Line : Integer) is
1114    begin
1115       Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
1116    end Rcheck_26;
1117
1118    procedure Rcheck_27 (File : System.Address; Line : Integer) is
1119    begin
1120       Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
1121    end Rcheck_27;
1122
1123    procedure Rcheck_28 (File : System.Address; Line : Integer) is
1124    begin
1125       Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
1126    end Rcheck_28;
1127
1128    procedure Rcheck_29 (File : System.Address; Line : Integer) is
1129    begin
1130       Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
1131    end Rcheck_29;
1132
1133    procedure Rcheck_30 (File : System.Address; Line : Integer) is
1134    begin
1135       Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
1136    end Rcheck_30;
1137
1138    procedure Rcheck_31 (File : System.Address; Line : Integer) is
1139    begin
1140       Raise_Storage_Error_Msg (File, Line, Rmsg_31'Address);
1141    end Rcheck_31;
1142
1143    procedure Rcheck_32 (File : System.Address; Line : Integer) is
1144    begin
1145       Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
1146    end Rcheck_32;
1147
1148    procedure Rcheck_33 (File : System.Address; Line : Integer) is
1149    begin
1150       Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
1151    end Rcheck_33;
1152
1153    procedure Rcheck_34 (File : System.Address; Line : Integer) is
1154    begin
1155       Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
1156    end Rcheck_34;
1157
1158    -------------
1159    -- Reraise --
1160    -------------
1161
1162    procedure Reraise is
1163       Excep : constant EOA := Get_Current_Excep.all;
1164
1165    begin
1166       Abort_Defer.all;
1167       Raise_Current_Excep (Excep.Id);
1168    end Reraise;
1169
1170    ------------------------
1171    -- Reraise_Occurrence --
1172    ------------------------
1173
1174    procedure Reraise_Occurrence (X : Exception_Occurrence) is
1175    begin
1176       if X.Id /= null then
1177          Abort_Defer.all;
1178          Save_Occurrence (Get_Current_Excep.all.all, X);
1179          Raise_Current_Excep (X.Id);
1180       end if;
1181    end Reraise_Occurrence;
1182
1183    -------------------------------
1184    -- Reraise_Occurrence_Always --
1185    -------------------------------
1186
1187    procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
1188    begin
1189       Abort_Defer.all;
1190       Save_Occurrence (Get_Current_Excep.all.all, X);
1191       Raise_Current_Excep (X.Id);
1192    end Reraise_Occurrence_Always;
1193
1194    ---------------------------------
1195    -- Reraise_Occurrence_No_Defer --
1196    ---------------------------------
1197
1198    procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
1199    begin
1200       Save_Occurrence (Get_Current_Excep.all.all, X);
1201       Raise_Current_Excep (X.Id);
1202    end Reraise_Occurrence_No_Defer;
1203
1204    ---------------------
1205    -- Save_Occurrence --
1206    ---------------------
1207
1208    procedure Save_Occurrence
1209      (Target : out Exception_Occurrence;
1210       Source : Exception_Occurrence)
1211    is
1212    begin
1213       Target.Id             := Source.Id;
1214       Target.Msg_Length     := Source.Msg_Length;
1215       Target.Num_Tracebacks := Source.Num_Tracebacks;
1216       Target.Pid            := Source.Pid;
1217
1218       Target.Msg (1 .. Target.Msg_Length) :=
1219         Source.Msg (1 .. Target.Msg_Length);
1220
1221       Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
1222         Source.Tracebacks (1 .. Target.Num_Tracebacks);
1223    end Save_Occurrence;
1224
1225    function Save_Occurrence (Source : Exception_Occurrence) return EOA is
1226       Target : constant EOA := new Exception_Occurrence;
1227    begin
1228       Save_Occurrence (Target.all, Source);
1229       return Target;
1230    end Save_Occurrence;
1231
1232    -------------------
1233    -- String_To_EId --
1234    -------------------
1235
1236    function String_To_EId (S : String) return Exception_Id
1237      renames Stream_Attributes.String_To_EId;
1238
1239    ------------------
1240    -- String_To_EO --
1241    ------------------
1242
1243    function String_To_EO (S : String) return Exception_Occurrence
1244      renames Stream_Attributes.String_To_EO;
1245
1246    ---------------
1247    -- To_Stderr --
1248    ---------------
1249
1250    procedure To_Stderr (C : Character) is
1251       type int is new Integer;
1252
1253       procedure put_char_stderr (C : int);
1254       pragma Import (C, put_char_stderr, "put_char_stderr");
1255
1256    begin
1257       put_char_stderr (Character'Pos (C));
1258    end To_Stderr;
1259
1260    procedure To_Stderr (S : String) is
1261    begin
1262       for J in S'Range loop
1263          if S (J) /= ASCII.CR then
1264             To_Stderr (S (J));
1265          end if;
1266       end loop;
1267    end To_Stderr;
1268
1269    -------------------------
1270    -- Transfer_Occurrence --
1271    -------------------------
1272
1273    procedure Transfer_Occurrence
1274      (Target : Exception_Occurrence_Access;
1275       Source : Exception_Occurrence)
1276    is
1277    begin
1278       Save_Occurrence (Target.all, Source);
1279    end Transfer_Occurrence;
1280
1281    ------------------------
1282    -- Triggered_By_Abort --
1283    ------------------------
1284
1285    function Triggered_By_Abort return Boolean is
1286       Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
1287    begin
1288       return Ex /= null
1289         and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
1290    end Triggered_By_Abort;
1291
1292 end Ada.Exceptions;