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