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-2015, 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 pragma Compiler_Unit_Warning;
  33
  34 pragma Style_Checks (All_Checks);
  35 --  No subprogram ordering check, due to logical grouping
  36
  37 pragma Polling (Off);
  38 --  We must turn polling off for this unit, because otherwise we get
  39 --  elaboration circularities with System.Exception_Tables.
  40
  41 with System;                  use System;
  42 with System.Exceptions_Debug; use System.Exceptions_Debug;
  43 with System.Standard_Library; use System.Standard_Library;
  44 with System.Soft_Links;       use System.Soft_Links;
  45
  46 package body Ada.Exceptions is
  47
  48    pragma Suppress (All_Checks);
  49    --  We definitely do not want exceptions occurring within this unit, or we
  50    --  are in big trouble. If an exceptional situation does occur, better that
  51    --  it not be raised, since raising it can cause confusing chaos.
  52
  53    -----------------------
  54    -- Local Subprograms --
  55    -----------------------
  56
  57    --  Note: the exported subprograms in this package body are called directly
  58    --  from C clients using the given external name, even though they are not
  59    --  technically visible in the Ada sense.
  60
  61    procedure Process_Raise_Exception (E : Exception_Id);
  62    pragma No_Return (Process_Raise_Exception);
  63    --  This is the lowest level raise routine. It raises the exception
  64    --  referenced by Current_Excep.all in the TSD, without deferring abort
  65    --  (the caller must ensure that abort is deferred on entry).
  66
  67    procedure To_Stderr (S : String);
  68    pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
  69    --  Little routine to output string to stderr that is also used in the
  70    --  tasking run time.
  71
  72    procedure To_Stderr (C : Character);
  73    pragma Inline (To_Stderr);
  74    pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
  75    --  Little routine to output a character to stderr, used by some of the
  76    --  separate units below.
  77
  78    package Exception_Data is
  79
  80       -----------------------------------
  81       -- Exception Message Subprograms --
  82       -----------------------------------
  83
  84       procedure Set_Exception_C_Msg
  85         (Excep  : EOA;
  86          Id     : Exception_Id;
  87          Msg1   : System.Address;
  88          Line   : Integer        := 0;
  89          Column : Integer        := 0;
  90          Msg2   : System.Address := System.Null_Address);
  91       --  This routine is called to setup the exception referenced by the
  92       --  Current_Excep field in the TSD to contain the indicated Id value
  93       --  and message. Msg1 is a null terminated string which is generated
  94       --  as the exception message. If line is non-zero, then a colon and
  95       --  the decimal representation of this integer is appended to the
  96       --  message. Ditto for Column. When Msg2 is non-null, a space and this
  97       --  additional null terminated string is added to the message.
  98
  99       procedure Set_Exception_Msg
 100         (Excep   : EOA;
 101          Id      : Exception_Id;
 102          Message : String);
 103       --  This routine is called to setup the exception referenced by the
 104       --  Current_Excep field in the TSD to contain the indicated Id value and
 105       --  message. Message is a string which is generated as the exception
 106       --  message.
 107
 108       ---------------------------------------
 109       -- Exception Information Subprograms --
 110       ---------------------------------------
 111
 112       function Untailored_Exception_Information
 113         (X : Exception_Occurrence) return String;
 114       --  This is used by Stream_Attributes.EO_To_String to convert an
 115       --  Exception_Occurrence to a String for the stream attributes.
 116       --  String_To_EO understands the format, as documented here.
 117       --
 118       --  The format of the string is as follows:
 119       --
 120       --    Exception_Name: <exception name> (as in Exception_Name)
 121       --    Message: <message> (only if Exception_Message is empty)
 122       --    PID=nnnn (only if nonzero)
 123       --    Call stack traceback locations:  (only if at least one location)
 124       --    <0xyyyyyyyy 0xyyyyyyyy ...>      (is recorded)
 125       --
 126       --  The lines are separated by a ASCII.LF character.
 127       --  The nnnn is the partition Id given as decimal digits.
 128       --  The 0x... line represents traceback program counter locations, in
 129       --  execution order with the first one being the exception location.
 130       --
 131       --  The Exception_Name and Message lines are omitted in the abort
 132       --  signal case, since this is not really an exception.
 133       --
 134       --  Note: If the format of the generated string is changed, please note
 135       --  that an equivalent modification to the routine String_To_EO must be
 136       --  made to preserve proper functioning of the stream attributes.
 137
 138       function Exception_Information (X : Exception_Occurrence) return String;
 139       --  This is the implementation of Ada.Exceptions.Exception_Information,
 140       --  as defined in the Ada RM.
 141       --
 142       --  If no traceback decorator (see GNAT.Exception_Traces) is currently
 143       --  in place, this is the same as Untailored_Exception_Information.
 144       --  Otherwise, the decorator is used to produce a symbolic traceback
 145       --  instead of hexadecimal addresses.
 146       --
 147       --  Note that unlike Untailored_Exception_Information, there is no need
 148       --  to keep the output of Exception_Information stable for streaming
 149       --  purposes, and in fact the output differs across platforms.
 150
 151    end Exception_Data;
 152
 153    package Exception_Traces is
 154
 155       -------------------------------------------------
 156       -- Run-Time Exception Notification Subprograms --
 157       -------------------------------------------------
 158
 159       --  These subprograms provide a common run-time interface to trigger the
 160       --  actions required when an exception is about to be propagated (e.g.
 161       --  user specified actions or output of exception information). They are
 162       --  exported to be usable by the Ada exception handling personality
 163       --  routine when the GCC 3 mechanism is used.
 164
 165       procedure Notify_Handled_Exception (Excep : EOA);
 166       pragma Export
 167         (C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
 168       --  This routine is called for a handled occurrence is about to be
 169       --  propagated.
 170
 171       procedure Notify_Unhandled_Exception (Excep : EOA);
 172       pragma Export
 173         (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
 174       --  This routine is called when an unhandled occurrence is about to be
 175       --  propagated.
 176
 177       procedure Unhandled_Exception_Terminate (Excep : EOA);
 178       pragma No_Return (Unhandled_Exception_Terminate);
 179       --  This procedure is called to terminate program execution following an
 180       --  unhandled exception. The exception information, including traceback
 181       --  if available is output, and execution is then terminated. Note that
 182       --  at the point where this routine is called, the stack has typically
 183       --  been destroyed.
 184
 185    end Exception_Traces;
 186
 187    package Stream_Attributes is
 188
 189       ----------------------------------
 190       -- Stream Attribute Subprograms --
 191       ----------------------------------
 192
 193       function EId_To_String (X : Exception_Id) return String;
 194       function String_To_EId (S : String) return Exception_Id;
 195       --  Functions for implementing Exception_Id stream attributes
 196
 197       function EO_To_String (X : Exception_Occurrence) return String;
 198       function String_To_EO (S : String) return Exception_Occurrence;
 199       --  Functions for implementing Exception_Occurrence stream
 200       --  attributes
 201
 202    end Stream_Attributes;
 203
 204    procedure Raise_Current_Excep (E : Exception_Id);
 205    pragma No_Return (Raise_Current_Excep);
 206    pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
 207    --  This is a simple wrapper to Process_Raise_Exception.
 208    --
 209    --  This external name for Raise_Current_Excep is historical, and probably
 210    --  should be changed but for now we keep it, because gdb and gigi know
 211    --  about it.
 212
 213    procedure Raise_Exception_No_Defer
 214       (E       : Exception_Id;
 215        Message : String := "");
 216    pragma Export
 217     (Ada, Raise_Exception_No_Defer,
 218      "ada__exceptions__raise_exception_no_defer");
 219    pragma No_Return (Raise_Exception_No_Defer);
 220    --  Similar to Raise_Exception, but with no abort deferral
 221
 222    procedure Raise_With_Msg (E : Exception_Id);
 223    pragma No_Return (Raise_With_Msg);
 224    pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
 225    --  Raises an exception with given exception id value. A message is
 226    --  associated with the raise, and has already been stored in the exception
 227    --  occurrence referenced by the Current_Excep in the TSD. Abort is deferred
 228    --  before the raise call.
 229
 230    procedure Raise_With_Location_And_Msg
 231      (E : Exception_Id;
 232       F : System.Address;
 233       L : Integer;
 234       M : System.Address := System.Null_Address);
 235    pragma No_Return (Raise_With_Location_And_Msg);
 236    --  Raise an exception with given exception id value. A filename and line
 237    --  number is associated with the raise and is stored in the exception
 238    --  occurrence and in addition a string message M is appended to this
 239    --  if M is not null.
 240
 241    procedure Raise_Constraint_Error
 242      (File : System.Address;
 243       Line : Integer);
 244    pragma No_Return (Raise_Constraint_Error);
 245    pragma Export
 246      (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
 247    --  Raise constraint error with file:line information
 248
 249    procedure Raise_Constraint_Error_Msg
 250      (File : System.Address;
 251       Line : Integer;
 252       Msg  : System.Address);
 253    pragma No_Return (Raise_Constraint_Error_Msg);
 254    pragma Export
 255      (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
 256    --  Raise constraint error with file:line + msg information
 257
 258    procedure Raise_Program_Error
 259      (File : System.Address;
 260       Line : Integer);
 261    pragma No_Return (Raise_Program_Error);
 262    pragma Export
 263      (C, Raise_Program_Error, "__gnat_raise_program_error");
 264    --  Raise program error with file:line information
 265
 266    procedure Raise_Program_Error_Msg
 267      (File : System.Address;
 268       Line : Integer;
 269       Msg  : System.Address);
 270    pragma No_Return (Raise_Program_Error_Msg);
 271    pragma Export
 272      (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
 273    --  Raise program error with file:line + msg information
 274
 275    procedure Raise_Storage_Error
 276      (File : System.Address;
 277       Line : Integer);
 278    pragma No_Return (Raise_Storage_Error);
 279    pragma Export
 280      (C, Raise_Storage_Error, "__gnat_raise_storage_error");
 281    --  Raise storage error with file:line information
 282
 283    procedure Raise_Storage_Error_Msg
 284      (File : System.Address;
 285       Line : Integer;
 286       Msg  : System.Address);
 287    pragma No_Return (Raise_Storage_Error_Msg);
 288    pragma Export
 289      (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
 290    --  Raise storage error with file:line + reason msg information
 291
 292    --  The exception raising process and the automatic tracing mechanism rely
 293    --  on some careful use of flags attached to the exception occurrence. The
 294    --  graph below illustrates the relations between the Raise_ subprograms
 295    --  and identifies the points where basic flags such as Exception_Raised
 296    --  are initialized.
 297    --
 298    --  (i) signs indicate the flags initialization points. R stands for Raise,
 299    --  W for With, and E for Exception.
 300    --
 301    --                   R_No_Msg    R_E   R_Pe  R_Ce  R_Se
 302    --                       |        |     |     |     |
 303    --                       +--+  +--+     +---+ | +---+
 304    --                          |  |            | | |
 305    --     R_E_No_Defer(i)    R_W_Msg(i)       R_W_Loc
 306    --           |               |              |   |
 307    --           +------------+  |  +-----------+   +--+
 308    --                        |  |  |                  |
 309    --                        |  |  |             Set_E_C_Msg(i)
 310    --                        |  |  |
 311    --                   Raise_Current_Excep
 312
 313    procedure Reraise;
 314    pragma No_Return (Reraise);
 315    pragma Export (C, Reraise, "__gnat_reraise");
 316    --  Reraises the exception referenced by the Current_Excep field of the TSD
 317    --  (all fields of this exception occurrence are set). Abort is deferred
 318    --  before the reraise operation.
 319
 320    procedure Transfer_Occurrence
 321      (Target : Exception_Occurrence_Access;
 322       Source : Exception_Occurrence);
 323    pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
 324    --  Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous
 325    --  to setup Target from Source as an exception to be propagated in the
 326    --  caller task. Target is expected to be a pointer to the fixed TSD
 327    --  occurrence for this task.
 328
 329    --------------------------------
 330    -- Run-Time Check Subprograms --
 331    --------------------------------
 332
 333    --  These subprograms raise a specific exception with a reason message
 334    --  attached. The parameters are the file name and line number in each
 335    --  case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
 336
 337    --  Note on ordering of these subprograms. Normally in the Ada.Exceptions
 338    --  units we do not care about the ordering of entries for Rcheck
 339    --  subprograms, and the normal approach is to keep them in the same
 340    --  order as declarations in Types.
 341
 342    --  This section is an IMPORTANT EXCEPTION. It is required by the .Net
 343    --  runtime that the routine Rcheck_PE_Finalize_Raise_Exception is at the
 344    --  end of the list (for reasons that are documented in the exceptmsg.awk
 345    --  script which takes care of generating the required exception data).
 346
 347    procedure Rcheck_CE_Access_Check                   -- 00
 348      (File : System.Address; Line : Integer);
 349    procedure Rcheck_CE_Null_Access_Parameter          -- 01
 350      (File : System.Address; Line : Integer);
 351    procedure Rcheck_CE_Discriminant_Check             -- 02
 352      (File : System.Address; Line : Integer);
 353    procedure Rcheck_CE_Divide_By_Zero                 -- 03
 354      (File : System.Address; Line : Integer);
 355    procedure Rcheck_CE_Explicit_Raise                 -- 04
 356      (File : System.Address; Line : Integer);
 357    procedure Rcheck_CE_Index_Check                    -- 05
 358      (File : System.Address; Line : Integer);
 359    procedure Rcheck_CE_Invalid_Data                   -- 06
 360      (File : System.Address; Line : Integer);
 361    procedure Rcheck_CE_Length_Check                   -- 07
 362      (File : System.Address; Line : Integer);
 363    procedure Rcheck_CE_Null_Exception_Id              -- 08
 364      (File : System.Address; Line : Integer);
 365    procedure Rcheck_CE_Null_Not_Allowed               -- 09
 366      (File : System.Address; Line : Integer);
 367    procedure Rcheck_CE_Overflow_Check                 -- 10
 368      (File : System.Address; Line : Integer);
 369    procedure Rcheck_CE_Partition_Check                -- 11
 370      (File : System.Address; Line : Integer);
 371    procedure Rcheck_CE_Range_Check                    -- 12
 372      (File : System.Address; Line : Integer);
 373    procedure Rcheck_CE_Tag_Check                      -- 13
 374      (File : System.Address; Line : Integer);
 375    procedure Rcheck_PE_Access_Before_Elaboration      -- 14
 376      (File : System.Address; Line : Integer);
 377    procedure Rcheck_PE_Accessibility_Check            -- 15
 378      (File : System.Address; Line : Integer);
 379    procedure Rcheck_PE_Address_Of_Intrinsic           -- 16
 380      (File : System.Address; Line : Integer);
 381    procedure Rcheck_PE_Aliased_Parameters             -- 17
 382      (File : System.Address; Line : Integer);
 383    procedure Rcheck_PE_All_Guards_Closed              -- 18
 384      (File : System.Address; Line : Integer);
 385    procedure Rcheck_PE_Bad_Predicated_Generic_Type    -- 19
 386      (File : System.Address; Line : Integer);
 387    procedure Rcheck_PE_Current_Task_In_Entry_Body     -- 20
 388      (File : System.Address; Line : Integer);
 389    procedure Rcheck_PE_Duplicated_Entry_Address       -- 21
 390      (File : System.Address; Line : Integer);
 391    procedure Rcheck_PE_Explicit_Raise                 -- 22
 392      (File : System.Address; Line : Integer);
 393
 394    procedure Rcheck_PE_Implicit_Return                -- 24
 395      (File : System.Address; Line : Integer);
 396    procedure Rcheck_PE_Misaligned_Address_Value       -- 25
 397      (File : System.Address; Line : Integer);
 398    procedure Rcheck_PE_Missing_Return                 -- 26
 399      (File : System.Address; Line : Integer);
 400    procedure Rcheck_PE_Overlaid_Controlled_Object     -- 27
 401      (File : System.Address; Line : Integer);
 402    procedure Rcheck_PE_Potentially_Blocking_Operation -- 28
 403      (File : System.Address; Line : Integer);
 404    procedure Rcheck_PE_Stubbed_Subprogram_Called      -- 29
 405      (File : System.Address; Line : Integer);
 406    procedure Rcheck_PE_Unchecked_Union_Restriction    -- 30
 407      (File : System.Address; Line : Integer);
 408    procedure Rcheck_PE_Non_Transportable_Actual       -- 31
 409      (File : System.Address; Line : Integer);
 410    procedure Rcheck_SE_Empty_Storage_Pool             -- 32
 411      (File : System.Address; Line : Integer);
 412    procedure Rcheck_SE_Explicit_Raise                 -- 33
 413      (File : System.Address; Line : Integer);
 414    procedure Rcheck_SE_Infinite_Recursion             -- 34
 415      (File : System.Address; Line : Integer);
 416    procedure Rcheck_SE_Object_Too_Large               -- 35
 417      (File : System.Address; Line : Integer);
 418    procedure Rcheck_PE_Stream_Operation_Not_Allowed   -- 36
 419      (File : System.Address; Line : Integer);
 420
 421    procedure Rcheck_PE_Finalize_Raised_Exception      -- 23
 422      (File : System.Address; Line : Integer);
 423    --  This routine is separated out because it has quite different behavior
 424    --  from the others. This is the "finalize/adjust raised exception". This
 425    --  subprogram is always called with abort deferred, unlike all other
 426    --  Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer.
 427
 428    pragma Export (C, Rcheck_CE_Access_Check,
 429                   "__gnat_rcheck_CE_Access_Check");
 430    pragma Export (C, Rcheck_CE_Null_Access_Parameter,
 431                   "__gnat_rcheck_CE_Null_Access_Parameter");
 432    pragma Export (C, Rcheck_CE_Discriminant_Check,
 433                   "__gnat_rcheck_CE_Discriminant_Check");
 434    pragma Export (C, Rcheck_CE_Divide_By_Zero,
 435                   "__gnat_rcheck_CE_Divide_By_Zero");
 436    pragma Export (C, Rcheck_CE_Explicit_Raise,
 437                   "__gnat_rcheck_CE_Explicit_Raise");
 438    pragma Export (C, Rcheck_CE_Index_Check,
 439                   "__gnat_rcheck_CE_Index_Check");
 440    pragma Export (C, Rcheck_CE_Invalid_Data,
 441                   "__gnat_rcheck_CE_Invalid_Data");
 442    pragma Export (C, Rcheck_CE_Length_Check,
 443                   "__gnat_rcheck_CE_Length_Check");
 444    pragma Export (C, Rcheck_CE_Null_Exception_Id,
 445                   "__gnat_rcheck_CE_Null_Exception_Id");
 446    pragma Export (C, Rcheck_CE_Null_Not_Allowed,
 447                   "__gnat_rcheck_CE_Null_Not_Allowed");
 448    pragma Export (C, Rcheck_CE_Overflow_Check,
 449                   "__gnat_rcheck_CE_Overflow_Check");
 450    pragma Export (C, Rcheck_CE_Partition_Check,
 451                   "__gnat_rcheck_CE_Partition_Check");
 452    pragma Export (C, Rcheck_CE_Range_Check,
 453                   "__gnat_rcheck_CE_Range_Check");
 454    pragma Export (C, Rcheck_CE_Tag_Check,
 455                   "__gnat_rcheck_CE_Tag_Check");
 456    pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
 457                   "__gnat_rcheck_PE_Access_Before_Elaboration");
 458    pragma Export (C, Rcheck_PE_Accessibility_Check,
 459                   "__gnat_rcheck_PE_Accessibility_Check");
 460    pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
 461                   "__gnat_rcheck_PE_Address_Of_Intrinsic");
 462    pragma Export (C, Rcheck_PE_Aliased_Parameters,
 463                   "__gnat_rcheck_PE_Aliased_Parameters");
 464    pragma Export (C, Rcheck_PE_All_Guards_Closed,
 465                   "__gnat_rcheck_PE_All_Guards_Closed");
 466    pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
 467                   "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
 468    pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
 469                   "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
 470    pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
 471                   "__gnat_rcheck_PE_Duplicated_Entry_Address");
 472    pragma Export (C, Rcheck_PE_Explicit_Raise,
 473                   "__gnat_rcheck_PE_Explicit_Raise");
 474    pragma Export (C, Rcheck_PE_Finalize_Raised_Exception,
 475                   "__gnat_rcheck_PE_Finalize_Raised_Exception");
 476    pragma Export (C, Rcheck_PE_Implicit_Return,
 477                   "__gnat_rcheck_PE_Implicit_Return");
 478    pragma Export (C, Rcheck_PE_Misaligned_Address_Value,
 479                   "__gnat_rcheck_PE_Misaligned_Address_Value");
 480    pragma Export (C, Rcheck_PE_Missing_Return,
 481                   "__gnat_rcheck_PE_Missing_Return");
 482    pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
 483                   "__gnat_rcheck_PE_Non_Transportable_Actual");
 484    pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
 485                   "__gnat_rcheck_PE_Overlaid_Controlled_Object");
 486    pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
 487                   "__gnat_rcheck_PE_Potentially_Blocking_Operation");
 488    pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
 489                   "__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
 490    pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
 491                   "__gnat_rcheck_PE_Stubbed_Subprogram_Called");
 492    pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
 493                   "__gnat_rcheck_PE_Unchecked_Union_Restriction");
 494    pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
 495                   "__gnat_rcheck_SE_Empty_Storage_Pool");
 496    pragma Export (C, Rcheck_SE_Explicit_Raise,
 497                   "__gnat_rcheck_SE_Explicit_Raise");
 498    pragma Export (C, Rcheck_SE_Infinite_Recursion,
 499                   "__gnat_rcheck_SE_Infinite_Recursion");
 500    pragma Export (C, Rcheck_SE_Object_Too_Large,
 501                   "__gnat_rcheck_SE_Object_Too_Large");
 502
 503    --  None of these procedures ever returns (they raise an exception). By
 504    --  using pragma No_Return, we ensure that any junk code after the call,
 505    --  such as normal return epilogue stuff, can be eliminated).
 506
 507    pragma No_Return (Rcheck_CE_Access_Check);
 508    pragma No_Return (Rcheck_CE_Null_Access_Parameter);
 509    pragma No_Return (Rcheck_CE_Discriminant_Check);
 510    pragma No_Return (Rcheck_CE_Divide_By_Zero);
 511    pragma No_Return (Rcheck_CE_Explicit_Raise);
 512    pragma No_Return (Rcheck_CE_Index_Check);
 513    pragma No_Return (Rcheck_CE_Invalid_Data);
 514    pragma No_Return (Rcheck_CE_Length_Check);
 515    pragma No_Return (Rcheck_CE_Null_Exception_Id);
 516    pragma No_Return (Rcheck_CE_Null_Not_Allowed);
 517    pragma No_Return (Rcheck_CE_Overflow_Check);
 518    pragma No_Return (Rcheck_CE_Partition_Check);
 519    pragma No_Return (Rcheck_CE_Range_Check);
 520    pragma No_Return (Rcheck_CE_Tag_Check);
 521    pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
 522    pragma No_Return (Rcheck_PE_Accessibility_Check);
 523    pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
 524    pragma No_Return (Rcheck_PE_Aliased_Parameters);
 525    pragma No_Return (Rcheck_PE_All_Guards_Closed);
 526    pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
 527    pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
 528    pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
 529    pragma No_Return (Rcheck_PE_Explicit_Raise);
 530    pragma No_Return (Rcheck_PE_Implicit_Return);
 531    pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
 532    pragma No_Return (Rcheck_PE_Missing_Return);
 533    pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
 534    pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
 535    pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
 536    pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
 537    pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
 538    pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
 539    pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
 540    pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
 541    pragma No_Return (Rcheck_SE_Explicit_Raise);
 542    pragma No_Return (Rcheck_SE_Infinite_Recursion);
 543    pragma No_Return (Rcheck_SE_Object_Too_Large);
 544
 545    --  For compatibility with previous version of GNAT, to preserve bootstrap
 546
 547    procedure Rcheck_00 (File : System.Address; Line : Integer);
 548    procedure Rcheck_01 (File : System.Address; Line : Integer);
 549    procedure Rcheck_02 (File : System.Address; Line : Integer);
 550    procedure Rcheck_03 (File : System.Address; Line : Integer);
 551    procedure Rcheck_04 (File : System.Address; Line : Integer);
 552    procedure Rcheck_05 (File : System.Address; Line : Integer);
 553    procedure Rcheck_06 (File : System.Address; Line : Integer);
 554    procedure Rcheck_07 (File : System.Address; Line : Integer);
 555    procedure Rcheck_08 (File : System.Address; Line : Integer);
 556    procedure Rcheck_09 (File : System.Address; Line : Integer);
 557    procedure Rcheck_10 (File : System.Address; Line : Integer);
 558    procedure Rcheck_11 (File : System.Address; Line : Integer);
 559    procedure Rcheck_12 (File : System.Address; Line : Integer);
 560    procedure Rcheck_13 (File : System.Address; Line : Integer);
 561    procedure Rcheck_14 (File : System.Address; Line : Integer);
 562    procedure Rcheck_15 (File : System.Address; Line : Integer);
 563    procedure Rcheck_16 (File : System.Address; Line : Integer);
 564    procedure Rcheck_17 (File : System.Address; Line : Integer);
 565    procedure Rcheck_18 (File : System.Address; Line : Integer);
 566    procedure Rcheck_19 (File : System.Address; Line : Integer);
 567    procedure Rcheck_20 (File : System.Address; Line : Integer);
 568    procedure Rcheck_21 (File : System.Address; Line : Integer);
 569    procedure Rcheck_22 (File : System.Address; Line : Integer);
 570    procedure Rcheck_23 (File : System.Address; Line : Integer);
 571    procedure Rcheck_24 (File : System.Address; Line : Integer);
 572    procedure Rcheck_25 (File : System.Address; Line : Integer);
 573    procedure Rcheck_26 (File : System.Address; Line : Integer);
 574    procedure Rcheck_27 (File : System.Address; Line : Integer);
 575    procedure Rcheck_28 (File : System.Address; Line : Integer);
 576    procedure Rcheck_29 (File : System.Address; Line : Integer);
 577    procedure Rcheck_30 (File : System.Address; Line : Integer);
 578    procedure Rcheck_31 (File : System.Address; Line : Integer);
 579    procedure Rcheck_32 (File : System.Address; Line : Integer);
 580    procedure Rcheck_33 (File : System.Address; Line : Integer);
 581    procedure Rcheck_34 (File : System.Address; Line : Integer);
 582    procedure Rcheck_35 (File : System.Address; Line : Integer);
 583    procedure Rcheck_36 (File : System.Address; Line : Integer);
 584
 585    pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
 586    pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
 587    pragma Export (C, Rcheck_02, "__gnat_rcheck_02");
 588    pragma Export (C, Rcheck_03, "__gnat_rcheck_03");
 589    pragma Export (C, Rcheck_04, "__gnat_rcheck_04");
 590    pragma Export (C, Rcheck_05, "__gnat_rcheck_05");
 591    pragma Export (C, Rcheck_06, "__gnat_rcheck_06");
 592    pragma Export (C, Rcheck_07, "__gnat_rcheck_07");
 593    pragma Export (C, Rcheck_08, "__gnat_rcheck_08");
 594    pragma Export (C, Rcheck_09, "__gnat_rcheck_09");
 595    pragma Export (C, Rcheck_10, "__gnat_rcheck_10");
 596    pragma Export (C, Rcheck_11, "__gnat_rcheck_11");
 597    pragma Export (C, Rcheck_12, "__gnat_rcheck_12");
 598    pragma Export (C, Rcheck_13, "__gnat_rcheck_13");
 599    pragma Export (C, Rcheck_14, "__gnat_rcheck_14");
 600    pragma Export (C, Rcheck_15, "__gnat_rcheck_15");
 601    pragma Export (C, Rcheck_16, "__gnat_rcheck_16");
 602    pragma Export (C, Rcheck_17, "__gnat_rcheck_17");
 603    pragma Export (C, Rcheck_18, "__gnat_rcheck_18");
 604    pragma Export (C, Rcheck_19, "__gnat_rcheck_19");
 605    pragma Export (C, Rcheck_20, "__gnat_rcheck_20");
 606    pragma Export (C, Rcheck_21, "__gnat_rcheck_21");
 607    pragma Export (C, Rcheck_22, "__gnat_rcheck_22");
 608    pragma Export (C, Rcheck_23, "__gnat_rcheck_23");
 609    pragma Export (C, Rcheck_24, "__gnat_rcheck_24");
 610    pragma Export (C, Rcheck_25, "__gnat_rcheck_25");
 611    pragma Export (C, Rcheck_26, "__gnat_rcheck_26");
 612    pragma Export (C, Rcheck_27, "__gnat_rcheck_27");
 613    pragma Export (C, Rcheck_28, "__gnat_rcheck_28");
 614    pragma Export (C, Rcheck_29, "__gnat_rcheck_29");
 615    pragma Export (C, Rcheck_30, "__gnat_rcheck_30");
 616    pragma Export (C, Rcheck_31, "__gnat_rcheck_31");
 617    pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
 618    pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
 619    pragma Export (C, Rcheck_34, "__gnat_rcheck_34");
 620    pragma Export (C, Rcheck_35, "__gnat_rcheck_35");
 621    pragma Export (C, Rcheck_36, "__gnat_rcheck_36");
 622
 623    --  None of these procedures ever returns (they raise an exception). By
 624    --  using pragma No_Return, we ensure that any junk code after the call,
 625    --  such as normal return epilogue stuff, can be eliminated).
 626
 627    pragma No_Return (Rcheck_00);
 628    pragma No_Return (Rcheck_01);
 629    pragma No_Return (Rcheck_02);
 630    pragma No_Return (Rcheck_03);
 631    pragma No_Return (Rcheck_04);
 632    pragma No_Return (Rcheck_05);
 633    pragma No_Return (Rcheck_06);
 634    pragma No_Return (Rcheck_07);
 635    pragma No_Return (Rcheck_08);
 636    pragma No_Return (Rcheck_09);
 637    pragma No_Return (Rcheck_10);
 638    pragma No_Return (Rcheck_11);
 639    pragma No_Return (Rcheck_12);
 640    pragma No_Return (Rcheck_13);
 641    pragma No_Return (Rcheck_14);
 642    pragma No_Return (Rcheck_15);
 643    pragma No_Return (Rcheck_16);
 644    pragma No_Return (Rcheck_17);
 645    pragma No_Return (Rcheck_18);
 646    pragma No_Return (Rcheck_19);
 647    pragma No_Return (Rcheck_20);
 648    pragma No_Return (Rcheck_21);
 649    pragma No_Return (Rcheck_22);
 650    pragma No_Return (Rcheck_23);
 651    pragma No_Return (Rcheck_24);
 652    pragma No_Return (Rcheck_25);
 653    pragma No_Return (Rcheck_26);
 654    pragma No_Return (Rcheck_27);
 655    pragma No_Return (Rcheck_28);
 656    pragma No_Return (Rcheck_29);
 657    pragma No_Return (Rcheck_30);
 658    pragma No_Return (Rcheck_32);
 659    pragma No_Return (Rcheck_33);
 660    pragma No_Return (Rcheck_34);
 661    pragma No_Return (Rcheck_35);
 662    pragma No_Return (Rcheck_36);
 663
 664    ---------------------------------------------
 665    -- Reason Strings for Run-Time Check Calls --
 666    ---------------------------------------------
 667
 668    --  These strings are null-terminated and are used by Rcheck_nn. The
 669    --  strings correspond to the definitions for Types.RT_Exception_Code.
 670
 671    use ASCII;
 672
 673    Rmsg_00 : constant String := "access check failed"              & NUL;
 674    Rmsg_01 : constant String := "access parameter is null"         & NUL;
 675    Rmsg_02 : constant String := "discriminant check failed"        & NUL;
 676    Rmsg_03 : constant String := "divide by zero"                   & NUL;
 677    Rmsg_04 : constant String := "explicit raise"                   & NUL;
 678    Rmsg_05 : constant String := "index check failed"               & NUL;
 679    Rmsg_06 : constant String := "invalid data"                     & NUL;
 680    Rmsg_07 : constant String := "length check failed"              & NUL;
 681    Rmsg_08 : constant String := "null Exception_Id"                & NUL;
 682    Rmsg_09 : constant String := "null-exclusion check failed"      & NUL;
 683    Rmsg_10 : constant String := "overflow check failed"            & NUL;
 684    Rmsg_11 : constant String := "partition check failed"           & NUL;
 685    Rmsg_12 : constant String := "range check failed"               & NUL;
 686    Rmsg_13 : constant String := "tag check failed"                 & NUL;
 687    Rmsg_14 : constant String := "access before elaboration"        & NUL;
 688    Rmsg_15 : constant String := "accessibility check failed"       & NUL;
 689    Rmsg_16 : constant String := "attempt to take address of"       &
 690                                 " intrinsic subprogram"            & NUL;
 691    Rmsg_17 : constant String := "aliased parameters"               & NUL;
 692    Rmsg_18 : constant String := "all guards closed"                & NUL;
 693    Rmsg_19 : constant String := "improper use of generic subtype"  &
 694                                 " with predicate"                  & NUL;
 695    Rmsg_20 : constant String := "Current_Task referenced in entry" &
 696                                 " body"                            & NUL;
 697    Rmsg_21 : constant String := "duplicated entry address"         & NUL;
 698    Rmsg_22 : constant String := "explicit raise"                   & NUL;
 699    Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL;
 700    Rmsg_24 : constant String := "implicit return with No_Return"   & NUL;
 701    Rmsg_25 : constant String := "misaligned address value"         & NUL;
 702    Rmsg_26 : constant String := "missing return"                   & NUL;
 703    Rmsg_27 : constant String := "overlaid controlled object"       & NUL;
 704    Rmsg_28 : constant String := "potentially blocking operation"   & NUL;
 705    Rmsg_29 : constant String := "stubbed subprogram called"        & NUL;
 706    Rmsg_30 : constant String := "unchecked union restriction"      & NUL;
 707    Rmsg_31 : constant String := "actual/returned class-wide"       &
 708                                 " value not transportable"         & NUL;
 709    Rmsg_32 : constant String := "empty storage pool"               & NUL;
 710    Rmsg_33 : constant String := "explicit raise"                   & NUL;
 711    Rmsg_34 : constant String := "infinite recursion"               & NUL;
 712    Rmsg_35 : constant String := "object too large"                 & NUL;
 713    Rmsg_36 : constant String := "stream operation not allowed"     & NUL;
 714
 715    -----------------------
 716    -- Polling Interface --
 717    -----------------------
 718
 719    type Unsigned is mod 2 ** 32;
 720
 721    Counter : Unsigned := 0;
 722    pragma Warnings (Off, Counter);
 723    --  This counter is provided for convenience. It can be used in Poll to
 724    --  perform periodic but not systematic operations.
 725
 726    procedure Poll is separate;
 727    --  The actual polling routine is separate, so that it can easily be
 728    --  replaced with a target dependent version.
 729
 730    ------------------------------
 731    -- Current_Target_Exception --
 732    ------------------------------
 733
 734    function Current_Target_Exception return Exception_Occurrence is
 735    begin
 736       return Null_Occurrence;
 737    end Current_Target_Exception;
 738
 739    -------------------
 740    -- EId_To_String --
 741    -------------------
 742
 743    function EId_To_String (X : Exception_Id) return String
 744      renames Stream_Attributes.EId_To_String;
 745
 746    ------------------
 747    -- EO_To_String --
 748    ------------------
 749
 750    --  We use the null string to represent the null occurrence, otherwise we
 751    --  output the Untailored_Exception_Information string for the occurrence.
 752
 753    function EO_To_String (X : Exception_Occurrence) return String
 754      renames Stream_Attributes.EO_To_String;
 755
 756    ------------------------
 757    -- Exception_Identity --
 758    ------------------------
 759
 760    function Exception_Identity
 761      (X : Exception_Occurrence) return Exception_Id
 762    is
 763    begin
 764       --  Note that the following test used to be here for the original Ada 95
 765       --  semantics, but these were modified by AI-241 to require returning
 766       --  Null_Id instead of raising Constraint_Error.
 767
 768       --  if X.Id = Null_Id then
 769       --     raise Constraint_Error;
 770       --  end if;
 771
 772       return X.Id;
 773    end Exception_Identity;
 774
 775    ---------------------------
 776    -- Exception_Information --
 777    ---------------------------
 778
 779    function Exception_Information (X : Exception_Occurrence) return String is
 780    begin
 781       if X.Id = Null_Id then
 782          raise Constraint_Error;
 783       else
 784          return Exception_Data.Exception_Information (X);
 785       end if;
 786    end Exception_Information;
 787
 788    -----------------------
 789    -- Exception_Message --
 790    -----------------------
 791
 792    function Exception_Message (X : Exception_Occurrence) return String is
 793    begin
 794       if X.Id = Null_Id then
 795          raise Constraint_Error;
 796       end if;
 797
 798       return X.Msg (1 .. X.Msg_Length);
 799    end Exception_Message;
 800
 801    --------------------
 802    -- Exception_Name --
 803    --------------------
 804
 805    function Exception_Name (Id : Exception_Id) return String is
 806    begin
 807       if Id = null then
 808          raise Constraint_Error;
 809       end if;
 810
 811       return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
 812    end Exception_Name;
 813
 814    function Exception_Name (X : Exception_Occurrence) return String is
 815    begin
 816       return Exception_Name (X.Id);
 817    end Exception_Name;
 818
 819    ---------------------------
 820    -- Exception_Name_Simple --
 821    ---------------------------
 822
 823    function Exception_Name_Simple (X : Exception_Occurrence) return String is
 824       Name : constant String := Exception_Name (X);
 825       P    : Natural;
 826
 827    begin
 828       P := Name'Length;
 829       while P > 1 loop
 830          exit when Name (P - 1) = '.';
 831          P := P - 1;
 832       end loop;
 833
 834       --  Return result making sure lower bound is 1
 835
 836       declare
 837          subtype Rname is String (1 .. Name'Length - P + 1);
 838       begin
 839          return Rname (Name (P .. Name'Length));
 840       end;
 841    end Exception_Name_Simple;
 842
 843    --------------------
 844    -- Exception_Data --
 845    --------------------
 846
 847    package body Exception_Data is separate;
 848    --  This package can be easily dummied out if we do not want the basic
 849    --  support for exception messages (such as in Ada 83).
 850
 851    ----------------------
 852    -- Exception_Traces --
 853    ----------------------
 854
 855    package body Exception_Traces is separate;
 856    --  Depending on the underlying support for IO the implementation will
 857    --  differ. Moreover we would like to dummy out this package in case we do
 858    --  not want any exception tracing support. This is why this package is
 859    --  separated.
 860
 861    -----------------------
 862    -- Stream Attributes --
 863    -----------------------
 864
 865    package body Stream_Attributes is separate;
 866    --  This package can be easily dummied out if we do not want the
 867    --  support for streaming Exception_Ids and Exception_Occurrences.
 868
 869    -----------------------------
 870    -- Process_Raise_Exception --
 871    -----------------------------
 872
 873    procedure Process_Raise_Exception (E : Exception_Id) is
 874       pragma Inspection_Point (E);
 875       --  This is so the debugger can reliably inspect the parameter
 876
 877       Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
 878       Excep       : constant EOA := Get_Current_Excep.all;
 879
 880       procedure builtin_longjmp (buffer : Address; Flag : Integer);
 881       pragma No_Return (builtin_longjmp);
 882       pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
 883
 884    begin
 885       --  WARNING: There should be no exception handler for this body because
 886       --  this would cause gigi to prepend a setup for a new jmpbuf to the
 887       --  sequence of statements in case of built-in sjljl. We would then
 888       --  always get this new buf in Jumpbuf_Ptr instead of the one for the
 889       --  exception we are handling, which would completely break the whole
 890       --  design of this procedure.
 891
 892       --  If the jump buffer pointer is non-null, transfer control using it.
 893       --  Otherwise announce an unhandled exception (note that this means that
 894       --  we have no finalizations to do other than at the outer level).
 895       --  Perform the necessary notification tasks in both cases.
 896
 897       if Jumpbuf_Ptr /= Null_Address then
 898          if not Excep.Exception_Raised then
 899             Excep.Exception_Raised := True;
 900             Exception_Traces.Notify_Handled_Exception (Excep);
 901          end if;
 902
 903          builtin_longjmp (Jumpbuf_Ptr, 1);
 904
 905       else
 906          Exception_Traces.Notify_Unhandled_Exception (Excep);
 907          Exception_Traces.Unhandled_Exception_Terminate (Excep);
 908       end if;
 909    end Process_Raise_Exception;
 910
 911    ----------------------------
 912    -- Raise_Constraint_Error --
 913    ----------------------------
 914
 915    procedure Raise_Constraint_Error
 916      (File : System.Address;
 917       Line : Integer)
 918    is
 919    begin
 920       Raise_With_Location_And_Msg
 921         (Constraint_Error_Def'Access, File, Line);
 922    end Raise_Constraint_Error;
 923
 924    --------------------------------
 925    -- Raise_Constraint_Error_Msg --
 926    --------------------------------
 927
 928    procedure Raise_Constraint_Error_Msg
 929      (File : System.Address;
 930       Line : Integer;
 931       Msg  : System.Address)
 932    is
 933    begin
 934       Raise_With_Location_And_Msg
 935         (Constraint_Error_Def'Access, File, Line, Msg);
 936    end Raise_Constraint_Error_Msg;
 937
 938    -------------------------
 939    -- Raise_Current_Excep --
 940    -------------------------
 941
 942    procedure Raise_Current_Excep (E : Exception_Id) is
 943
 944       pragma Inspection_Point (E);
 945       --  This is so the debugger can reliably inspect the parameter when
 946       --  inserting a breakpoint at the start of this procedure.
 947
 948       Id : Exception_Id := E;
 949       pragma Volatile (Id);
 950       pragma Warnings (Off, Id);
 951       --  In order to provide support for breakpoints on unhandled exceptions,
 952       --  the debugger will also need to be able to inspect the value of E from
 953       --  another (inner) frame. So we need to make sure that if E is passed in
 954       --  a register, its value is also spilled on stack. For this, we store
 955       --  the parameter value in a local variable, and add a pragma Volatile to
 956       --  make sure it is spilled. The pragma Warnings (Off) is needed because
 957       --  the compiler knows that Id is not referenced and that this use of
 958       --  pragma Volatile is peculiar.
 959
 960    begin
 961       Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
 962       Process_Raise_Exception (E);
 963    end Raise_Current_Excep;
 964
 965    ---------------------
 966    -- Raise_Exception --
 967    ---------------------
 968
 969    procedure Raise_Exception
 970      (E       : Exception_Id;
 971       Message : String := "")
 972    is
 973       EF    : Exception_Id := E;
 974       Excep : constant EOA := Get_Current_Excep.all;
 975    begin
 976       --  Raise CE if E = Null_ID (AI-446)
 977
 978       if E = null then
 979          EF := Constraint_Error'Identity;
 980       end if;
 981
 982       --  Go ahead and raise appropriate exception
 983
 984       Exception_Data.Set_Exception_Msg (Excep, EF, Message);
 985       Abort_Defer.all;
 986       Raise_Current_Excep (EF);
 987    end Raise_Exception;
 988
 989    ----------------------------
 990    -- Raise_Exception_Always --
 991    ----------------------------
 992
 993    procedure Raise_Exception_Always
 994      (E       : Exception_Id;
 995       Message : String := "")
 996    is
 997       Excep : constant EOA := Get_Current_Excep.all;
 998    begin
 999       Exception_Data.Set_Exception_Msg (Excep, E, Message);
1000       Abort_Defer.all;
1001       Raise_Current_Excep (E);
1002    end Raise_Exception_Always;
1003
1004    ------------------------------
1005    -- Raise_Exception_No_Defer --
1006    ------------------------------
1007
1008    procedure Raise_Exception_No_Defer
1009      (E       : Exception_Id;
1010       Message : String := "")
1011    is
1012       Excep : constant EOA := Get_Current_Excep.all;
1013    begin
1014       Exception_Data.Set_Exception_Msg (Excep, E, Message);
1015
1016       --  Do not call Abort_Defer.all, as specified by the spec
1017
1018       Raise_Current_Excep (E);
1019    end Raise_Exception_No_Defer;
1020
1021    -------------------------------------
1022    -- Raise_From_Controlled_Operation --
1023    -------------------------------------
1024
1025    procedure Raise_From_Controlled_Operation
1026      (X : Ada.Exceptions.Exception_Occurrence)
1027    is
1028       Prefix             : constant String := "adjust/finalize raised ";
1029       Orig_Msg           : constant String := Exception_Message (X);
1030       Orig_Prefix_Length : constant Natural :=
1031         Integer'Min (Prefix'Length, Orig_Msg'Length);
1032       Orig_Prefix        : String renames Orig_Msg
1033         (Orig_Msg'First ..  Orig_Msg'First + Orig_Prefix_Length - 1);
1034    begin
1035       --  Message already has proper prefix, just re-reraise
1036
1037       if Orig_Prefix = Prefix then
1038          Raise_Exception_No_Defer
1039            (E       => Program_Error'Identity,
1040             Message => Orig_Msg);
1041
1042       else
1043          declare
1044             New_Msg  : constant String := Prefix & Exception_Name (X);
1045
1046          begin
1047             --  No message present, just provide our own
1048
1049             if Orig_Msg = "" then
1050                Raise_Exception_No_Defer
1051                  (E       => Program_Error'Identity,
1052                   Message => New_Msg);
1053
1054             --  Message present, add informational prefix
1055
1056             else
1057                Raise_Exception_No_Defer
1058                  (E       => Program_Error'Identity,
1059                   Message => New_Msg & ": " & Orig_Msg);
1060             end if;
1061          end;
1062       end if;
1063    end Raise_From_Controlled_Operation;
1064
1065    -------------------------------
1066    -- Raise_From_Signal_Handler --
1067    -------------------------------
1068
1069    procedure Raise_From_Signal_Handler
1070      (E : Exception_Id;
1071       M : System.Address)
1072    is
1073       Excep : constant EOA := Get_Current_Excep.all;
1074    begin
1075       Exception_Data.Set_Exception_C_Msg (Excep, E, M);
1076       Abort_Defer.all;
1077       Process_Raise_Exception (E);
1078    end Raise_From_Signal_Handler;
1079
1080    -------------------------
1081    -- Raise_Program_Error --
1082    -------------------------
1083
1084    procedure Raise_Program_Error
1085      (File : System.Address;
1086       Line : Integer)
1087    is
1088    begin
1089       Raise_With_Location_And_Msg
1090         (Program_Error_Def'Access, File, Line);
1091    end Raise_Program_Error;
1092
1093    -----------------------------
1094    -- Raise_Program_Error_Msg --
1095    -----------------------------
1096
1097    procedure Raise_Program_Error_Msg
1098      (File : System.Address;
1099       Line : Integer;
1100       Msg  : System.Address)
1101    is
1102    begin
1103       Raise_With_Location_And_Msg
1104         (Program_Error_Def'Access, File, Line, Msg);
1105    end Raise_Program_Error_Msg;
1106
1107    -------------------------
1108    -- Raise_Storage_Error --
1109    -------------------------
1110
1111    procedure Raise_Storage_Error
1112      (File : System.Address;
1113       Line : Integer)
1114    is
1115    begin
1116       Raise_With_Location_And_Msg
1117         (Storage_Error_Def'Access, File, Line);
1118    end Raise_Storage_Error;
1119
1120    -----------------------------
1121    -- Raise_Storage_Error_Msg --
1122    -----------------------------
1123
1124    procedure Raise_Storage_Error_Msg
1125      (File : System.Address;
1126       Line : Integer;
1127       Msg  : System.Address)
1128    is
1129    begin
1130       Raise_With_Location_And_Msg
1131         (Storage_Error_Def'Access, File, Line, Msg);
1132    end Raise_Storage_Error_Msg;
1133
1134    ---------------------------------
1135    -- Raise_With_Location_And_Msg --
1136    ---------------------------------
1137
1138    procedure Raise_With_Location_And_Msg
1139      (E : Exception_Id;
1140       F : System.Address;
1141       L : Integer;
1142       M : System.Address := System.Null_Address)
1143    is
1144       Excep : constant EOA := Get_Current_Excep.all;
1145    begin
1146       Exception_Data.Set_Exception_C_Msg (Excep, E, F, L, Msg2 => M);
1147       Abort_Defer.all;
1148       Raise_Current_Excep (E);
1149    end Raise_With_Location_And_Msg;
1150
1151    --------------------
1152    -- Raise_With_Msg --
1153    --------------------
1154
1155    procedure Raise_With_Msg (E : Exception_Id) is
1156       Excep : constant EOA := Get_Current_Excep.all;
1157
1158    begin
1159       Excep.Exception_Raised := False;
1160       Excep.Id               := E;
1161       Excep.Num_Tracebacks   := 0;
1162       Excep.Pid              := Local_Partition_ID;
1163       Abort_Defer.all;
1164       Raise_Current_Excep (E);
1165    end Raise_With_Msg;
1166
1167    -----------------------------------------
1168    -- Calls to Run-Time Check Subprograms --
1169    -----------------------------------------
1170
1171    procedure Rcheck_CE_Access_Check
1172      (File : System.Address; Line : Integer)
1173    is
1174    begin
1175       Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address);
1176    end Rcheck_CE_Access_Check;
1177
1178    procedure Rcheck_CE_Null_Access_Parameter
1179      (File : System.Address; Line : Integer)
1180    is
1181    begin
1182       Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address);
1183    end Rcheck_CE_Null_Access_Parameter;
1184
1185    procedure Rcheck_CE_Discriminant_Check
1186      (File : System.Address; Line : Integer)
1187    is
1188    begin
1189       Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address);
1190    end Rcheck_CE_Discriminant_Check;
1191
1192    procedure Rcheck_CE_Divide_By_Zero
1193      (File : System.Address; Line : Integer)
1194    is
1195    begin
1196       Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address);
1197    end Rcheck_CE_Divide_By_Zero;
1198
1199    procedure Rcheck_CE_Explicit_Raise
1200      (File : System.Address; Line : Integer)
1201    is
1202    begin
1203       Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address);
1204    end Rcheck_CE_Explicit_Raise;
1205
1206    procedure Rcheck_CE_Index_Check
1207      (File : System.Address; Line : Integer)
1208    is
1209    begin
1210       Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address);
1211    end Rcheck_CE_Index_Check;
1212
1213    procedure Rcheck_CE_Invalid_Data
1214      (File : System.Address; Line : Integer)
1215    is
1216    begin
1217       Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address);
1218    end Rcheck_CE_Invalid_Data;
1219
1220    procedure Rcheck_CE_Length_Check
1221      (File : System.Address; Line : Integer)
1222    is
1223    begin
1224       Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address);
1225    end Rcheck_CE_Length_Check;
1226
1227    procedure Rcheck_CE_Null_Exception_Id
1228      (File : System.Address; Line : Integer)
1229    is
1230    begin
1231       Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address);
1232    end Rcheck_CE_Null_Exception_Id;
1233
1234    procedure Rcheck_CE_Null_Not_Allowed
1235      (File : System.Address; Line : Integer)
1236    is
1237    begin
1238       Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address);
1239    end Rcheck_CE_Null_Not_Allowed;
1240
1241    procedure Rcheck_CE_Overflow_Check
1242      (File : System.Address; Line : Integer)
1243    is
1244    begin
1245       Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address);
1246    end Rcheck_CE_Overflow_Check;
1247
1248    procedure Rcheck_CE_Partition_Check
1249      (File : System.Address; Line : Integer)
1250    is
1251    begin
1252       Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address);
1253    end Rcheck_CE_Partition_Check;
1254
1255    procedure Rcheck_CE_Range_Check
1256      (File : System.Address; Line : Integer)
1257    is
1258    begin
1259       Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address);
1260    end Rcheck_CE_Range_Check;
1261
1262    procedure Rcheck_CE_Tag_Check
1263      (File : System.Address; Line : Integer)
1264    is
1265    begin
1266       Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address);
1267    end Rcheck_CE_Tag_Check;
1268
1269    procedure Rcheck_PE_Access_Before_Elaboration
1270      (File : System.Address; Line : Integer)
1271    is
1272    begin
1273       Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
1274    end Rcheck_PE_Access_Before_Elaboration;
1275
1276    procedure Rcheck_PE_Accessibility_Check
1277      (File : System.Address; Line : Integer)
1278    is
1279    begin
1280       Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
1281    end Rcheck_PE_Accessibility_Check;
1282
1283    procedure Rcheck_PE_Address_Of_Intrinsic
1284      (File : System.Address; Line : Integer)
1285    is
1286    begin
1287       Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
1288    end Rcheck_PE_Address_Of_Intrinsic;
1289
1290    procedure Rcheck_PE_Aliased_Parameters
1291      (File : System.Address; Line : Integer)
1292    is
1293    begin
1294       Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
1295    end Rcheck_PE_Aliased_Parameters;
1296
1297    procedure Rcheck_PE_All_Guards_Closed
1298      (File : System.Address; Line : Integer)
1299    is
1300    begin
1301       Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
1302    end Rcheck_PE_All_Guards_Closed;
1303
1304    procedure Rcheck_PE_Bad_Predicated_Generic_Type
1305      (File : System.Address; Line : Integer)
1306    is
1307    begin
1308       Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
1309    end Rcheck_PE_Bad_Predicated_Generic_Type;
1310
1311    procedure Rcheck_PE_Current_Task_In_Entry_Body
1312      (File : System.Address; Line : Integer)
1313    is
1314    begin
1315       Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
1316    end Rcheck_PE_Current_Task_In_Entry_Body;
1317
1318    procedure Rcheck_PE_Duplicated_Entry_Address
1319      (File : System.Address; Line : Integer)
1320    is
1321    begin
1322       Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
1323    end Rcheck_PE_Duplicated_Entry_Address;
1324
1325    procedure Rcheck_PE_Explicit_Raise
1326      (File : System.Address; Line : Integer)
1327    is
1328    begin
1329       Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
1330    end Rcheck_PE_Explicit_Raise;
1331
1332    procedure Rcheck_PE_Implicit_Return
1333      (File : System.Address; Line : Integer)
1334    is
1335    begin
1336       Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
1337    end Rcheck_PE_Implicit_Return;
1338
1339    procedure Rcheck_PE_Misaligned_Address_Value
1340      (File : System.Address; Line : Integer)
1341    is
1342    begin
1343       Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
1344    end Rcheck_PE_Misaligned_Address_Value;
1345
1346    procedure Rcheck_PE_Missing_Return
1347      (File : System.Address; Line : Integer)
1348    is
1349    begin
1350       Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
1351    end Rcheck_PE_Missing_Return;
1352
1353    procedure Rcheck_PE_Overlaid_Controlled_Object
1354      (File : System.Address; Line : Integer)
1355    is
1356    begin
1357       Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
1358    end Rcheck_PE_Overlaid_Controlled_Object;
1359
1360    procedure Rcheck_PE_Potentially_Blocking_Operation
1361      (File : System.Address; Line : Integer)
1362    is
1363    begin
1364       Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
1365    end Rcheck_PE_Potentially_Blocking_Operation;
1366
1367    procedure Rcheck_PE_Stubbed_Subprogram_Called
1368      (File : System.Address; Line : Integer)
1369    is
1370    begin
1371       Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
1372    end Rcheck_PE_Stubbed_Subprogram_Called;
1373
1374    procedure Rcheck_PE_Unchecked_Union_Restriction
1375      (File : System.Address; Line : Integer)
1376    is
1377    begin
1378       Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
1379    end Rcheck_PE_Unchecked_Union_Restriction;
1380
1381    procedure Rcheck_PE_Non_Transportable_Actual
1382      (File : System.Address; Line : Integer)
1383    is
1384    begin
1385       Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
1386    end Rcheck_PE_Non_Transportable_Actual;
1387
1388    procedure Rcheck_SE_Empty_Storage_Pool
1389      (File : System.Address; Line : Integer)
1390    is
1391    begin
1392       Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
1393    end Rcheck_SE_Empty_Storage_Pool;
1394
1395    procedure Rcheck_SE_Explicit_Raise
1396      (File : System.Address; Line : Integer)
1397    is
1398    begin
1399       Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
1400    end Rcheck_SE_Explicit_Raise;
1401
1402    procedure Rcheck_SE_Infinite_Recursion
1403      (File : System.Address; Line : Integer)
1404    is
1405    begin
1406       Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
1407    end Rcheck_SE_Infinite_Recursion;
1408
1409    procedure Rcheck_SE_Object_Too_Large
1410      (File : System.Address; Line : Integer)
1411    is
1412    begin
1413       Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
1414    end Rcheck_SE_Object_Too_Large;
1415
1416    procedure Rcheck_PE_Stream_Operation_Not_Allowed
1417      (File : System.Address; Line : Integer)
1418    is
1419    begin
1420       Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
1421    end Rcheck_PE_Stream_Operation_Not_Allowed;
1422
1423    procedure Rcheck_PE_Finalize_Raised_Exception
1424      (File : System.Address; Line : Integer)
1425    is
1426       E     : constant Exception_Id := Program_Error_Def'Access;
1427       Excep : constant EOA := Get_Current_Excep.all;
1428
1429    begin
1430       --  This is "finalize/adjust raised exception". This subprogram is always
1431       --  called with abort deferred, unlike all other Rcheck_* subprograms,
1432       --  itneeds to call Raise_Exception_No_Defer.
1433
1434       --  This is consistent with Raise_From_Controlled_Operation
1435
1436       Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0,
1437                                           Rmsg_23'Address);
1438       Raise_Current_Excep (E);
1439    end Rcheck_PE_Finalize_Raised_Exception;
1440
1441    procedure Rcheck_00 (File : System.Address; Line : Integer)
1442      renames Rcheck_CE_Access_Check;
1443    procedure Rcheck_01 (File : System.Address; Line : Integer)
1444      renames Rcheck_CE_Null_Access_Parameter;
1445    procedure Rcheck_02 (File : System.Address; Line : Integer)
1446      renames Rcheck_CE_Discriminant_Check;
1447    procedure Rcheck_03 (File : System.Address; Line : Integer)
1448      renames Rcheck_CE_Divide_By_Zero;
1449    procedure Rcheck_04 (File : System.Address; Line : Integer)
1450      renames Rcheck_CE_Explicit_Raise;
1451    procedure Rcheck_05 (File : System.Address; Line : Integer)
1452      renames Rcheck_CE_Index_Check;
1453    procedure Rcheck_06 (File : System.Address; Line : Integer)
1454      renames Rcheck_CE_Invalid_Data;
1455    procedure Rcheck_07 (File : System.Address; Line : Integer)
1456      renames Rcheck_CE_Length_Check;
1457    procedure Rcheck_08 (File : System.Address; Line : Integer)
1458      renames Rcheck_CE_Null_Exception_Id;
1459    procedure Rcheck_09 (File : System.Address; Line : Integer)
1460      renames Rcheck_CE_Null_Not_Allowed;
1461    procedure Rcheck_10 (File : System.Address; Line : Integer)
1462      renames Rcheck_CE_Overflow_Check;
1463    procedure Rcheck_11 (File : System.Address; Line : Integer)
1464      renames Rcheck_CE_Partition_Check;
1465    procedure Rcheck_12 (File : System.Address; Line : Integer)
1466      renames Rcheck_CE_Range_Check;
1467    procedure Rcheck_13 (File : System.Address; Line : Integer)
1468      renames Rcheck_CE_Tag_Check;
1469    procedure Rcheck_14 (File : System.Address; Line : Integer)
1470      renames Rcheck_PE_Access_Before_Elaboration;
1471    procedure Rcheck_15 (File : System.Address; Line : Integer)
1472      renames Rcheck_PE_Accessibility_Check;
1473    procedure Rcheck_16 (File : System.Address; Line : Integer)
1474      renames Rcheck_PE_Address_Of_Intrinsic;
1475    procedure Rcheck_17 (File : System.Address; Line : Integer)
1476      renames Rcheck_PE_Aliased_Parameters;
1477    procedure Rcheck_18 (File : System.Address; Line : Integer)
1478      renames Rcheck_PE_All_Guards_Closed;
1479    procedure Rcheck_19 (File : System.Address; Line : Integer)
1480      renames Rcheck_PE_Bad_Predicated_Generic_Type;
1481    procedure Rcheck_20 (File : System.Address; Line : Integer)
1482      renames Rcheck_PE_Current_Task_In_Entry_Body;
1483    procedure Rcheck_21 (File : System.Address; Line : Integer)
1484      renames Rcheck_PE_Duplicated_Entry_Address;
1485    procedure Rcheck_22 (File : System.Address; Line : Integer)
1486      renames Rcheck_PE_Explicit_Raise;
1487    procedure Rcheck_23 (File : System.Address; Line : Integer)
1488      renames Rcheck_PE_Finalize_Raised_Exception;
1489    procedure Rcheck_24 (File : System.Address; Line : Integer)
1490      renames Rcheck_PE_Implicit_Return;
1491    procedure Rcheck_25 (File : System.Address; Line : Integer)
1492      renames Rcheck_PE_Misaligned_Address_Value;
1493    procedure Rcheck_26 (File : System.Address; Line : Integer)
1494      renames Rcheck_PE_Missing_Return;
1495    procedure Rcheck_27 (File : System.Address; Line : Integer)
1496      renames Rcheck_PE_Overlaid_Controlled_Object;
1497    procedure Rcheck_28 (File : System.Address; Line : Integer)
1498      renames Rcheck_PE_Potentially_Blocking_Operation;
1499    procedure Rcheck_29 (File : System.Address; Line : Integer)
1500      renames Rcheck_PE_Stubbed_Subprogram_Called;
1501    procedure Rcheck_30 (File : System.Address; Line : Integer)
1502      renames Rcheck_PE_Unchecked_Union_Restriction;
1503    procedure Rcheck_31 (File : System.Address; Line : Integer)
1504      renames Rcheck_PE_Non_Transportable_Actual;
1505    procedure Rcheck_32 (File : System.Address; Line : Integer)
1506      renames Rcheck_SE_Empty_Storage_Pool;
1507    procedure Rcheck_33 (File : System.Address; Line : Integer)
1508      renames Rcheck_SE_Explicit_Raise;
1509    procedure Rcheck_34 (File : System.Address; Line : Integer)
1510      renames Rcheck_SE_Infinite_Recursion;
1511    procedure Rcheck_35 (File : System.Address; Line : Integer)
1512      renames Rcheck_SE_Object_Too_Large;
1513    procedure Rcheck_36 (File : System.Address; Line : Integer)
1514      renames Rcheck_PE_Stream_Operation_Not_Allowed;
1515
1516    -------------
1517    -- Reraise --
1518    -------------
1519
1520    procedure Reraise is
1521       Excep : constant EOA := Get_Current_Excep.all;
1522
1523    begin
1524       Abort_Defer.all;
1525       Raise_Current_Excep (Excep.Id);
1526    end Reraise;
1527
1528    --------------------------------------
1529    -- Reraise_Library_Exception_If_Any --
1530    --------------------------------------
1531
1532    procedure Reraise_Library_Exception_If_Any is
1533       LE : Exception_Occurrence;
1534    begin
1535       if Library_Exception_Set then
1536          LE := Library_Exception;
1537          Raise_From_Controlled_Operation (LE);
1538       end if;
1539    end Reraise_Library_Exception_If_Any;
1540
1541    ------------------------
1542    -- Reraise_Occurrence --
1543    ------------------------
1544
1545    procedure Reraise_Occurrence (X : Exception_Occurrence) is
1546    begin
1547       if X.Id /= null then
1548          Abort_Defer.all;
1549          Save_Occurrence (Get_Current_Excep.all.all, X);
1550          Raise_Current_Excep (X.Id);
1551       end if;
1552    end Reraise_Occurrence;
1553
1554    -------------------------------
1555    -- Reraise_Occurrence_Always --
1556    -------------------------------
1557
1558    procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
1559    begin
1560       Abort_Defer.all;
1561       Save_Occurrence (Get_Current_Excep.all.all, X);
1562       Raise_Current_Excep (X.Id);
1563    end Reraise_Occurrence_Always;
1564
1565    ---------------------------------
1566    -- Reraise_Occurrence_No_Defer --
1567    ---------------------------------
1568
1569    procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
1570    begin
1571       Save_Occurrence (Get_Current_Excep.all.all, X);
1572       Raise_Current_Excep (X.Id);
1573    end Reraise_Occurrence_No_Defer;
1574
1575    ---------------------
1576    -- Save_Occurrence --
1577    ---------------------
1578
1579    procedure Save_Occurrence
1580      (Target : out Exception_Occurrence;
1581       Source : Exception_Occurrence)
1582    is
1583    begin
1584       Target.Id             := Source.Id;
1585       Target.Msg_Length     := Source.Msg_Length;
1586       Target.Num_Tracebacks := Source.Num_Tracebacks;
1587       Target.Pid            := Source.Pid;
1588
1589       Target.Msg (1 .. Target.Msg_Length) :=
1590         Source.Msg (1 .. Target.Msg_Length);
1591
1592       Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
1593         Source.Tracebacks (1 .. Target.Num_Tracebacks);
1594    end Save_Occurrence;
1595
1596    function Save_Occurrence (Source : Exception_Occurrence) return EOA is
1597       Target : constant EOA := new Exception_Occurrence;
1598    begin
1599       Save_Occurrence (Target.all, Source);
1600       return Target;
1601    end Save_Occurrence;
1602
1603    -------------------
1604    -- String_To_EId --
1605    -------------------
1606
1607    function String_To_EId (S : String) return Exception_Id
1608      renames Stream_Attributes.String_To_EId;
1609
1610    ------------------
1611    -- String_To_EO --
1612    ------------------
1613
1614    function String_To_EO (S : String) return Exception_Occurrence
1615      renames Stream_Attributes.String_To_EO;
1616
1617    ---------------
1618    -- To_Stderr --
1619    ---------------
1620
1621    procedure To_Stderr (C : Character) is
1622       type int is new Integer;
1623
1624       procedure put_char_stderr (C : int);
1625       pragma Import (C, put_char_stderr, "put_char_stderr");
1626
1627    begin
1628       put_char_stderr (Character'Pos (C));
1629    end To_Stderr;
1630
1631    procedure To_Stderr (S : String) is
1632    begin
1633       for J in S'Range loop
1634          if S (J) /= ASCII.CR then
1635             To_Stderr (S (J));
1636          end if;
1637       end loop;
1638    end To_Stderr;
1639
1640    -------------------------
1641    -- Transfer_Occurrence --
1642    -------------------------
1643
1644    procedure Transfer_Occurrence
1645      (Target : Exception_Occurrence_Access;
1646       Source : Exception_Occurrence)
1647    is
1648    begin
1649       Save_Occurrence (Target.all, Source);
1650    end Transfer_Occurrence;
1651
1652    ------------------------
1653    -- Triggered_By_Abort --
1654    ------------------------
1655
1656    function Triggered_By_Abort return Boolean is
1657       Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
1658    begin
1659       return Ex /= null
1660         and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
1661    end Triggered_By_Abort;
1662
1663 end Ada.Exceptions;