gcc/ada/libgnat/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-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Style_Checks (All_Checks);
  33 --  No subprogram ordering check, due to logical grouping
  34
  35 with System;                  use System;
  36 with System.Exceptions;       use System.Exceptions;
  37 with System.Exceptions_Debug; use System.Exceptions_Debug;
  38 with System.Standard_Library; use System.Standard_Library;
  39 with System.Soft_Links;       use System.Soft_Links;
  40 with System.WCh_Con;          use System.WCh_Con;
  41 with System.WCh_StW;          use System.WCh_StW;
  42
  43 pragma Warnings (Off);
  44 --  Suppress complaints about Symbolic not being referenced, and about it not
  45 --  having pragma Preelaborate.
  46 with System.Traceback.Symbolic;
  47 --  Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version,
  48 --  it will install symbolic tracebacks as the default decorator. Otherwise,
  49 --  symbolic tracebacks are not supported, and we fall back to hexadecimal
  50 --  addresses.
  51 pragma Warnings (On);
  52
  53 package body Ada.Exceptions is
  54
  55    pragma Suppress (All_Checks);
  56    --  We definitely do not want exceptions occurring within this unit, or
  57    --  we are in big trouble. If an exceptional situation does occur, better
  58    --  that it not be raised, since raising it can cause confusing chaos.
  59
  60    -----------------------
  61    -- Local Subprograms --
  62    -----------------------
  63
  64    --  Note: the exported subprograms in this package body are called directly
  65    --  from C clients using the given external name, even though they are not
  66    --  technically visible in the Ada sense.
  67
  68    procedure AAA;
  69    procedure ZZZ;
  70    --  Start and end of procedures in this package
  71    --
  72    --  These procedures are used to provide exclusion bounds in calls to
  73    --  Call_Chain at exception raise points from this unit. The purpose is
  74    --  to arrange for the exception tracebacks not to include frames from
  75    --  subprograms involved in the raise process, as these are meaningless
  76    --  from the user's standpoint.
  77    --
  78    --  For these bounds to be meaningful, we need to ensure that the object
  79    --  code for the subprograms involved in processing a raise is located after
  80    --  the object code AAA and before the object code ZZZ. This will indeed be
  81    --  the case as long as the following rules are respected:
  82    --
  83    --  1) The bodies of the subprograms involved in processing a raise
  84    --     are located after the body of AAA and before the body of ZZZ.
  85    --
  86    --  2) No pragma Inline applies to any of these subprograms, as this
  87    --     could delay the corresponding assembly output until the end of
  88    --     the unit.
  89    --
  90    --  To obtain the address of AAA and ZZZ, use the Code_Address attribute
  91    --  instead of the Address attribute as the latter will return the address
  92    --  of a stub or descriptor on some platforms. This include IA-64,
  93    --  PowerPC/AIX, big-endian PowerPC64 and HPUX.
  94
  95    procedure Call_Chain (Excep : EOA);
  96    --  Store up to Max_Tracebacks in Excep, corresponding to the current
  97    --  call chain.
  98
  99    function Image (Index : Integer) return String;
 100    --  Return string image corresponding to Index
 101
 102    procedure To_Stderr (S : String);
 103    pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
 104    --  Little routine to output string to stderr that is also used
 105    --  in the tasking run time.
 106
 107    procedure To_Stderr (C : Character);
 108    pragma Inline (To_Stderr);
 109    pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
 110    --  Little routine to output a character to stderr, used by some of
 111    --  the separate units below.
 112
 113    package Exception_Data is
 114
 115       -----------------------------------
 116       -- Exception Message Subprograms --
 117       -----------------------------------
 118
 119       procedure Set_Exception_C_Msg
 120         (Excep  : EOA;
 121          Id     : Exception_Id;
 122          Msg1   : System.Address;
 123          Line   : Integer        := 0;
 124          Column : Integer        := 0;
 125          Msg2   : System.Address := System.Null_Address);
 126       --  This routine is called to setup the exception referenced by X
 127       --  to contain the indicated Id value and message. Msg1 is a null
 128       --  terminated string which is generated as the exception message. If
 129       --  line is non-zero, then a colon and the decimal representation of
 130       --  this integer is appended to the message. Ditto for Column. When Msg2
 131       --  is non-null, a space and this additional null terminated string is
 132       --  added to the message.
 133
 134       procedure Set_Exception_Msg
 135         (Excep   : EOA;
 136          Id      : Exception_Id;
 137          Message : String);
 138       --  This routine is called to setup the exception referenced by X
 139       --  to contain the indicated Id value and message. Message is a string
 140       --  which is generated as the exception message.
 141
 142       ---------------------------------------
 143       -- Exception Information Subprograms --
 144       ---------------------------------------
 145
 146       function Untailored_Exception_Information
 147         (X : Exception_Occurrence) return String;
 148       --  This is used by Stream_Attributes.EO_To_String to convert an
 149       --  Exception_Occurrence to a String for the stream attributes.
 150       --  String_To_EO understands the format, as documented here.
 151       --
 152       --  The format of the string is as follows:
 153       --
 154       --    raised <exception name> : <message>
 155       --    (" : <message>" is present only if Exception_Message is not empty)
 156       --    PID=nnnn (only if nonzero)
 157       --    Call stack traceback locations:  (only if at least one location)
 158       --    <0xyyyyyyyy 0xyyyyyyyy ...>      (is recorded)
 159       --
 160       --  The lines are separated by a ASCII.LF character.
 161       --  The nnnn is the partition Id given as decimal digits.
 162       --  The 0x... line represents traceback program counter locations, in
 163       --  execution order with the first one being the exception location.
 164       --
 165       --  The Exception_Name and Message lines are omitted in the abort
 166       --  signal case, since this is not really an exception.
 167       --
 168       --  Note: If the format of the generated string is changed, please note
 169       --  that an equivalent modification to the routine String_To_EO must be
 170       --  made to preserve proper functioning of the stream attributes.
 171
 172       function Exception_Information (X : Exception_Occurrence) return String;
 173       --  This is the implementation of Ada.Exceptions.Exception_Information,
 174       --  as defined in the Ada RM.
 175       --
 176       --  If no traceback decorator (see GNAT.Exception_Traces) is currently
 177       --  in place, this is the same as Untailored_Exception_Information.
 178       --  Otherwise, the decorator is used to produce a symbolic traceback
 179       --  instead of hexadecimal addresses.
 180       --
 181       --  Note that unlike Untailored_Exception_Information, there is no need
 182       --  to keep the output of Exception_Information stable for streaming
 183       --  purposes, and in fact the output differs across platforms.
 184
 185    end Exception_Data;
 186
 187    package Exception_Traces is
 188
 189       -------------------------------------------------
 190       -- Run-Time Exception Notification Subprograms --
 191       -------------------------------------------------
 192
 193       --  These subprograms provide a common run-time interface to trigger the
 194       --  actions required when an exception is about to be propagated (e.g.
 195       --  user specified actions or output of exception information). They are
 196       --  exported to be usable by the Ada exception handling personality
 197       --  routine when the GCC 3 mechanism is used.
 198
 199       procedure Notify_Handled_Exception (Excep : EOA);
 200       pragma Export
 201         (C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
 202       --  This routine is called for a handled occurrence is about to be
 203       --  propagated.
 204
 205       procedure Notify_Unhandled_Exception (Excep : EOA);
 206       pragma Export
 207         (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
 208       --  This routine is called when an unhandled occurrence is about to be
 209       --  propagated.
 210
 211       procedure Unhandled_Exception_Terminate (Excep : EOA);
 212       pragma No_Return (Unhandled_Exception_Terminate);
 213       --  This procedure is called to terminate execution following an
 214       --  unhandled exception. The exception information, including
 215       --  traceback if available is output, and execution is then
 216       --  terminated. Note that at the point where this routine is
 217       --  called, the stack has typically been destroyed.
 218
 219    end Exception_Traces;
 220
 221    package Exception_Propagation is
 222
 223       ---------------------------------------
 224       -- Exception Propagation Subprograms --
 225       ---------------------------------------
 226
 227       function Allocate_Occurrence return EOA;
 228       --  Allocate an exception occurrence (as well as the machine occurrence)
 229
 230       procedure Propagate_Exception (Excep : Exception_Occurrence);
 231       pragma No_Return (Propagate_Exception);
 232       pragma Machine_Attribute (Propagate_Exception, "expected_throw");
 233       --  This procedure propagates the exception represented by Excep
 234
 235    end Exception_Propagation;
 236
 237    package Stream_Attributes is
 238
 239       ----------------------------------
 240       -- Stream Attribute Subprograms --
 241       ----------------------------------
 242
 243       function EId_To_String (X : Exception_Id) return String;
 244       function String_To_EId (S : String) return Exception_Id;
 245       --  Functions for implementing Exception_Id stream attributes
 246
 247       function EO_To_String (X : Exception_Occurrence) return String;
 248       function String_To_EO (S : String) return Exception_Occurrence;
 249       --  Functions for implementing Exception_Occurrence stream
 250       --  attributes
 251
 252    end Stream_Attributes;
 253
 254    procedure Complete_Occurrence (X : EOA);
 255    --  Finish building the occurrence: save the call chain and notify the
 256    --  debugger.
 257
 258    procedure Complete_And_Propagate_Occurrence (X : EOA);
 259    pragma No_Return (Complete_And_Propagate_Occurrence);
 260    pragma Machine_Attribute (Complete_And_Propagate_Occurrence,
 261                              "expected_throw");
 262    --  This is a simple wrapper to Complete_Occurrence and
 263    --  Exception_Propagation.Propagate_Exception.
 264
 265    function Create_Occurrence_From_Signal_Handler
 266      (E : Exception_Id;
 267       M : System.Address) return EOA;
 268    --  Create and build an exception occurrence using exception id E and
 269    --  nul-terminated message M.
 270
 271    function Create_Machine_Occurrence_From_Signal_Handler
 272      (E : Exception_Id;
 273       M : System.Address) return System.Address;
 274    pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler,
 275                   "__gnat_create_machine_occurrence_from_signal_handler");
 276    --  Create and build an exception occurrence using exception id E and
 277    --  nul-terminated message M. Return the machine occurrence.
 278
 279    procedure Raise_Exception_No_Defer
 280      (E       : Exception_Id;
 281       Message : String := "");
 282    pragma Export
 283     (Ada, Raise_Exception_No_Defer,
 284      "ada__exceptions__raise_exception_no_defer");
 285    pragma No_Return (Raise_Exception_No_Defer);
 286    pragma Machine_Attribute (Raise_Exception_No_Defer, "expected_throw");
 287    --  Similar to Raise_Exception, but with no abort deferral
 288
 289    procedure Raise_From_Signal_Handler
 290      (E : Exception_Id;
 291       M : System.Address);
 292    pragma Export
 293      (C, Raise_From_Signal_Handler, "__gnat_raise_from_signal_handler");
 294    pragma No_Return (Raise_From_Signal_Handler);
 295    pragma Machine_Attribute (Raise_From_Signal_Handler, "expected_throw");
 296    --  This routine is used to raise an exception from a signal handler. The
 297    --  signal handler has already stored the machine state (i.e. the state that
 298    --  corresponds to the location at which the signal was raised). E is the
 299    --  Exception_Id specifying what exception is being raised, and M is a
 300    --  pointer to a null-terminated string which is the message to be raised.
 301    --  Note that this routine never returns, so it is permissible to simply
 302    --  jump to this routine, rather than call it. This may be appropriate for
 303    --  systems where the right way to get out of signal handler is to alter the
 304    --  PC value in the machine state or in some other way ask the operating
 305    --  system to return here rather than to the original location.
 306
 307    procedure Raise_With_Msg (E : Exception_Id);
 308    pragma No_Return (Raise_With_Msg);
 309    pragma Machine_Attribute (Raise_With_Msg, "expected_throw");
 310    pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
 311    --  Raises an exception with given exception id value. A message
 312    --  is associated with the raise, and has already been stored in the
 313    --  exception occurrence referenced by the Current_Excep in the TSD.
 314    --  Abort is deferred before the raise call.
 315
 316    procedure Raise_With_Location_And_Msg
 317      (E : Exception_Id;
 318       F : System.Address;
 319       L : Integer;
 320       C : Integer := 0;
 321       M : System.Address := System.Null_Address);
 322    pragma No_Return (Raise_With_Location_And_Msg);
 323    pragma Machine_Attribute (Raise_With_Location_And_Msg, "expected_throw");
 324    --  Raise an exception with given exception id value. A filename and line
 325    --  number is associated with the raise and is stored in the exception
 326    --  occurrence and in addition a column and a string message M may be
 327    --  appended to this (if not null/0).
 328
 329    procedure Raise_Constraint_Error (File : System.Address; Line : Integer);
 330    pragma No_Return (Raise_Constraint_Error);
 331    pragma Machine_Attribute (Raise_Constraint_Error, "expected_throw");
 332    pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
 333    --  Raise constraint error with file:line information
 334
 335    procedure Raise_Constraint_Error_Msg
 336      (File   : System.Address;
 337       Line   : Integer;
 338       Column : Integer;
 339       Msg    : System.Address);
 340    pragma No_Return (Raise_Constraint_Error_Msg);
 341    pragma Machine_Attribute (Raise_Constraint_Error_Msg, "expected_throw");
 342    pragma Export
 343      (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
 344    --  Raise constraint error with file:line:col + msg information
 345
 346    procedure Raise_Program_Error (File : System.Address; Line : Integer);
 347    pragma No_Return (Raise_Program_Error);
 348    pragma Machine_Attribute (Raise_Program_Error, "expected_throw");
 349    pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error");
 350    --  Raise program error with file:line information
 351
 352    procedure Raise_Program_Error_Msg
 353      (File : System.Address;
 354       Line : Integer;
 355       Msg  : System.Address);
 356    pragma No_Return (Raise_Program_Error_Msg);
 357    pragma Machine_Attribute (Raise_Program_Error_Msg, "expected_throw");
 358    pragma Export
 359      (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
 360    --  Raise program error with file:line + msg information
 361
 362    procedure Raise_Storage_Error (File : System.Address; Line : Integer);
 363    pragma No_Return (Raise_Storage_Error);
 364    pragma Machine_Attribute (Raise_Storage_Error, "expected_throw");
 365    pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error");
 366    --  Raise storage error with file:line information
 367
 368    procedure Raise_Storage_Error_Msg
 369      (File : System.Address;
 370       Line : Integer;
 371       Msg  : System.Address);
 372    pragma No_Return (Raise_Storage_Error_Msg);
 373    pragma Machine_Attribute (Raise_Storage_Error_Msg, "expected_throw");
 374    pragma Export
 375      (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
 376    --  Raise storage error with file:line + reason msg information
 377
 378    --  The exception raising process and the automatic tracing mechanism rely
 379    --  on some careful use of flags attached to the exception occurrence. The
 380    --  graph below illustrates the relations between the Raise_ subprograms
 381    --  and identifies the points where basic flags such as Exception_Raised
 382    --  are initialized.
 383
 384    --  (i) signs indicate the flags initialization points. R stands for Raise,
 385    --  W for With, and E for Exception.
 386
 387    --                   R_No_Msg    R_E   R_Pe  R_Ce  R_Se
 388    --                       |        |     |     |     |
 389    --                       +--+  +--+     +---+ | +---+
 390    --                          |  |            | | |
 391    --     R_E_No_Defer(i)    R_W_Msg(i)       R_W_Loc
 392    --           |               |              |   |
 393    --           +------------+  |  +-----------+   +--+
 394    --                        |  |  |                  |
 395    --                        |  |  |             Set_E_C_Msg(i)
 396    --                        |  |  |
 397    --            Complete_And_Propagate_Occurrence
 398
 399    procedure Reraise;
 400    pragma No_Return (Reraise);
 401    pragma Machine_Attribute (Reraise, "expected_throw");
 402    pragma Export (C, Reraise, "__gnat_reraise");
 403    --  Reraises the exception referenced by the Current_Excep field
 404    --  of the TSD (all fields of this exception occurrence are set).
 405    --  Abort is deferred before the reraise operation. Called from
 406    --  System.Tasking.RendezVous.Exceptional_Complete_RendezVous
 407
 408    procedure Transfer_Occurrence
 409      (Target : Exception_Occurrence_Access;
 410       Source : Exception_Occurrence);
 411    pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
 412    --  Called from s-tasren.adb:Local_Complete_RendezVous and
 413    --  s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from
 414    --  Source as an exception to be propagated in the caller task. Target is
 415    --  expected to be a pointer to the fixed TSD occurrence for this task.
 416
 417    --------------------------------
 418    -- Run-Time Check Subprograms --
 419    --------------------------------
 420
 421    --  These subprograms raise a specific exception with a reason message
 422    --  attached. The parameters are the file name and line number in each
 423    --  case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
 424
 425    procedure Rcheck_CE_Access_Check
 426      (File : System.Address; Line : Integer);
 427    procedure Rcheck_CE_Null_Access_Parameter
 428      (File : System.Address; Line : Integer);
 429    procedure Rcheck_CE_Discriminant_Check
 430      (File : System.Address; Line : Integer);
 431    procedure Rcheck_CE_Divide_By_Zero
 432      (File : System.Address; Line : Integer);
 433    procedure Rcheck_CE_Explicit_Raise
 434      (File : System.Address; Line : Integer);
 435    procedure Rcheck_CE_Index_Check
 436      (File : System.Address; Line : Integer);
 437    procedure Rcheck_CE_Invalid_Data
 438      (File : System.Address; Line : Integer);
 439    procedure Rcheck_CE_Length_Check
 440      (File : System.Address; Line : Integer);
 441    procedure Rcheck_CE_Null_Exception_Id
 442      (File : System.Address; Line : Integer);
 443    procedure Rcheck_CE_Null_Not_Allowed
 444      (File : System.Address; Line : Integer);
 445    procedure Rcheck_CE_Overflow_Check
 446      (File : System.Address; Line : Integer);
 447    procedure Rcheck_CE_Partition_Check
 448      (File : System.Address; Line : Integer);
 449    procedure Rcheck_CE_Range_Check
 450      (File : System.Address; Line : Integer);
 451    procedure Rcheck_CE_Tag_Check
 452      (File : System.Address; Line : Integer);
 453    procedure Rcheck_PE_Access_Before_Elaboration
 454      (File : System.Address; Line : Integer);
 455    procedure Rcheck_PE_Accessibility_Check
 456      (File : System.Address; Line : Integer);
 457    procedure Rcheck_PE_Address_Of_Intrinsic
 458      (File : System.Address; Line : Integer);
 459    procedure Rcheck_PE_Aliased_Parameters
 460      (File : System.Address; Line : Integer);
 461    procedure Rcheck_PE_All_Guards_Closed
 462      (File : System.Address; Line : Integer);
 463    procedure Rcheck_PE_Bad_Predicated_Generic_Type
 464      (File : System.Address; Line : Integer);
 465    procedure Rcheck_PE_Build_In_Place_Mismatch
 466      (File : System.Address; Line : Integer);
 467    procedure Rcheck_PE_Current_Task_In_Entry_Body
 468      (File : System.Address; Line : Integer);
 469    procedure Rcheck_PE_Duplicated_Entry_Address
 470      (File : System.Address; Line : Integer);
 471    procedure Rcheck_PE_Explicit_Raise
 472      (File : System.Address; Line : Integer);
 473    procedure Rcheck_PE_Implicit_Return
 474      (File : System.Address; Line : Integer);
 475    procedure Rcheck_PE_Misaligned_Address_Value
 476      (File : System.Address; Line : Integer);
 477    procedure Rcheck_PE_Missing_Return
 478      (File : System.Address; Line : Integer);
 479    procedure Rcheck_PE_Non_Transportable_Actual
 480      (File : System.Address; Line : Integer);
 481    procedure Rcheck_PE_Overlaid_Controlled_Object
 482      (File : System.Address; Line : Integer);
 483    procedure Rcheck_PE_Potentially_Blocking_Operation
 484      (File : System.Address; Line : Integer);
 485    procedure Rcheck_PE_Stubbed_Subprogram_Called
 486      (File : System.Address; Line : Integer);
 487    procedure Rcheck_PE_Unchecked_Union_Restriction
 488      (File : System.Address; Line : Integer);
 489    procedure Rcheck_SE_Empty_Storage_Pool
 490      (File : System.Address; Line : Integer);
 491    procedure Rcheck_SE_Explicit_Raise
 492      (File : System.Address; Line : Integer);
 493    procedure Rcheck_SE_Infinite_Recursion
 494      (File : System.Address; Line : Integer);
 495    procedure Rcheck_SE_Object_Too_Large
 496      (File : System.Address; Line : Integer);
 497    procedure Rcheck_PE_Stream_Operation_Not_Allowed
 498      (File : System.Address; Line : Integer);
 499    procedure Rcheck_CE_Access_Check_Ext
 500      (File : System.Address; Line, Column : Integer);
 501    procedure Rcheck_CE_Index_Check_Ext
 502      (File : System.Address; Line, Column, Index, First, Last : Integer);
 503    procedure Rcheck_CE_Invalid_Data_Ext
 504      (File : System.Address; Line, Column, Index, First, Last : Integer);
 505    procedure Rcheck_CE_Range_Check_Ext
 506      (File : System.Address; Line, Column, Index, First, Last : Integer);
 507
 508    procedure Rcheck_PE_Finalize_Raised_Exception
 509      (File : System.Address; Line : Integer);
 510    --  This routine is separated out because it has quite different behavior
 511    --  from the others. This is the "finalize/adjust raised exception". This
 512    --  subprogram is always called with abort deferred, unlike all other
 513    --  Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer.
 514
 515    pragma Export (C, Rcheck_CE_Access_Check,
 516                   "__gnat_rcheck_CE_Access_Check");
 517    pragma Export (C, Rcheck_CE_Null_Access_Parameter,
 518                   "__gnat_rcheck_CE_Null_Access_Parameter");
 519    pragma Export (C, Rcheck_CE_Discriminant_Check,
 520                   "__gnat_rcheck_CE_Discriminant_Check");
 521    pragma Export (C, Rcheck_CE_Divide_By_Zero,
 522                   "__gnat_rcheck_CE_Divide_By_Zero");
 523    pragma Export (C, Rcheck_CE_Explicit_Raise,
 524                   "__gnat_rcheck_CE_Explicit_Raise");
 525    pragma Export (C, Rcheck_CE_Index_Check,
 526                   "__gnat_rcheck_CE_Index_Check");
 527    pragma Export (C, Rcheck_CE_Invalid_Data,
 528                   "__gnat_rcheck_CE_Invalid_Data");
 529    pragma Export (C, Rcheck_CE_Length_Check,
 530                   "__gnat_rcheck_CE_Length_Check");
 531    pragma Export (C, Rcheck_CE_Null_Exception_Id,
 532                   "__gnat_rcheck_CE_Null_Exception_Id");
 533    pragma Export (C, Rcheck_CE_Null_Not_Allowed,
 534                   "__gnat_rcheck_CE_Null_Not_Allowed");
 535    pragma Export (C, Rcheck_CE_Overflow_Check,
 536                   "__gnat_rcheck_CE_Overflow_Check");
 537    pragma Export (C, Rcheck_CE_Partition_Check,
 538                   "__gnat_rcheck_CE_Partition_Check");
 539    pragma Export (C, Rcheck_CE_Range_Check,
 540                   "__gnat_rcheck_CE_Range_Check");
 541    pragma Export (C, Rcheck_CE_Tag_Check,
 542                   "__gnat_rcheck_CE_Tag_Check");
 543    pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
 544                   "__gnat_rcheck_PE_Access_Before_Elaboration");
 545    pragma Export (C, Rcheck_PE_Accessibility_Check,
 546                   "__gnat_rcheck_PE_Accessibility_Check");
 547    pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
 548                   "__gnat_rcheck_PE_Address_Of_Intrinsic");
 549    pragma Export (C, Rcheck_PE_Aliased_Parameters,
 550                   "__gnat_rcheck_PE_Aliased_Parameters");
 551    pragma Export (C, Rcheck_PE_All_Guards_Closed,
 552                   "__gnat_rcheck_PE_All_Guards_Closed");
 553    pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
 554                   "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
 555    pragma Export (C, Rcheck_PE_Build_In_Place_Mismatch,
 556                   "__gnat_rcheck_PE_Build_In_Place_Mismatch");
 557    pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
 558                   "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
 559    pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
 560                   "__gnat_rcheck_PE_Duplicated_Entry_Address");
 561    pragma Export (C, Rcheck_PE_Explicit_Raise,
 562                   "__gnat_rcheck_PE_Explicit_Raise");
 563    pragma Export (C, Rcheck_PE_Finalize_Raised_Exception,
 564                   "__gnat_rcheck_PE_Finalize_Raised_Exception");
 565    pragma Export (C, Rcheck_PE_Implicit_Return,
 566                   "__gnat_rcheck_PE_Implicit_Return");
 567    pragma Export (C, Rcheck_PE_Misaligned_Address_Value,
 568                   "__gnat_rcheck_PE_Misaligned_Address_Value");
 569    pragma Export (C, Rcheck_PE_Missing_Return,
 570                   "__gnat_rcheck_PE_Missing_Return");
 571    pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
 572                   "__gnat_rcheck_PE_Non_Transportable_Actual");
 573    pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
 574                   "__gnat_rcheck_PE_Overlaid_Controlled_Object");
 575    pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
 576                   "__gnat_rcheck_PE_Potentially_Blocking_Operation");
 577    pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
 578                   "__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
 579    pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
 580                   "__gnat_rcheck_PE_Stubbed_Subprogram_Called");
 581    pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
 582                   "__gnat_rcheck_PE_Unchecked_Union_Restriction");
 583    pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
 584                   "__gnat_rcheck_SE_Empty_Storage_Pool");
 585    pragma Export (C, Rcheck_SE_Explicit_Raise,
 586                   "__gnat_rcheck_SE_Explicit_Raise");
 587    pragma Export (C, Rcheck_SE_Infinite_Recursion,
 588                   "__gnat_rcheck_SE_Infinite_Recursion");
 589    pragma Export (C, Rcheck_SE_Object_Too_Large,
 590                   "__gnat_rcheck_SE_Object_Too_Large");
 591
 592    pragma Export (C, Rcheck_CE_Access_Check_Ext,
 593                   "__gnat_rcheck_CE_Access_Check_ext");
 594    pragma Export (C, Rcheck_CE_Index_Check_Ext,
 595                   "__gnat_rcheck_CE_Index_Check_ext");
 596    pragma Export (C, Rcheck_CE_Invalid_Data_Ext,
 597                   "__gnat_rcheck_CE_Invalid_Data_ext");
 598    pragma Export (C, Rcheck_CE_Range_Check_Ext,
 599                   "__gnat_rcheck_CE_Range_Check_ext");
 600
 601    --  None of these procedures ever returns (they raise an exception). By
 602    --  using pragma No_Return, we ensure that any junk code after the call,
 603    --  such as normal return epilogue stuff, can be eliminated).
 604
 605    pragma No_Return (Rcheck_CE_Access_Check);
 606    pragma No_Return (Rcheck_CE_Null_Access_Parameter);
 607    pragma No_Return (Rcheck_CE_Discriminant_Check);
 608    pragma No_Return (Rcheck_CE_Divide_By_Zero);
 609    pragma No_Return (Rcheck_CE_Explicit_Raise);
 610    pragma No_Return (Rcheck_CE_Index_Check);
 611    pragma No_Return (Rcheck_CE_Invalid_Data);
 612    pragma No_Return (Rcheck_CE_Length_Check);
 613    pragma No_Return (Rcheck_CE_Null_Exception_Id);
 614    pragma No_Return (Rcheck_CE_Null_Not_Allowed);
 615    pragma No_Return (Rcheck_CE_Overflow_Check);
 616    pragma No_Return (Rcheck_CE_Partition_Check);
 617    pragma No_Return (Rcheck_CE_Range_Check);
 618    pragma No_Return (Rcheck_CE_Tag_Check);
 619    pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
 620    pragma No_Return (Rcheck_PE_Accessibility_Check);
 621    pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
 622    pragma No_Return (Rcheck_PE_Aliased_Parameters);
 623    pragma No_Return (Rcheck_PE_All_Guards_Closed);
 624    pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
 625    pragma No_Return (Rcheck_PE_Build_In_Place_Mismatch);
 626    pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
 627    pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
 628    pragma No_Return (Rcheck_PE_Explicit_Raise);
 629    pragma No_Return (Rcheck_PE_Implicit_Return);
 630    pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
 631    pragma No_Return (Rcheck_PE_Missing_Return);
 632    pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
 633    pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
 634    pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
 635    pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
 636    pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
 637    pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
 638    pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
 639    pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
 640    pragma No_Return (Rcheck_SE_Explicit_Raise);
 641    pragma No_Return (Rcheck_SE_Infinite_Recursion);
 642    pragma No_Return (Rcheck_SE_Object_Too_Large);
 643
 644    pragma No_Return (Rcheck_CE_Access_Check_Ext);
 645    pragma No_Return (Rcheck_CE_Index_Check_Ext);
 646    pragma No_Return (Rcheck_CE_Invalid_Data_Ext);
 647    pragma No_Return (Rcheck_CE_Range_Check_Ext);
 648
 649    --  These procedures are all expected to raise an exception.
 650    --  These attributes are not visible to callers; they are made
 651    --  visible in trans.c:build_raise_check.
 652
 653    pragma Machine_Attribute (Rcheck_CE_Access_Check,
 654                              "expected_throw");
 655    pragma Machine_Attribute (Rcheck_CE_Null_Access_Parameter,
 656                              "expected_throw");
 657    pragma Machine_Attribute (Rcheck_CE_Discriminant_Check,
 658                              "expected_throw");
 659    pragma Machine_Attribute (Rcheck_CE_Divide_By_Zero,
 660                              "expected_throw");
 661    pragma Machine_Attribute (Rcheck_CE_Explicit_Raise,
 662                              "expected_throw");
 663    pragma Machine_Attribute (Rcheck_CE_Index_Check,
 664                              "expected_throw");
 665    pragma Machine_Attribute (Rcheck_CE_Invalid_Data,
 666                              "expected_throw");
 667    pragma Machine_Attribute (Rcheck_CE_Length_Check,
 668                              "expected_throw");
 669    pragma Machine_Attribute (Rcheck_CE_Null_Exception_Id,
 670                              "expected_throw");
 671    pragma Machine_Attribute (Rcheck_CE_Null_Not_Allowed,
 672                              "expected_throw");
 673    pragma Machine_Attribute (Rcheck_CE_Overflow_Check,
 674                              "expected_throw");
 675    pragma Machine_Attribute (Rcheck_CE_Partition_Check,
 676                              "expected_throw");
 677    pragma Machine_Attribute (Rcheck_CE_Range_Check,
 678                              "expected_throw");
 679    pragma Machine_Attribute (Rcheck_CE_Tag_Check,
 680                              "expected_throw");
 681    pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
 682                              "expected_throw");
 683    pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
 684                              "expected_throw");
 685    pragma Machine_Attribute (Rcheck_PE_Address_Of_Intrinsic,
 686                              "expected_throw");
 687    pragma Machine_Attribute (Rcheck_PE_Aliased_Parameters,
 688                              "expected_throw");
 689    pragma Machine_Attribute (Rcheck_PE_All_Guards_Closed,
 690                              "expected_throw");
 691    pragma Machine_Attribute (Rcheck_PE_Bad_Predicated_Generic_Type,
 692                              "expected_throw");
 693    pragma Machine_Attribute (Rcheck_PE_Build_In_Place_Mismatch,
 694                              "expected_throw");
 695    pragma Machine_Attribute (Rcheck_PE_Current_Task_In_Entry_Body,
 696                              "expected_throw");
 697    pragma Machine_Attribute (Rcheck_PE_Duplicated_Entry_Address,
 698                              "expected_throw");
 699    pragma Machine_Attribute (Rcheck_PE_Explicit_Raise,
 700                              "expected_throw");
 701    pragma Machine_Attribute (Rcheck_PE_Implicit_Return,
 702                              "expected_throw");
 703    pragma Machine_Attribute (Rcheck_PE_Misaligned_Address_Value,
 704                              "expected_throw");
 705    pragma Machine_Attribute (Rcheck_PE_Missing_Return,
 706                              "expected_throw");
 707    pragma Machine_Attribute (Rcheck_PE_Non_Transportable_Actual,
 708                              "expected_throw");
 709    pragma Machine_Attribute (Rcheck_PE_Overlaid_Controlled_Object,
 710                              "expected_throw");
 711    pragma Machine_Attribute (Rcheck_PE_Potentially_Blocking_Operation,
 712                              "expected_throw");
 713    pragma Machine_Attribute (Rcheck_PE_Stream_Operation_Not_Allowed,
 714                              "expected_throw");
 715    pragma Machine_Attribute (Rcheck_PE_Stubbed_Subprogram_Called,
 716                              "expected_throw");
 717    pragma Machine_Attribute (Rcheck_PE_Unchecked_Union_Restriction,
 718                              "expected_throw");
 719    pragma Machine_Attribute (Rcheck_PE_Finalize_Raised_Exception,
 720                              "expected_throw");
 721    pragma Machine_Attribute (Rcheck_SE_Empty_Storage_Pool,
 722                              "expected_throw");
 723    pragma Machine_Attribute (Rcheck_SE_Explicit_Raise,
 724                              "expected_throw");
 725    pragma Machine_Attribute (Rcheck_SE_Infinite_Recursion,
 726                              "expected_throw");
 727    pragma Machine_Attribute (Rcheck_SE_Object_Too_Large,
 728                              "expected_throw");
 729
 730    pragma Machine_Attribute (Rcheck_CE_Access_Check_Ext,
 731                              "expected_throw");
 732    pragma Machine_Attribute (Rcheck_CE_Index_Check_Ext,
 733                              "expected_throw");
 734    pragma Machine_Attribute (Rcheck_CE_Invalid_Data_Ext,
 735                              "expected_throw");
 736    pragma Machine_Attribute (Rcheck_CE_Range_Check_Ext,
 737                              "expected_throw");
 738
 739    --  Make all of these procedures callable from strub contexts.
 740    --  These attributes are not visible to callers; they are made
 741    --  visible in trans.c:build_raise_check.
 742
 743    pragma Machine_Attribute (Rcheck_CE_Access_Check,
 744                              "strub", "callable");
 745    pragma Machine_Attribute (Rcheck_CE_Null_Access_Parameter,
 746                              "strub", "callable");
 747    pragma Machine_Attribute (Rcheck_CE_Discriminant_Check,
 748                              "strub", "callable");
 749    pragma Machine_Attribute (Rcheck_CE_Divide_By_Zero,
 750                              "strub", "callable");
 751    pragma Machine_Attribute (Rcheck_CE_Explicit_Raise,
 752                              "strub", "callable");
 753    pragma Machine_Attribute (Rcheck_CE_Index_Check,
 754                              "strub", "callable");
 755    pragma Machine_Attribute (Rcheck_CE_Invalid_Data,
 756                              "strub", "callable");
 757    pragma Machine_Attribute (Rcheck_CE_Length_Check,
 758                              "strub", "callable");
 759    pragma Machine_Attribute (Rcheck_CE_Null_Exception_Id,
 760                              "strub", "callable");
 761    pragma Machine_Attribute (Rcheck_CE_Null_Not_Allowed,
 762                              "strub", "callable");
 763    pragma Machine_Attribute (Rcheck_CE_Overflow_Check,
 764                              "strub", "callable");
 765    pragma Machine_Attribute (Rcheck_CE_Partition_Check,
 766                              "strub", "callable");
 767    pragma Machine_Attribute (Rcheck_CE_Range_Check,
 768                              "strub", "callable");
 769    pragma Machine_Attribute (Rcheck_CE_Tag_Check,
 770                              "strub", "callable");
 771    pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
 772                              "strub", "callable");
 773    pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
 774                              "strub", "callable");
 775    pragma Machine_Attribute (Rcheck_PE_Address_Of_Intrinsic,
 776                              "strub", "callable");
 777    pragma Machine_Attribute (Rcheck_PE_Aliased_Parameters,
 778                              "strub", "callable");
 779    pragma Machine_Attribute (Rcheck_PE_All_Guards_Closed,
 780                              "strub", "callable");
 781    pragma Machine_Attribute (Rcheck_PE_Bad_Predicated_Generic_Type,
 782                              "strub", "callable");
 783    pragma Machine_Attribute (Rcheck_PE_Build_In_Place_Mismatch,
 784                              "strub", "callable");
 785    pragma Machine_Attribute (Rcheck_PE_Current_Task_In_Entry_Body,
 786                              "strub", "callable");
 787    pragma Machine_Attribute (Rcheck_PE_Duplicated_Entry_Address,
 788                              "strub", "callable");
 789    pragma Machine_Attribute (Rcheck_PE_Explicit_Raise,
 790                              "strub", "callable");
 791    pragma Machine_Attribute (Rcheck_PE_Implicit_Return,
 792                              "strub", "callable");
 793    pragma Machine_Attribute (Rcheck_PE_Misaligned_Address_Value,
 794                              "strub", "callable");
 795    pragma Machine_Attribute (Rcheck_PE_Missing_Return,
 796                              "strub", "callable");
 797    pragma Machine_Attribute (Rcheck_PE_Non_Transportable_Actual,
 798                              "strub", "callable");
 799    pragma Machine_Attribute (Rcheck_PE_Overlaid_Controlled_Object,
 800                              "strub", "callable");
 801    pragma Machine_Attribute (Rcheck_PE_Potentially_Blocking_Operation,
 802                              "strub", "callable");
 803    pragma Machine_Attribute (Rcheck_PE_Stream_Operation_Not_Allowed,
 804                              "strub", "callable");
 805    pragma Machine_Attribute (Rcheck_PE_Stubbed_Subprogram_Called,
 806                              "strub", "callable");
 807    pragma Machine_Attribute (Rcheck_PE_Unchecked_Union_Restriction,
 808                              "strub", "callable");
 809    pragma Machine_Attribute (Rcheck_PE_Finalize_Raised_Exception,
 810                              "strub", "callable");
 811    pragma Machine_Attribute (Rcheck_SE_Empty_Storage_Pool,
 812                              "strub", "callable");
 813    pragma Machine_Attribute (Rcheck_SE_Explicit_Raise,
 814                              "strub", "callable");
 815    pragma Machine_Attribute (Rcheck_SE_Infinite_Recursion,
 816                              "strub", "callable");
 817    pragma Machine_Attribute (Rcheck_SE_Object_Too_Large,
 818                              "strub", "callable");
 819
 820    pragma Machine_Attribute (Rcheck_CE_Access_Check_Ext,
 821                              "strub", "callable");
 822    pragma Machine_Attribute (Rcheck_CE_Index_Check_Ext,
 823                              "strub", "callable");
 824    pragma Machine_Attribute (Rcheck_CE_Invalid_Data_Ext,
 825                              "strub", "callable");
 826    pragma Machine_Attribute (Rcheck_CE_Range_Check_Ext,
 827                              "strub", "callable");
 828
 829    ---------------------------------------------
 830    -- Reason Strings for Run-Time Check Calls --
 831    ---------------------------------------------
 832
 833    --  These strings are null-terminated and are used by Rcheck_nn. The
 834    --  strings correspond to the definitions for Types.RT_Exception_Code.
 835
 836    use ASCII;
 837
 838    Rmsg_00 : constant String := "access check failed"              & NUL;
 839    Rmsg_01 : constant String := "access parameter is null"         & NUL;
 840    Rmsg_02 : constant String := "discriminant check failed"        & NUL;
 841    Rmsg_03 : constant String := "divide by zero"                   & NUL;
 842    Rmsg_04 : constant String := "explicit raise"                   & NUL;
 843    Rmsg_05 : constant String := "index check failed"               & NUL;
 844    Rmsg_06 : constant String := "invalid data"                     & NUL;
 845    Rmsg_07 : constant String := "length check failed"              & NUL;
 846    Rmsg_08 : constant String := "null Exception_Id"                & NUL;
 847    Rmsg_09 : constant String := "null-exclusion check failed"      & NUL;
 848    Rmsg_10 : constant String := "overflow check failed"            & NUL;
 849    Rmsg_11 : constant String := "partition check failed"           & NUL;
 850    Rmsg_12 : constant String := "range check failed"               & NUL;
 851    Rmsg_13 : constant String := "tag check failed"                 & NUL;
 852    Rmsg_14 : constant String := "access before elaboration"        & NUL;
 853    Rmsg_15 : constant String := "accessibility check failed"       & NUL;
 854    Rmsg_16 : constant String := "attempt to take address of"       &
 855                                 " intrinsic subprogram"            & NUL;
 856    Rmsg_17 : constant String := "aliased parameters"               & NUL;
 857    Rmsg_18 : constant String := "all guards closed"                & NUL;
 858    Rmsg_19 : constant String := "improper use of generic subtype"  &
 859                                 " with predicate"                  & NUL;
 860    Rmsg_20 : constant String := "Current_Task referenced in entry" &
 861                                 " body"                            & NUL;
 862    Rmsg_21 : constant String := "duplicated entry address"         & NUL;
 863    Rmsg_22 : constant String := "explicit raise"                   & NUL;
 864    Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL;
 865    Rmsg_24 : constant String := "implicit return with No_Return"   & NUL;
 866    Rmsg_25 : constant String := "misaligned address value"         & NUL;
 867    Rmsg_26 : constant String := "missing return"                   & NUL;
 868    Rmsg_27 : constant String := "overlaid controlled object"       & NUL;
 869    Rmsg_28 : constant String := "potentially blocking operation"   & NUL;
 870    Rmsg_29 : constant String := "stubbed subprogram called"        & NUL;
 871    Rmsg_30 : constant String := "unchecked union restriction"      & NUL;
 872    Rmsg_31 : constant String := "actual/returned class-wide"       &
 873                                 " value not transportable"         & NUL;
 874    Rmsg_32 : constant String := "empty storage pool"               & NUL;
 875    Rmsg_33 : constant String := "explicit raise"                   & NUL;
 876    Rmsg_34 : constant String := "infinite recursion"               & NUL;
 877    Rmsg_35 : constant String := "object too large"                 & NUL;
 878    Rmsg_36 : constant String := "stream operation not allowed"     & NUL;
 879    Rmsg_37 : constant String := "build-in-place mismatch"          & NUL;
 880
 881    ---------
 882    -- AAA --
 883    ---------
 884
 885    --  This function gives us the start of the PC range for addresses within
 886    --  the exception unit itself. We hope that gigi/gcc keep all the procedures
 887    --  in their original order.
 888
 889    procedure AAA is null;
 890
 891    ----------------
 892    -- Call_Chain --
 893    ----------------
 894
 895    procedure Call_Chain (Excep : EOA) is separate;
 896    --  The actual Call_Chain routine is separate, so that it can easily
 897    --  be dummied out when no exception traceback information is needed.
 898
 899    -------------------
 900    -- EId_To_String --
 901    -------------------
 902
 903    function EId_To_String (X : Exception_Id) return String
 904      renames Stream_Attributes.EId_To_String;
 905
 906    ------------------
 907    -- EO_To_String --
 908    ------------------
 909
 910    --  We use the null string to represent the null occurrence, otherwise we
 911    --  output the Untailored_Exception_Information string for the occurrence.
 912
 913    function EO_To_String (X : Exception_Occurrence) return String
 914      renames Stream_Attributes.EO_To_String;
 915
 916    ------------------------
 917    -- Exception_Identity --
 918    ------------------------
 919
 920    function Exception_Identity
 921      (X : Exception_Occurrence) return Exception_Id
 922    is
 923    begin
 924       --  Note that the following test used to be here for the original
 925       --  Ada 95 semantics, but these were modified by AI-241 to require
 926       --  returning Null_Id instead of raising Constraint_Error.
 927
 928       --  if X.Id = Null_Id then
 929       --     raise Constraint_Error;
 930       --  end if;
 931
 932       return X.Id;
 933    end Exception_Identity;
 934
 935    ---------------------------
 936    -- Exception_Information --
 937    ---------------------------
 938
 939    function Exception_Information (X : Exception_Occurrence) return String is
 940    begin
 941       if X.Id = Null_Id then
 942          raise Constraint_Error;
 943       else
 944          return Exception_Data.Exception_Information (X);
 945       end if;
 946    end Exception_Information;
 947
 948    -----------------------
 949    -- Exception_Message --
 950    -----------------------
 951
 952    function Exception_Message (X : Exception_Occurrence) return String is
 953    begin
 954       if X.Id = Null_Id then
 955          raise Constraint_Error;
 956       else
 957          return X.Msg (1 .. X.Msg_Length);
 958       end if;
 959    end Exception_Message;
 960
 961    --------------------
 962    -- Exception_Name --
 963    --------------------
 964
 965    function Exception_Name (Id : Exception_Id) return String is
 966    begin
 967       if Id = null then
 968          raise Constraint_Error;
 969       else
 970          return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
 971       end if;
 972    end Exception_Name;
 973
 974    function Exception_Name (X : Exception_Occurrence) return String is
 975    begin
 976       return Exception_Name (X.Id);
 977    end Exception_Name;
 978
 979    ---------------------------
 980    -- Exception_Name_Simple --
 981    ---------------------------
 982
 983    function Exception_Name_Simple (X : Exception_Occurrence) return String is
 984       Name : constant String := Exception_Name (X);
 985       P    : Natural;
 986
 987    begin
 988       P := Name'Length;
 989       while P > 1 loop
 990          exit when Name (P - 1) = '.';
 991          P := P - 1;
 992       end loop;
 993
 994       --  Return result making sure lower bound is 1
 995
 996       declare
 997          subtype Rname is String (1 .. Name'Length - P + 1);
 998       begin
 999          return Rname (Name (P .. Name'Length));
1000       end;
1001    end Exception_Name_Simple;
1002
1003    --------------------
1004    -- Exception_Data --
1005    --------------------
1006
1007    package body Exception_Data is separate;
1008    --  This package can be easily dummied out if we do not want the basic
1009    --  support for exception messages (such as in Ada 83).
1010
1011    ---------------------------
1012    -- Exception_Propagation --
1013    ---------------------------
1014
1015    package body Exception_Propagation is separate;
1016    --  Depending on the actual exception mechanism used (front-end or
1017    --  back-end based), the implementation will differ, which is why this
1018    --  package is separated.
1019
1020    ----------------------
1021    -- Exception_Traces --
1022    ----------------------
1023
1024    package body Exception_Traces is separate;
1025    --  Depending on the underlying support for IO the implementation will
1026    --  differ. Moreover we would like to dummy out this package in case we
1027    --  do not want any exception tracing support. This is why this package
1028    --  is separated.
1029
1030    --------------------------------------
1031    -- Get_Exception_Machine_Occurrence --
1032    --------------------------------------
1033
1034    function Get_Exception_Machine_Occurrence
1035      (X : Exception_Occurrence) return System.Address
1036    is
1037    begin
1038       return X.Machine_Occurrence;
1039    end Get_Exception_Machine_Occurrence;
1040
1041    -----------
1042    -- Image --
1043    -----------
1044
1045    function Image (Index : Integer) return String is
1046       Result : constant String := Integer'Image (Index);
1047    begin
1048       if Result (1) = ' ' then
1049          return Result (2 .. Result'Last);
1050       else
1051          return Result;
1052       end if;
1053    end Image;
1054
1055    -----------------------
1056    -- Stream Attributes --
1057    -----------------------
1058
1059    package body Stream_Attributes is separate;
1060    --  This package can be easily dummied out if we do not want the
1061    --  support for streaming Exception_Ids and Exception_Occurrences.
1062
1063    ----------------------------
1064    -- Raise_Constraint_Error --
1065    ----------------------------
1066
1067    procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is
1068    begin
1069       Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line);
1070    end Raise_Constraint_Error;
1071
1072    --------------------------------
1073    -- Raise_Constraint_Error_Msg --
1074    --------------------------------
1075
1076    procedure Raise_Constraint_Error_Msg
1077      (File   : System.Address;
1078       Line   : Integer;
1079       Column : Integer;
1080       Msg    : System.Address)
1081    is
1082    begin
1083       Raise_With_Location_And_Msg
1084         (Constraint_Error_Def'Access, File, Line, Column, Msg);
1085    end Raise_Constraint_Error_Msg;
1086
1087    -------------------------
1088    -- Complete_Occurrence --
1089    -------------------------
1090
1091    procedure Complete_Occurrence (X : EOA) is
1092    begin
1093       --  Compute the backtrace for this occurrence if the corresponding
1094       --  binder option has been set. Call_Chain takes care of the reraise
1095       --  case.
1096
1097       --  ??? Using Call_Chain here means we are going to walk up the stack
1098       --  once only for backtracing purposes before doing it again for the
1099       --  propagation per se.
1100
1101       --  The first inspection is much lighter, though, as it only requires
1102       --  partial unwinding of each frame. Additionally, although we could use
1103       --  the personality routine to record the addresses while propagating,
1104       --  this method has two drawbacks:
1105
1106       --  1) the trace is incomplete if the exception is handled since we
1107       --  don't walk past the frame with the handler,
1108
1109       --    and
1110
1111       --  2) we would miss the frames for which our personality routine is not
1112       --  called, e.g. if C or C++ calls are on the way.
1113
1114       Call_Chain (X);
1115
1116       --  Notify the debugger
1117       Debug_Raise_Exception
1118         (E       => SSL.Exception_Data_Ptr (X.Id),
1119          Message => X.Msg (1 .. X.Msg_Length));
1120    end Complete_Occurrence;
1121
1122    ---------------------------------------
1123    -- Complete_And_Propagate_Occurrence --
1124    ---------------------------------------
1125
1126    procedure Complete_And_Propagate_Occurrence (X : EOA) is
1127    begin
1128       Complete_Occurrence (X);
1129       Exception_Propagation.Propagate_Exception (X.all);
1130    end Complete_And_Propagate_Occurrence;
1131
1132    ---------------------
1133    -- Raise_Exception --
1134    ---------------------
1135
1136    procedure Raise_Exception
1137      (E       : Exception_Id;
1138       Message : String := "")
1139    is
1140       EF : Exception_Id := E;
1141    begin
1142       --  Raise CE if E = Null_ID (AI-446)
1143
1144       if E = null then
1145          EF := Constraint_Error'Identity;
1146       end if;
1147
1148       --  Go ahead and raise appropriate exception
1149
1150       Raise_Exception_Always (EF, Message);
1151    end Raise_Exception;
1152
1153    ----------------------------
1154    -- Raise_Exception_Always --
1155    ----------------------------
1156
1157    procedure Raise_Exception_Always
1158      (E       : Exception_Id;
1159       Message : String := "")
1160    is
1161       X : constant EOA := Exception_Propagation.Allocate_Occurrence;
1162
1163    begin
1164       Exception_Data.Set_Exception_Msg (X, E, Message);
1165       Complete_And_Propagate_Occurrence (X);
1166    end Raise_Exception_Always;
1167
1168    ------------------------------
1169    -- Raise_Exception_No_Defer --
1170    ------------------------------
1171
1172    procedure Raise_Exception_No_Defer
1173      (E       : Exception_Id;
1174       Message : String := "")
1175    is
1176       X : constant EOA := Exception_Propagation.Allocate_Occurrence;
1177
1178    begin
1179       Exception_Data.Set_Exception_Msg (X, E, Message);
1180
1181       --  Do not call Abort_Defer.all, as specified by the spec
1182
1183       Complete_And_Propagate_Occurrence (X);
1184    end Raise_Exception_No_Defer;
1185
1186    -------------------------------------
1187    -- Raise_From_Controlled_Operation --
1188    -------------------------------------
1189
1190    procedure Raise_From_Controlled_Operation
1191      (X : Ada.Exceptions.Exception_Occurrence)
1192    is
1193       Prefix             : constant String := "adjust/finalize raised ";
1194       Orig_Msg           : constant String := Exception_Message (X);
1195       Orig_Prefix_Length : constant Natural :=
1196                              Integer'Min (Prefix'Length, Orig_Msg'Length);
1197
1198       Orig_Prefix : String renames
1199         Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
1200
1201    begin
1202       --  Message already has the proper prefix, just re-raise
1203
1204       if Orig_Prefix = Prefix then
1205          Raise_Exception_No_Defer
1206            (E       => Program_Error'Identity,
1207             Message => Orig_Msg);
1208
1209       else
1210          declare
1211             New_Msg : constant String := Prefix & Exception_Name (X);
1212
1213          begin
1214             --  No message present, just provide our own
1215
1216             if Orig_Msg = "" then
1217                Raise_Exception_No_Defer
1218                  (E       => Program_Error'Identity,
1219                   Message => New_Msg);
1220
1221             --  Message present, add informational prefix
1222
1223             else
1224                Raise_Exception_No_Defer
1225                  (E       => Program_Error'Identity,
1226                   Message => New_Msg & ": " & Orig_Msg);
1227             end if;
1228          end;
1229       end if;
1230    end Raise_From_Controlled_Operation;
1231
1232    -------------------------------------------
1233    -- Create_Occurrence_From_Signal_Handler --
1234    -------------------------------------------
1235
1236    function Create_Occurrence_From_Signal_Handler
1237      (E : Exception_Id;
1238       M : System.Address) return EOA
1239    is
1240       X : constant EOA := Exception_Propagation.Allocate_Occurrence;
1241
1242    begin
1243       Exception_Data.Set_Exception_C_Msg (X, E, M);
1244       Complete_Occurrence (X);
1245       return X;
1246    end Create_Occurrence_From_Signal_Handler;
1247
1248    ---------------------------------------------------
1249    -- Create_Machine_Occurrence_From_Signal_Handler --
1250    ---------------------------------------------------
1251
1252    function Create_Machine_Occurrence_From_Signal_Handler
1253      (E : Exception_Id;
1254       M : System.Address) return System.Address
1255    is
1256    begin
1257       return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence;
1258    end Create_Machine_Occurrence_From_Signal_Handler;
1259
1260    -------------------------------
1261    -- Raise_From_Signal_Handler --
1262    -------------------------------
1263
1264    procedure Raise_From_Signal_Handler
1265      (E : Exception_Id;
1266       M : System.Address)
1267    is
1268    begin
1269       Exception_Propagation.Propagate_Exception
1270         (Create_Occurrence_From_Signal_Handler (E, M).all);
1271    end Raise_From_Signal_Handler;
1272
1273    -------------------------
1274    -- Raise_Program_Error --
1275    -------------------------
1276
1277    procedure Raise_Program_Error
1278      (File : System.Address;
1279       Line : Integer)
1280    is
1281    begin
1282       Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line);
1283    end Raise_Program_Error;
1284
1285    -----------------------------
1286    -- Raise_Program_Error_Msg --
1287    -----------------------------
1288
1289    procedure Raise_Program_Error_Msg
1290      (File : System.Address;
1291       Line : Integer;
1292       Msg  : System.Address)
1293    is
1294    begin
1295       Raise_With_Location_And_Msg
1296         (Program_Error_Def'Access, File, Line, M => Msg);
1297    end Raise_Program_Error_Msg;
1298
1299    -------------------------
1300    -- Raise_Storage_Error --
1301    -------------------------
1302
1303    procedure Raise_Storage_Error
1304      (File : System.Address;
1305       Line : Integer)
1306    is
1307    begin
1308       Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line);
1309    end Raise_Storage_Error;
1310
1311    -----------------------------
1312    -- Raise_Storage_Error_Msg --
1313    -----------------------------
1314
1315    procedure Raise_Storage_Error_Msg
1316      (File : System.Address;
1317       Line : Integer;
1318       Msg  : System.Address)
1319    is
1320    begin
1321       Raise_With_Location_And_Msg
1322         (Storage_Error_Def'Access, File, Line, M => Msg);
1323    end Raise_Storage_Error_Msg;
1324
1325    ---------------------------------
1326    -- Raise_With_Location_And_Msg --
1327    ---------------------------------
1328
1329    procedure Raise_With_Location_And_Msg
1330      (E : Exception_Id;
1331       F : System.Address;
1332       L : Integer;
1333       C : Integer := 0;
1334       M : System.Address := System.Null_Address)
1335    is
1336       X : constant EOA := Exception_Propagation.Allocate_Occurrence;
1337    begin
1338       Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M);
1339       Complete_And_Propagate_Occurrence (X);
1340    end Raise_With_Location_And_Msg;
1341
1342    --------------------
1343    -- Raise_With_Msg --
1344    --------------------
1345
1346    procedure Raise_With_Msg (E : Exception_Id) is
1347       Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
1348       Ex    : constant Exception_Occurrence_Access := Get_Current_Excep.all;
1349    begin
1350       Excep.Exception_Raised := False;
1351       Excep.Id               := E;
1352       Excep.Num_Tracebacks   := 0;
1353       Excep.Pid              := Local_Partition_ID;
1354
1355       --  Copy the message from the current exception
1356       --  Change the interface to be called with an occurrence ???
1357
1358       Excep.Msg_Length                  := Ex.Msg_Length;
1359       Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length);
1360
1361       Complete_And_Propagate_Occurrence (Excep);
1362    end Raise_With_Msg;
1363
1364    -----------------------------------------
1365    -- Calls to Run-Time Check Subprograms --
1366    -----------------------------------------
1367
1368    procedure Rcheck_CE_Access_Check
1369      (File : System.Address; Line : Integer)
1370    is
1371    begin
1372       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address);
1373    end Rcheck_CE_Access_Check;
1374
1375    procedure Rcheck_CE_Null_Access_Parameter
1376      (File : System.Address; Line : Integer)
1377    is
1378    begin
1379       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address);
1380    end Rcheck_CE_Null_Access_Parameter;
1381
1382    procedure Rcheck_CE_Discriminant_Check
1383      (File : System.Address; Line : Integer)
1384    is
1385    begin
1386       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address);
1387    end Rcheck_CE_Discriminant_Check;
1388
1389    procedure Rcheck_CE_Divide_By_Zero
1390      (File : System.Address; Line : Integer)
1391    is
1392    begin
1393       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address);
1394    end Rcheck_CE_Divide_By_Zero;
1395
1396    procedure Rcheck_CE_Explicit_Raise
1397      (File : System.Address; Line : Integer)
1398    is
1399    begin
1400       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address);
1401    end Rcheck_CE_Explicit_Raise;
1402
1403    procedure Rcheck_CE_Index_Check
1404      (File : System.Address; Line : Integer)
1405    is
1406    begin
1407       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address);
1408    end Rcheck_CE_Index_Check;
1409
1410    procedure Rcheck_CE_Invalid_Data
1411      (File : System.Address; Line : Integer)
1412    is
1413    begin
1414       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address);
1415    end Rcheck_CE_Invalid_Data;
1416
1417    procedure Rcheck_CE_Length_Check
1418      (File : System.Address; Line : Integer)
1419    is
1420    begin
1421       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address);
1422    end Rcheck_CE_Length_Check;
1423
1424    procedure Rcheck_CE_Null_Exception_Id
1425      (File : System.Address; Line : Integer)
1426    is
1427    begin
1428       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address);
1429    end Rcheck_CE_Null_Exception_Id;
1430
1431    procedure Rcheck_CE_Null_Not_Allowed
1432      (File : System.Address; Line : Integer)
1433    is
1434    begin
1435       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address);
1436    end Rcheck_CE_Null_Not_Allowed;
1437
1438    procedure Rcheck_CE_Overflow_Check
1439      (File : System.Address; Line : Integer)
1440    is
1441    begin
1442       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address);
1443    end Rcheck_CE_Overflow_Check;
1444
1445    procedure Rcheck_CE_Partition_Check
1446      (File : System.Address; Line : Integer)
1447    is
1448    begin
1449       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address);
1450    end Rcheck_CE_Partition_Check;
1451
1452    procedure Rcheck_CE_Range_Check
1453      (File : System.Address; Line : Integer)
1454    is
1455    begin
1456       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address);
1457    end Rcheck_CE_Range_Check;
1458
1459    procedure Rcheck_CE_Tag_Check
1460      (File : System.Address; Line : Integer)
1461    is
1462    begin
1463       Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
1464    end Rcheck_CE_Tag_Check;
1465
1466    procedure Rcheck_PE_Access_Before_Elaboration
1467      (File : System.Address; Line : Integer)
1468    is
1469    begin
1470       Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
1471    end Rcheck_PE_Access_Before_Elaboration;
1472
1473    procedure Rcheck_PE_Accessibility_Check
1474      (File : System.Address; Line : Integer)
1475    is
1476    begin
1477       Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
1478    end Rcheck_PE_Accessibility_Check;
1479
1480    procedure Rcheck_PE_Address_Of_Intrinsic
1481      (File : System.Address; Line : Integer)
1482    is
1483    begin
1484       Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
1485    end Rcheck_PE_Address_Of_Intrinsic;
1486
1487    procedure Rcheck_PE_Aliased_Parameters
1488      (File : System.Address; Line : Integer)
1489    is
1490    begin
1491       Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
1492    end Rcheck_PE_Aliased_Parameters;
1493
1494    procedure Rcheck_PE_All_Guards_Closed
1495      (File : System.Address; Line : Integer)
1496    is
1497    begin
1498       Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
1499    end Rcheck_PE_All_Guards_Closed;
1500
1501    procedure Rcheck_PE_Bad_Predicated_Generic_Type
1502      (File : System.Address; Line : Integer)
1503    is
1504    begin
1505       Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
1506    end Rcheck_PE_Bad_Predicated_Generic_Type;
1507
1508    procedure Rcheck_PE_Build_In_Place_Mismatch
1509      (File : System.Address; Line : Integer)
1510    is
1511    begin
1512       Raise_Program_Error_Msg (File, Line, Rmsg_37'Address);
1513    end Rcheck_PE_Build_In_Place_Mismatch;
1514
1515    procedure Rcheck_PE_Current_Task_In_Entry_Body
1516      (File : System.Address; Line : Integer)
1517    is
1518    begin
1519       Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
1520    end Rcheck_PE_Current_Task_In_Entry_Body;
1521
1522    procedure Rcheck_PE_Duplicated_Entry_Address
1523      (File : System.Address; Line : Integer)
1524    is
1525    begin
1526       Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
1527    end Rcheck_PE_Duplicated_Entry_Address;
1528
1529    procedure Rcheck_PE_Explicit_Raise
1530      (File : System.Address; Line : Integer)
1531    is
1532    begin
1533       Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
1534    end Rcheck_PE_Explicit_Raise;
1535
1536    procedure Rcheck_PE_Implicit_Return
1537      (File : System.Address; Line : Integer)
1538    is
1539    begin
1540       Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
1541    end Rcheck_PE_Implicit_Return;
1542
1543    procedure Rcheck_PE_Misaligned_Address_Value
1544      (File : System.Address; Line : Integer)
1545    is
1546    begin
1547       Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
1548    end Rcheck_PE_Misaligned_Address_Value;
1549
1550    procedure Rcheck_PE_Missing_Return
1551      (File : System.Address; Line : Integer)
1552    is
1553    begin
1554       Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
1555    end Rcheck_PE_Missing_Return;
1556
1557    procedure Rcheck_PE_Non_Transportable_Actual
1558      (File : System.Address; Line : Integer)
1559    is
1560    begin
1561       Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
1562    end Rcheck_PE_Non_Transportable_Actual;
1563
1564    procedure Rcheck_PE_Overlaid_Controlled_Object
1565      (File : System.Address; Line : Integer)
1566    is
1567    begin
1568       Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
1569    end Rcheck_PE_Overlaid_Controlled_Object;
1570
1571    procedure Rcheck_PE_Potentially_Blocking_Operation
1572      (File : System.Address; Line : Integer)
1573    is
1574    begin
1575       Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
1576    end Rcheck_PE_Potentially_Blocking_Operation;
1577
1578    procedure Rcheck_PE_Stream_Operation_Not_Allowed
1579      (File : System.Address; Line : Integer)
1580    is
1581    begin
1582       Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
1583    end Rcheck_PE_Stream_Operation_Not_Allowed;
1584
1585    procedure Rcheck_PE_Stubbed_Subprogram_Called
1586      (File : System.Address; Line : Integer)
1587    is
1588    begin
1589       Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
1590    end Rcheck_PE_Stubbed_Subprogram_Called;
1591
1592    procedure Rcheck_PE_Unchecked_Union_Restriction
1593      (File : System.Address; Line : Integer)
1594    is
1595    begin
1596       Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
1597    end Rcheck_PE_Unchecked_Union_Restriction;
1598
1599    procedure Rcheck_SE_Empty_Storage_Pool
1600      (File : System.Address; Line : Integer)
1601    is
1602    begin
1603       Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
1604    end Rcheck_SE_Empty_Storage_Pool;
1605
1606    procedure Rcheck_SE_Explicit_Raise
1607      (File : System.Address; Line : Integer)
1608    is
1609    begin
1610       Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
1611    end Rcheck_SE_Explicit_Raise;
1612
1613    procedure Rcheck_SE_Infinite_Recursion
1614      (File : System.Address; Line : Integer)
1615    is
1616    begin
1617       Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
1618    end Rcheck_SE_Infinite_Recursion;
1619
1620    procedure Rcheck_SE_Object_Too_Large
1621      (File : System.Address; Line : Integer)
1622    is
1623    begin
1624       Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
1625    end Rcheck_SE_Object_Too_Large;
1626
1627    procedure Rcheck_CE_Access_Check_Ext
1628      (File : System.Address; Line, Column : Integer)
1629    is
1630    begin
1631       Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address);
1632    end Rcheck_CE_Access_Check_Ext;
1633
1634    procedure Rcheck_CE_Index_Check_Ext
1635      (File : System.Address; Line, Column, Index, First, Last : Integer)
1636    is
1637       Msg : constant String :=
1638               Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF
1639               & "index " & Image (Index) & " not in " & Image (First)
1640               & ".." & Image (Last) & ASCII.NUL;
1641    begin
1642       Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
1643    end Rcheck_CE_Index_Check_Ext;
1644
1645    procedure Rcheck_CE_Invalid_Data_Ext
1646      (File : System.Address; Line, Column, Index, First, Last : Integer)
1647    is
1648       Msg : constant String :=
1649               Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF
1650               & "value " & Image (Index) & " not in " & Image (First)
1651               & ".." & Image (Last) & ASCII.NUL;
1652    begin
1653       Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
1654    end Rcheck_CE_Invalid_Data_Ext;
1655
1656    procedure Rcheck_CE_Range_Check_Ext
1657      (File : System.Address; Line, Column, Index, First, Last : Integer)
1658    is
1659       Msg : constant String :=
1660               Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF
1661               & "value " & Image (Index) & " not in " & Image (First)
1662               & ".." & Image (Last) & ASCII.NUL;
1663    begin
1664       Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
1665    end Rcheck_CE_Range_Check_Ext;
1666
1667    procedure Rcheck_PE_Finalize_Raised_Exception
1668      (File : System.Address; Line : Integer)
1669    is
1670       X : constant EOA := Exception_Propagation.Allocate_Occurrence;
1671
1672    begin
1673       --  This is "finalize/adjust raised exception". This subprogram is always
1674       --  called with abort deferred, unlike all other Rcheck_* subprograms, it
1675       --  needs to call Raise_Exception_No_Defer.
1676
1677       --  This is consistent with Raise_From_Controlled_Operation
1678
1679       Exception_Data.Set_Exception_C_Msg
1680         (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address);
1681       Complete_And_Propagate_Occurrence (X);
1682    end Rcheck_PE_Finalize_Raised_Exception;
1683
1684    -------------
1685    -- Reraise --
1686    -------------
1687
1688    procedure Reraise is
1689       Excep    : constant EOA := Exception_Propagation.Allocate_Occurrence;
1690       Saved_MO : constant System.Address := Excep.Machine_Occurrence;
1691
1692    begin
1693       Save_Occurrence (Excep.all, Get_Current_Excep.all.all);
1694       Excep.Machine_Occurrence := Saved_MO;
1695       Complete_And_Propagate_Occurrence (Excep);
1696    end Reraise;
1697
1698    --------------------------------------
1699    -- Reraise_Library_Exception_If_Any --
1700    --------------------------------------
1701
1702    procedure Reraise_Library_Exception_If_Any is
1703       LE : Exception_Occurrence;
1704
1705    begin
1706       if Library_Exception_Set then
1707          LE := Library_Exception;
1708
1709          if LE.Id = Null_Id then
1710             Raise_Exception_No_Defer
1711               (E       => Program_Error'Identity,
1712                Message => "finalize/adjust raised exception");
1713          else
1714             Raise_From_Controlled_Operation (LE);
1715          end if;
1716       end if;
1717    end Reraise_Library_Exception_If_Any;
1718
1719    ------------------------
1720    -- Reraise_Occurrence --
1721    ------------------------
1722
1723    procedure Reraise_Occurrence (X : Exception_Occurrence) is
1724    begin
1725       if X.Id = null then
1726          return;
1727       else
1728          Reraise_Occurrence_Always (X);
1729       end if;
1730    end Reraise_Occurrence;
1731
1732    -------------------------------
1733    -- Reraise_Occurrence_Always --
1734    -------------------------------
1735
1736    procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
1737    begin
1738       Reraise_Occurrence_No_Defer (X);
1739    end Reraise_Occurrence_Always;
1740
1741    ---------------------------------
1742    -- Reraise_Occurrence_No_Defer --
1743    ---------------------------------
1744
1745    procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
1746    begin
1747       --  If we have a Machine_Occurrence at hand already, e.g. when we are
1748       --  reraising a foreign exception, just repropagate. Otherwise, e.g.
1749       --  when reraising a GNAT exception or an occurrence read back from a
1750       --  stream, set up a new occurrence with its own Machine block first.
1751
1752       if X.Machine_Occurrence /= System.Null_Address then
1753          Exception_Propagation.Propagate_Exception (X);
1754       else
1755          declare
1756             Excep : constant EOA
1757               := Exception_Propagation.Allocate_Occurrence;
1758             Saved_MO : constant System.Address := Excep.Machine_Occurrence;
1759          begin
1760             Save_Occurrence (Excep.all, X);
1761             Excep.Machine_Occurrence := Saved_MO;
1762             Complete_And_Propagate_Occurrence (Excep);
1763          end;
1764       end if;
1765    end Reraise_Occurrence_No_Defer;
1766
1767    ---------------------
1768    -- Save_Occurrence --
1769    ---------------------
1770
1771    procedure Save_Occurrence
1772      (Target : out Exception_Occurrence;
1773       Source : Exception_Occurrence)
1774    is
1775    begin
1776       --  As the machine occurrence might be a data that must be finalized
1777       --  (outside any Ada mechanism), do not copy it
1778
1779       Target.Id                 := Source.Id;
1780       Target.Machine_Occurrence := System.Null_Address;
1781       Target.Msg_Length         := Source.Msg_Length;
1782       Target.Num_Tracebacks     := Source.Num_Tracebacks;
1783       Target.Exception_Raised   := Source.Exception_Raised;
1784       Target.Pid                := Source.Pid;
1785
1786       Target.Msg (1 .. Target.Msg_Length) :=
1787         Source.Msg (1 .. Target.Msg_Length);
1788
1789       Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
1790         Source.Tracebacks (1 .. Target.Num_Tracebacks);
1791    end Save_Occurrence;
1792
1793    function Save_Occurrence (Source : Exception_Occurrence) return EOA is
1794       Target : constant EOA := new Exception_Occurrence;
1795    begin
1796       Save_Occurrence (Target.all, Source);
1797       return Target;
1798    end Save_Occurrence;
1799
1800    -------------------
1801    -- String_To_EId --
1802    -------------------
1803
1804    function String_To_EId (S : String) return Exception_Id
1805      renames Stream_Attributes.String_To_EId;
1806
1807    ------------------
1808    -- String_To_EO --
1809    ------------------
1810
1811    function String_To_EO (S : String) return Exception_Occurrence
1812      renames Stream_Attributes.String_To_EO;
1813
1814    ---------------
1815    -- To_Stderr --
1816    ---------------
1817
1818    procedure To_Stderr (C : Character) is
1819       procedure Put_Char_Stderr (C : Integer);
1820       pragma Import (C, Put_Char_Stderr, "put_char_stderr");
1821    begin
1822       Put_Char_Stderr (Character'Pos (C));
1823    end To_Stderr;
1824
1825    procedure To_Stderr (S : String) is
1826    begin
1827       for J in S'Range loop
1828          if S (J) /= ASCII.CR then
1829             To_Stderr (S (J));
1830          end if;
1831       end loop;
1832    end To_Stderr;
1833
1834    -------------------------
1835    -- Transfer_Occurrence --
1836    -------------------------
1837
1838    procedure Transfer_Occurrence
1839      (Target : Exception_Occurrence_Access;
1840       Source : Exception_Occurrence)
1841    is
1842    begin
1843       Save_Occurrence (Target.all, Source);
1844    end Transfer_Occurrence;
1845
1846    ------------------------
1847    -- Triggered_By_Abort --
1848    ------------------------
1849
1850    function Triggered_By_Abort return Boolean is
1851       Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
1852    begin
1853       return Ex /= null
1854         and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
1855    end Triggered_By_Abort;
1856
1857    -------------------------
1858    -- Wide_Exception_Name --
1859    -------------------------
1860
1861    WC_Encoding : constant Character;
1862    pragma Import (C, WC_Encoding, "__gl_wc_encoding");
1863    --  Encoding method for source, as exported by binder
1864
1865    function Wide_Exception_Name
1866      (Id : Exception_Id) return Wide_String
1867    is
1868       S : constant String := Exception_Name (Id);
1869       W : Wide_String (1 .. S'Length);
1870       L : Natural;
1871    begin
1872       String_To_Wide_String
1873         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1874       return W (1 .. L);
1875    end Wide_Exception_Name;
1876
1877    function Wide_Exception_Name
1878      (X : Exception_Occurrence) return Wide_String
1879    is
1880       S : constant String := Exception_Name (X);
1881       W : Wide_String (1 .. S'Length);
1882       L : Natural;
1883    begin
1884       String_To_Wide_String
1885         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1886       return W (1 .. L);
1887    end Wide_Exception_Name;
1888
1889    ----------------------------
1890    -- Wide_Wide_Exception_Name --
1891    -----------------------------
1892
1893    function Wide_Wide_Exception_Name
1894      (Id : Exception_Id) return Wide_Wide_String
1895    is
1896       S : constant String := Exception_Name (Id);
1897       W : Wide_Wide_String (1 .. S'Length);
1898       L : Natural;
1899    begin
1900       String_To_Wide_Wide_String
1901         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1902       return W (1 .. L);
1903    end Wide_Wide_Exception_Name;
1904
1905    function Wide_Wide_Exception_Name
1906      (X : Exception_Occurrence) return Wide_Wide_String
1907    is
1908       S : constant String := Exception_Name (X);
1909       W : Wide_Wide_String (1 .. S'Length);
1910       L : Natural;
1911    begin
1912       String_To_Wide_Wide_String
1913         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1914       return W (1 .. L);
1915    end Wide_Wide_Exception_Name;
1916
1917    ---------
1918    -- ZZZ --
1919    ---------
1920
1921    --  This function gives us the end of the PC range for addresses
1922    --  within the exception unit itself. We hope that gigi/gcc keeps all the
1923    --  procedures in their original order.
1924
1925    procedure ZZZ is null;
1926
1927 end Ada.Exceptions;