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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This version of Ada.Exceptions is a full Ada 95 version, and Ada 2005
  35 --  features such as the additional definitions of Exception_Name returning
  36 --  Wide_[Wide_]String.
  37
  38 --  It is used for building the compiler and the basic tools, since these
  39 --  builds may be done with bootstrap compilers that cannot handle these
  40 --  additions. The full version of Ada.Exceptions can be found in the files
  41 --  a-except-2005.ads/adb, and is used for all other builds where full Ada
  42 --  2005 functionality is required. in particular, it is used for building
  43 --  run times on all targets.
  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, wether 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 are called from the runtime to raise a specific
 377    --  exception with a reason message attached. The parameters are
 378    --  the file name and line number in each case. The names are keyed
 379    --  to the codes defined in Types.ads and a-types.h (for example,
 380    --  the name Rcheck_05 refers to the Reason whose Pos code is 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
 416    pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
 417    pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
 418    pragma Export (C, Rcheck_02, "__gnat_rcheck_02");
 419    pragma Export (C, Rcheck_03, "__gnat_rcheck_03");
 420    pragma Export (C, Rcheck_04, "__gnat_rcheck_04");
 421    pragma Export (C, Rcheck_05, "__gnat_rcheck_05");
 422    pragma Export (C, Rcheck_06, "__gnat_rcheck_06");
 423    pragma Export (C, Rcheck_07, "__gnat_rcheck_07");
 424    pragma Export (C, Rcheck_08, "__gnat_rcheck_08");
 425    pragma Export (C, Rcheck_09, "__gnat_rcheck_09");
 426    pragma Export (C, Rcheck_10, "__gnat_rcheck_10");
 427    pragma Export (C, Rcheck_11, "__gnat_rcheck_11");
 428    pragma Export (C, Rcheck_12, "__gnat_rcheck_12");
 429    pragma Export (C, Rcheck_13, "__gnat_rcheck_13");
 430    pragma Export (C, Rcheck_14, "__gnat_rcheck_14");
 431    pragma Export (C, Rcheck_15, "__gnat_rcheck_15");
 432    pragma Export (C, Rcheck_16, "__gnat_rcheck_16");
 433    pragma Export (C, Rcheck_17, "__gnat_rcheck_17");
 434    pragma Export (C, Rcheck_18, "__gnat_rcheck_18");
 435    pragma Export (C, Rcheck_19, "__gnat_rcheck_19");
 436    pragma Export (C, Rcheck_20, "__gnat_rcheck_20");
 437    pragma Export (C, Rcheck_21, "__gnat_rcheck_21");
 438    pragma Export (C, Rcheck_22, "__gnat_rcheck_22");
 439    pragma Export (C, Rcheck_23, "__gnat_rcheck_23");
 440    pragma Export (C, Rcheck_24, "__gnat_rcheck_24");
 441    pragma Export (C, Rcheck_25, "__gnat_rcheck_25");
 442    pragma Export (C, Rcheck_26, "__gnat_rcheck_26");
 443    pragma Export (C, Rcheck_27, "__gnat_rcheck_27");
 444    pragma Export (C, Rcheck_28, "__gnat_rcheck_28");
 445    pragma Export (C, Rcheck_29, "__gnat_rcheck_29");
 446    pragma Export (C, Rcheck_30, "__gnat_rcheck_30");
 447    pragma Export (C, Rcheck_31, "__gnat_rcheck_31");
 448    pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
 449
 450    --  None of these procedures ever returns (they raise an exception!). By
 451    --  using pragma No_Return, we ensure that any junk code after the call,
 452    --  such as normal return epilog stuff, can be eliminated).
 453
 454    pragma No_Return (Rcheck_00);
 455    pragma No_Return (Rcheck_01);
 456    pragma No_Return (Rcheck_02);
 457    pragma No_Return (Rcheck_03);
 458    pragma No_Return (Rcheck_04);
 459    pragma No_Return (Rcheck_05);
 460    pragma No_Return (Rcheck_06);
 461    pragma No_Return (Rcheck_07);
 462    pragma No_Return (Rcheck_08);
 463    pragma No_Return (Rcheck_09);
 464    pragma No_Return (Rcheck_10);
 465    pragma No_Return (Rcheck_11);
 466    pragma No_Return (Rcheck_12);
 467    pragma No_Return (Rcheck_13);
 468    pragma No_Return (Rcheck_14);
 469    pragma No_Return (Rcheck_15);
 470    pragma No_Return (Rcheck_16);
 471    pragma No_Return (Rcheck_17);
 472    pragma No_Return (Rcheck_18);
 473    pragma No_Return (Rcheck_19);
 474    pragma No_Return (Rcheck_20);
 475    pragma No_Return (Rcheck_21);
 476    pragma No_Return (Rcheck_22);
 477    pragma No_Return (Rcheck_23);
 478    pragma No_Return (Rcheck_24);
 479    pragma No_Return (Rcheck_25);
 480    pragma No_Return (Rcheck_26);
 481    pragma No_Return (Rcheck_27);
 482    pragma No_Return (Rcheck_28);
 483    pragma No_Return (Rcheck_29);
 484    pragma No_Return (Rcheck_30);
 485    pragma No_Return (Rcheck_32);
 486
 487    ---------------------------------------------
 488    -- Reason Strings for Run-Time Check Calls --
 489    ---------------------------------------------
 490
 491    --  These strings are null-terminated and are used by Rcheck_nn. The
 492    --  strings correspond to the definitions for Types.RT_Exception_Code.
 493
 494    use ASCII;
 495
 496    Rmsg_00 : constant String := "access check failed"              & NUL;
 497    Rmsg_01 : constant String := "access parameter is null"         & NUL;
 498    Rmsg_02 : constant String := "discriminant check failed"        & NUL;
 499    Rmsg_03 : constant String := "divide by zero"                   & NUL;
 500    Rmsg_04 : constant String := "explicit raise"                   & NUL;
 501    Rmsg_05 : constant String := "index check failed"               & NUL;
 502    Rmsg_06 : constant String := "invalid data"                     & NUL;
 503    Rmsg_07 : constant String := "length check failed"              & NUL;
 504    Rmsg_08 : constant String := "null Exception_Id"                & NUL;
 505    Rmsg_09 : constant String := "null-exclusion check failed"      & NUL;
 506    Rmsg_10 : constant String := "overflow check failed"            & NUL;
 507    Rmsg_11 : constant String := "partition check failed"           & NUL;
 508    Rmsg_12 : constant String := "range check failed"               & NUL;
 509    Rmsg_13 : constant String := "tag check failed"                 & NUL;
 510    Rmsg_14 : constant String := "access before elaboration"        & NUL;
 511    Rmsg_15 : constant String := "accessibility check failed"       & NUL;
 512    Rmsg_16 : constant String := "all guards closed"                & NUL;
 513    Rmsg_17 : constant String := "Current_Task referenced in entry" &
 514                                 " body"                            & NUL;
 515    Rmsg_18 : constant String := "duplicated entry address"         & NUL;
 516    Rmsg_19 : constant String := "explicit raise"                   & NUL;
 517    Rmsg_20 : constant String := "finalize/adjust raised exception" & NUL;
 518    Rmsg_21 : constant String := "implicit return with No_Return"   & NUL;
 519    Rmsg_22 : constant String := "misaligned address value"         & NUL;
 520    Rmsg_23 : constant String := "missing return"                   & NUL;
 521    Rmsg_24 : constant String := "overlaid controlled object"       & NUL;
 522    Rmsg_25 : constant String := "potentially blocking operation"   & NUL;
 523    Rmsg_26 : constant String := "stubbed subprogram called"        & NUL;
 524    Rmsg_27 : constant String := "unchecked union restriction"      & NUL;
 525    Rmsg_28 : constant String := "actual/returned class-wide value "
 526                                 & "not transportable"              & NUL;
 527    Rmsg_29 : constant String := "empty storage pool"               & NUL;
 528    Rmsg_30 : constant String := "explicit raise"                   & NUL;
 529    Rmsg_31 : constant String := "infinite recursion"               & NUL;
 530    Rmsg_32 : constant String := "object too large"                 & NUL;
 531
 532    -----------------------
 533    -- Polling Interface --
 534    -----------------------
 535
 536    type Unsigned is mod 2 ** 32;
 537
 538    Counter : Unsigned := 0;
 539    pragma Warnings (Off, Counter);
 540    --  This counter is provided for convenience. It can be used in Poll to
 541    --  perform periodic but not systematic operations.
 542
 543    procedure Poll is separate;
 544    --  The actual polling routine is separate, so that it can easily
 545    --  be replaced with a target dependent version.
 546
 547    ------------------------------
 548    -- Current_Target_Exception --
 549    ------------------------------
 550
 551    function Current_Target_Exception return Exception_Occurrence is
 552    begin
 553       return Null_Occurrence;
 554    end Current_Target_Exception;
 555
 556    -------------------
 557    -- EId_To_String --
 558    -------------------
 559
 560    function EId_To_String (X : Exception_Id) return String
 561      renames Stream_Attributes.EId_To_String;
 562
 563    ------------------
 564    -- EO_To_String --
 565    ------------------
 566
 567    --  We use the null string to represent the null occurrence, otherwise
 568    --  we output the Exception_Information string for the occurrence.
 569
 570    function EO_To_String (X : Exception_Occurrence) return String
 571      renames Stream_Attributes.EO_To_String;
 572
 573    ------------------------
 574    -- Exception_Identity --
 575    ------------------------
 576
 577    function Exception_Identity
 578      (X : Exception_Occurrence) return Exception_Id
 579    is
 580    begin
 581       --  Note that the following test used to be here for the original
 582       --  Ada 95 semantics, but these were modified by AI-241 to require
 583       --  returning Null_Id instead of raising Constraint_Error.
 584
 585       --  if X.Id = Null_Id then
 586       --     raise Constraint_Error;
 587       --  end if;
 588
 589       return X.Id;
 590    end Exception_Identity;
 591
 592    ---------------------------
 593    -- Exception_Information --
 594    ---------------------------
 595
 596    function Exception_Information (X : Exception_Occurrence) return String is
 597    begin
 598       if X.Id = Null_Id then
 599          raise Constraint_Error;
 600       end if;
 601
 602       return Exception_Data.Exception_Information (X);
 603    end Exception_Information;
 604
 605    -----------------------
 606    -- Exception_Message --
 607    -----------------------
 608
 609    function Exception_Message (X : Exception_Occurrence) return String is
 610    begin
 611       if X.Id = Null_Id then
 612          raise Constraint_Error;
 613       end if;
 614
 615       return X.Msg (1 .. X.Msg_Length);
 616    end Exception_Message;
 617
 618    --------------------
 619    -- Exception_Name --
 620    --------------------
 621
 622    function Exception_Name (Id : Exception_Id) return String is
 623    begin
 624       if Id = null then
 625          raise Constraint_Error;
 626       end if;
 627
 628       return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
 629    end Exception_Name;
 630
 631    function Exception_Name (X : Exception_Occurrence) return String is
 632    begin
 633       return Exception_Name (X.Id);
 634    end Exception_Name;
 635
 636    ---------------------------
 637    -- Exception_Name_Simple --
 638    ---------------------------
 639
 640    function Exception_Name_Simple (X : Exception_Occurrence) return String is
 641       Name : constant String := Exception_Name (X);
 642       P    : Natural;
 643
 644    begin
 645       P := Name'Length;
 646       while P > 1 loop
 647          exit when Name (P - 1) = '.';
 648          P := P - 1;
 649       end loop;
 650
 651       --  Return result making sure lower bound is 1
 652
 653       declare
 654          subtype Rname is String (1 .. Name'Length - P + 1);
 655       begin
 656          return Rname (Name (P .. Name'Length));
 657       end;
 658    end Exception_Name_Simple;
 659
 660    --------------------
 661    -- Exception_Data --
 662    --------------------
 663
 664    package body Exception_Data is separate;
 665    --  This package can be easily dummied out if we do not want the
 666    --  basic support for exception messages (such as in Ada 83).
 667
 668    package body Exception_Propagation is
 669
 670       procedure Setup_Exception
 671         (Excep    : EOA;
 672          Current  : EOA;
 673          Reraised : Boolean := False)
 674       is
 675          pragma Warnings (Off, Excep);
 676          pragma Warnings (Off, Current);
 677          pragma Warnings (Off, Reraised);
 678       begin
 679          null;
 680       end Setup_Exception;
 681
 682    end Exception_Propagation;
 683
 684    ----------------------
 685    -- Exception_Traces --
 686    ----------------------
 687
 688    package body Exception_Traces is separate;
 689    --  Depending on the underlying support for IO the implementation
 690    --  will differ. Moreover we would like to dummy out this package
 691    --  in case we do not want any exception tracing support. This is
 692    --  why this package is separated.
 693
 694    -----------------------
 695    -- Stream Attributes --
 696    -----------------------
 697
 698    package body Stream_Attributes is separate;
 699    --  This package can be easily dummied out if we do not want the
 700    --  support for streaming Exception_Ids and Exception_Occurrences.
 701
 702    -----------------------------
 703    -- Process_Raise_Exception --
 704    -----------------------------
 705
 706    procedure Process_Raise_Exception (E : Exception_Id) is
 707       pragma Inspection_Point (E);
 708       --  This is so the debugger can reliably inspect the parameter
 709
 710       Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
 711       Excep       : constant EOA := Get_Current_Excep.all;
 712
 713       procedure builtin_longjmp (buffer : Address; Flag : Integer);
 714       pragma No_Return (builtin_longjmp);
 715       pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
 716
 717    begin
 718       --  WARNING: There should be no exception handler for this body
 719       --  because this would cause gigi to prepend a setup for a new
 720       --  jmpbuf to the sequence of statements in case of built-in sjljl.
 721       --  We would then always get this new buf in Jumpbuf_Ptr instead of the
 722       --  one for the exception we are handling, which would completely break
 723       --  the whole design of this procedure.
 724
 725       --  If the jump buffer pointer is non-null, transfer control using
 726       --  it. Otherwise announce an unhandled exception (note that this
 727       --  means that we have no finalizations to do other than at the outer
 728       --  level). Perform the necessary notification tasks in both cases.
 729
 730       if Jumpbuf_Ptr /= Null_Address then
 731          if not Excep.Exception_Raised then
 732             Excep.Exception_Raised := True;
 733             Exception_Traces.Notify_Handled_Exception;
 734          end if;
 735
 736          builtin_longjmp (Jumpbuf_Ptr, 1);
 737
 738       else
 739          Exception_Traces.Notify_Unhandled_Exception;
 740          Exception_Traces.Unhandled_Exception_Terminate;
 741       end if;
 742    end Process_Raise_Exception;
 743
 744    ----------------------------
 745    -- Raise_Constraint_Error --
 746    ----------------------------
 747
 748    procedure Raise_Constraint_Error
 749      (File : System.Address;
 750       Line : Integer)
 751    is
 752    begin
 753       Raise_With_Location_And_Msg
 754         (Constraint_Error_Def'Access, File, Line);
 755    end Raise_Constraint_Error;
 756
 757    --------------------------------
 758    -- Raise_Constraint_Error_Msg --
 759    --------------------------------
 760
 761    procedure Raise_Constraint_Error_Msg
 762      (File : System.Address;
 763       Line : Integer;
 764       Msg  : System.Address)
 765    is
 766    begin
 767       Raise_With_Location_And_Msg
 768         (Constraint_Error_Def'Access, File, Line, Msg);
 769    end Raise_Constraint_Error_Msg;
 770
 771    -------------------------
 772    -- Raise_Current_Excep --
 773    -------------------------
 774
 775    procedure Raise_Current_Excep (E : Exception_Id) is
 776
 777       pragma Inspection_Point (E);
 778       --  This is so the debugger can reliably inspect the parameter when
 779       --  inserting a breakpoint at the start of this procedure.
 780
 781       Id : Exception_Id := E;
 782       pragma Volatile (Id);
 783       pragma Warnings (Off, Id);
 784       --  In order to provide support for breakpoints on unhandled exceptions,
 785       --  the debugger will also need to be able to inspect the value of E from
 786       --  another (inner) frame. So we need to make sure that if E is passed in
 787       --  a register, its value is also spilled on stack. For this, we store
 788       --  the parameter value in a local variable, and add a pragma Volatile to
 789       --  make sure it is spilled. The pragma Warnings (Off) is needed because
 790       --  the compiler knows that Id is not referenced and that this use of
 791       --  pragma Volatile is peculiar!
 792
 793    begin
 794       Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
 795       Process_Raise_Exception (E);
 796    end Raise_Current_Excep;
 797
 798    ---------------------
 799    -- Raise_Exception --
 800    ---------------------
 801
 802    procedure Raise_Exception
 803      (E       : Exception_Id;
 804       Message : String := "")
 805    is
 806    begin
 807       if E /= null then
 808          Exception_Data.Set_Exception_Msg (E, Message);
 809          Abort_Defer.all;
 810          Raise_Current_Excep (E);
 811       end if;
 812
 813       --  Note: if E is null then just return (Ada 95 semantics)
 814
 815       return;
 816    end Raise_Exception;
 817
 818    ----------------------------
 819    -- Raise_Exception_Always --
 820    ----------------------------
 821
 822    procedure Raise_Exception_Always
 823      (E       : Exception_Id;
 824       Message : String := "")
 825    is
 826    begin
 827       Exception_Data.Set_Exception_Msg (E, Message);
 828       Abort_Defer.all;
 829       Raise_Current_Excep (E);
 830    end Raise_Exception_Always;
 831
 832    -------------------------------------
 833    -- Raise_From_Controlled_Operation --
 834    -------------------------------------
 835
 836    procedure Raise_From_Controlled_Operation
 837      (X : Ada.Exceptions.Exception_Occurrence)
 838    is
 839       Prefix   : constant String := "adjust/finalize raised ";
 840       Orig_Msg : constant String := Exception_Message (X);
 841       New_Msg  : constant String := Prefix & Exception_Name (X);
 842
 843    begin
 844       if Orig_Msg'Length >= Prefix'Length
 845         and then
 846           Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Prefix'Length - 1) =
 847                                                                      Prefix
 848       then
 849          --  Message already has proper prefix, just re-reraise PROGRAM_ERROR
 850
 851          Raise_Exception_No_Defer
 852            (E       => Program_Error'Identity,
 853             Message => Orig_Msg);
 854
 855       elsif Orig_Msg = "" then
 856
 857          --  No message present: just provide our own
 858
 859          Raise_Exception_No_Defer
 860            (E       => Program_Error'Identity,
 861             Message => New_Msg);
 862
 863       else
 864          --  Message present, add informational prefix
 865
 866          Raise_Exception_No_Defer
 867            (E       => Program_Error'Identity,
 868             Message => New_Msg & ": " & Orig_Msg);
 869       end if;
 870    end Raise_From_Controlled_Operation;
 871
 872    -------------------------------
 873    -- Raise_From_Signal_Handler --
 874    -------------------------------
 875
 876    procedure Raise_From_Signal_Handler
 877      (E : Exception_Id;
 878       M : System.Address)
 879    is
 880    begin
 881       Exception_Data.Set_Exception_C_Msg (E, M);
 882       Abort_Defer.all;
 883       Process_Raise_Exception (E);
 884    end Raise_From_Signal_Handler;
 885
 886    -------------------------
 887    -- Raise_Program_Error --
 888    -------------------------
 889
 890    procedure Raise_Program_Error
 891      (File : System.Address;
 892       Line : Integer)
 893    is
 894    begin
 895       Raise_With_Location_And_Msg
 896         (Program_Error_Def'Access, File, Line);
 897    end Raise_Program_Error;
 898
 899    -----------------------------
 900    -- Raise_Program_Error_Msg --
 901    -----------------------------
 902
 903    procedure Raise_Program_Error_Msg
 904      (File : System.Address;
 905       Line : Integer;
 906       Msg  : System.Address)
 907    is
 908    begin
 909       Raise_With_Location_And_Msg
 910         (Program_Error_Def'Access, File, Line, Msg);
 911    end Raise_Program_Error_Msg;
 912
 913    -------------------------
 914    -- Raise_Storage_Error --
 915    -------------------------
 916
 917    procedure Raise_Storage_Error
 918      (File : System.Address;
 919       Line : Integer)
 920    is
 921    begin
 922       Raise_With_Location_And_Msg
 923         (Storage_Error_Def'Access, File, Line);
 924    end Raise_Storage_Error;
 925
 926    -----------------------------
 927    -- Raise_Storage_Error_Msg --
 928    -----------------------------
 929
 930    procedure Raise_Storage_Error_Msg
 931      (File : System.Address;
 932       Line : Integer;
 933       Msg  : System.Address)
 934    is
 935    begin
 936       Raise_With_Location_And_Msg
 937         (Storage_Error_Def'Access, File, Line, Msg);
 938    end Raise_Storage_Error_Msg;
 939
 940    ---------------------------------
 941    -- Raise_With_Location_And_Msg --
 942    ---------------------------------
 943
 944    procedure Raise_With_Location_And_Msg
 945      (E : Exception_Id;
 946       F : System.Address;
 947       L : Integer;
 948       M : System.Address := System.Null_Address)
 949    is
 950    begin
 951       Exception_Data.Set_Exception_C_Msg (E, F, L, M);
 952       Abort_Defer.all;
 953       Raise_Current_Excep (E);
 954    end Raise_With_Location_And_Msg;
 955
 956    --------------------
 957    -- Raise_With_Msg --
 958    --------------------
 959
 960    procedure Raise_With_Msg (E : Exception_Id) is
 961       Excep : constant EOA := Get_Current_Excep.all;
 962
 963    begin
 964       Excep.Exception_Raised := False;
 965       Excep.Id               := E;
 966       Excep.Num_Tracebacks   := 0;
 967       Excep.Cleanup_Flag     := False;
 968       Excep.Pid              := Local_Partition_ID;
 969       Abort_Defer.all;
 970       Raise_Current_Excep (E);
 971    end Raise_With_Msg;
 972
 973    --------------------------------------
 974    -- Calls to Run-Time Check Routines --
 975    --------------------------------------
 976
 977    procedure Rcheck_00 (File : System.Address; Line : Integer) is
 978    begin
 979       Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address);
 980    end Rcheck_00;
 981
 982    procedure Rcheck_01 (File : System.Address; Line : Integer) is
 983    begin
 984       Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address);
 985    end Rcheck_01;
 986
 987    procedure Rcheck_02 (File : System.Address; Line : Integer) is
 988    begin
 989       Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address);
 990    end Rcheck_02;
 991
 992    procedure Rcheck_03 (File : System.Address; Line : Integer) is
 993    begin
 994       Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address);
 995    end Rcheck_03;
 996
 997    procedure Rcheck_04 (File : System.Address; Line : Integer) is
 998    begin
 999       Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address);
1000    end Rcheck_04;
1001
1002    procedure Rcheck_05 (File : System.Address; Line : Integer) is
1003    begin
1004       Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address);
1005    end Rcheck_05;
1006
1007    procedure Rcheck_06 (File : System.Address; Line : Integer) is
1008    begin
1009       Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address);
1010    end Rcheck_06;
1011
1012    procedure Rcheck_07 (File : System.Address; Line : Integer) is
1013    begin
1014       Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address);
1015    end Rcheck_07;
1016
1017    procedure Rcheck_08 (File : System.Address; Line : Integer) is
1018    begin
1019       Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address);
1020    end Rcheck_08;
1021
1022    procedure Rcheck_09 (File : System.Address; Line : Integer) is
1023    begin
1024       Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address);
1025    end Rcheck_09;
1026
1027    procedure Rcheck_10 (File : System.Address; Line : Integer) is
1028    begin
1029       Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address);
1030    end Rcheck_10;
1031
1032    procedure Rcheck_11 (File : System.Address; Line : Integer) is
1033    begin
1034       Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address);
1035    end Rcheck_11;
1036
1037    procedure Rcheck_12 (File : System.Address; Line : Integer) is
1038    begin
1039       Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address);
1040    end Rcheck_12;
1041
1042    procedure Rcheck_13 (File : System.Address; Line : Integer) is
1043    begin
1044       Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address);
1045    end Rcheck_13;
1046
1047    procedure Rcheck_14 (File : System.Address; Line : Integer) is
1048    begin
1049       Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
1050    end Rcheck_14;
1051
1052    procedure Rcheck_15 (File : System.Address; Line : Integer) is
1053    begin
1054       Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
1055    end Rcheck_15;
1056
1057    procedure Rcheck_16 (File : System.Address; Line : Integer) is
1058    begin
1059       Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
1060    end Rcheck_16;
1061
1062    procedure Rcheck_17 (File : System.Address; Line : Integer) is
1063    begin
1064       Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
1065    end Rcheck_17;
1066
1067    procedure Rcheck_18 (File : System.Address; Line : Integer) is
1068    begin
1069       Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
1070    end Rcheck_18;
1071
1072    procedure Rcheck_19 (File : System.Address; Line : Integer) is
1073    begin
1074       Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
1075    end Rcheck_19;
1076
1077    procedure Rcheck_20 (File : System.Address; Line : Integer) is
1078    begin
1079       Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
1080    end Rcheck_20;
1081
1082    procedure Rcheck_21 (File : System.Address; Line : Integer) is
1083    begin
1084       Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
1085    end Rcheck_21;
1086
1087    procedure Rcheck_22 (File : System.Address; Line : Integer) is
1088    begin
1089       Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
1090    end Rcheck_22;
1091
1092    procedure Rcheck_23 (File : System.Address; Line : Integer) is
1093    begin
1094       Raise_Program_Error_Msg (File, Line, Rmsg_23'Address);
1095    end Rcheck_23;
1096
1097    procedure Rcheck_24 (File : System.Address; Line : Integer) is
1098    begin
1099       Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
1100    end Rcheck_24;
1101
1102    procedure Rcheck_25 (File : System.Address; Line : Integer) is
1103    begin
1104       Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
1105    end Rcheck_25;
1106
1107    procedure Rcheck_26 (File : System.Address; Line : Integer) is
1108    begin
1109       Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
1110    end Rcheck_26;
1111
1112    procedure Rcheck_27 (File : System.Address; Line : Integer) is
1113    begin
1114       Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
1115    end Rcheck_27;
1116
1117    procedure Rcheck_28 (File : System.Address; Line : Integer) is
1118    begin
1119       Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
1120    end Rcheck_28;
1121
1122    procedure Rcheck_29 (File : System.Address; Line : Integer) is
1123    begin
1124       Raise_Storage_Error_Msg (File, Line, Rmsg_29'Address);
1125    end Rcheck_29;
1126
1127    procedure Rcheck_30 (File : System.Address; Line : Integer) is
1128    begin
1129       Raise_Storage_Error_Msg (File, Line, Rmsg_30'Address);
1130    end Rcheck_30;
1131
1132    procedure Rcheck_31 (File : System.Address; Line : Integer) is
1133    begin
1134       Raise_Storage_Error_Msg (File, Line, Rmsg_31'Address);
1135    end Rcheck_31;
1136
1137    procedure Rcheck_32 (File : System.Address; Line : Integer) is
1138    begin
1139       Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
1140    end Rcheck_32;
1141
1142    -------------
1143    -- Reraise --
1144    -------------
1145
1146    procedure Reraise is
1147       Excep : constant EOA := Get_Current_Excep.all;
1148
1149    begin
1150       Abort_Defer.all;
1151       Raise_Current_Excep (Excep.Id);
1152    end Reraise;
1153
1154    ------------------------
1155    -- Reraise_Occurrence --
1156    ------------------------
1157
1158    procedure Reraise_Occurrence (X : Exception_Occurrence) is
1159    begin
1160       if X.Id /= null then
1161          Abort_Defer.all;
1162          Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
1163          Raise_Current_Excep (X.Id);
1164       end if;
1165    end Reraise_Occurrence;
1166
1167    -------------------------------
1168    -- Reraise_Occurrence_Always --
1169    -------------------------------
1170
1171    procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
1172    begin
1173       Abort_Defer.all;
1174       Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
1175       Raise_Current_Excep (X.Id);
1176    end Reraise_Occurrence_Always;
1177
1178    ---------------------------------
1179    -- Reraise_Occurrence_No_Defer --
1180    ---------------------------------
1181
1182    procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
1183    begin
1184       Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
1185       Raise_Current_Excep (X.Id);
1186    end Reraise_Occurrence_No_Defer;
1187
1188    ---------------------
1189    -- Save_Occurrence --
1190    ---------------------
1191
1192    procedure Save_Occurrence
1193      (Target : out Exception_Occurrence;
1194       Source : Exception_Occurrence)
1195    is
1196    begin
1197       Save_Occurrence_No_Private (Target, Source);
1198    end Save_Occurrence;
1199
1200    function Save_Occurrence (Source : Exception_Occurrence) return EOA is
1201       Target : constant EOA := new Exception_Occurrence;
1202    begin
1203       Save_Occurrence (Target.all, Source);
1204       return Target;
1205    end Save_Occurrence;
1206
1207    --------------------------------
1208    -- Save_Occurrence_No_Private --
1209    --------------------------------
1210
1211    procedure Save_Occurrence_No_Private
1212      (Target : out Exception_Occurrence;
1213       Source : Exception_Occurrence)
1214    is
1215    begin
1216       Target.Id             := Source.Id;
1217       Target.Msg_Length     := Source.Msg_Length;
1218       Target.Num_Tracebacks := Source.Num_Tracebacks;
1219       Target.Pid            := Source.Pid;
1220       Target.Cleanup_Flag   := Source.Cleanup_Flag;
1221
1222       Target.Msg (1 .. Target.Msg_Length) :=
1223         Source.Msg (1 .. Target.Msg_Length);
1224
1225       Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
1226         Source.Tracebacks (1 .. Target.Num_Tracebacks);
1227    end Save_Occurrence_No_Private;
1228
1229    -------------------------
1230    -- Transfer_Occurrence --
1231    -------------------------
1232
1233    procedure Transfer_Occurrence
1234      (Target : Exception_Occurrence_Access;
1235       Source : Exception_Occurrence)
1236    is
1237    begin
1238       --  Setup Target as an exception to be propagated in the calling task
1239       --  (rendezvous-wise), taking care not to clobber the associated private
1240       --  data.  Target is expected to be a pointer to the calling task's
1241       --  fixed TSD occurrence, which is very different from Get_Current_Excep
1242       --  here because this subprogram is called from the called task.
1243
1244       Save_Occurrence_No_Private (Target.all, Source);
1245    end Transfer_Occurrence;
1246
1247    -------------------
1248    -- String_To_EId --
1249    -------------------
1250
1251    function String_To_EId (S : String) return Exception_Id
1252      renames Stream_Attributes.String_To_EId;
1253
1254    ------------------
1255    -- String_To_EO --
1256    ------------------
1257
1258    function String_To_EO (S : String) return Exception_Occurrence
1259      renames Stream_Attributes.String_To_EO;
1260
1261    ------------------------------
1262    -- Raise_Exception_No_Defer --
1263    ------------------------------
1264
1265    procedure Raise_Exception_No_Defer
1266      (E       : Exception_Id;
1267       Message : String := "")
1268    is
1269    begin
1270       Exception_Data.Set_Exception_Msg (E, Message);
1271
1272       --  Do not call Abort_Defer.all, as specified by the spec
1273
1274       Raise_Current_Excep (E);
1275    end Raise_Exception_No_Defer;
1276
1277    ---------------
1278    -- To_Stderr --
1279    ---------------
1280
1281    procedure To_Stderr (C : Character) is
1282
1283       type int is new Integer;
1284
1285       procedure put_char_stderr (C : int);
1286       pragma Import (C, put_char_stderr, "put_char_stderr");
1287
1288    begin
1289       put_char_stderr (Character'Pos (C));
1290    end To_Stderr;
1291
1292    procedure To_Stderr (S : String) is
1293    begin
1294       for J in S'Range loop
1295          if S (J) /= ASCII.CR then
1296             To_Stderr (S (J));
1297          end if;
1298       end loop;
1299    end To_Stderr;
1300
1301 end Ada.Exceptions;