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