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