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