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