gcc/ada/libgnat/a-except.adb

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