gcc/ada/a-except-2005.adb

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