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