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