gcc/ada/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-2002 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 pragma Polling (Off);
  35 --  We must turn polling off for this unit, because otherwise we get
  36 --  elaboration circularities with System.Exception_Tables.
  37
  38 with Ada.Unchecked_Deallocation;
  39
  40 with GNAT.Heap_Sort_A;        use GNAT.Heap_Sort_A;
  41
  42 with System;                  use System;
  43 with System.Exception_Table;  use System.Exception_Table;
  44 with System.Exceptions;       use System.Exceptions;
  45 with System.Standard_Library; use System.Standard_Library;
  46 with System.Storage_Elements; use System.Storage_Elements;
  47 with System.Soft_Links;       use System.Soft_Links;
  48 with System.Machine_State_Operations; use System.Machine_State_Operations;
  49 with System.Traceback;
  50
  51 with Unchecked_Conversion;
  52
  53 package body Ada.Exceptions is
  54
  55    procedure builtin_longjmp (buffer : Address; Flag : Integer);
  56    pragma No_Return (builtin_longjmp);
  57    pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
  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    type Subprogram_Descriptor_List_Ptr is
  65      access all Subprogram_Descriptor_List;
  66
  67    Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
  68    --  This location is initialized by Register_Exceptions to point to a
  69    --  list of pointers to procedure descriptors, sorted into ascending
  70    --  order of PC addresses.
  71    --
  72    --  Note that SDP_Table_Build is called *before* this unit (or any
  73    --  other unit) is elaborated. That's important, because exceptions can
  74    --  and do occur during elaboration of units, and must be handled during
  75    --  elaboration. This means that we are counting on the fact that the
  76    --  initialization of Subprogram_Descriptors to null is done by the
  77    --  load process and NOT by an explicit assignment during elaboration.
  78
  79    Num_Subprogram_Descriptors : Natural;
  80    --  Number of subprogram descriptors, the useful descriptors are stored
  81    --  in Subprogram_Descriptors (1 .. Num_Subprogram_Descriptors). There
  82    --  can be unused entries at the end of the array due to elimination of
  83    --  duplicated entries (which can arise from use of pragma Import).
  84
  85    Exception_Tracebacks : Integer;
  86    pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks");
  87    --  Boolean indicating whether tracebacks should be stored in exception
  88    --  occurrences.
  89
  90    Zero_Cost_Exceptions : Integer;
  91    pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions");
  92    --  Boolean indicating if we are handling exceptions using a zero cost
  93    --  mechanism.
  94    --
  95    --  ??? We currently have two alternatives for this scheme : one using
  96    --  front-end tables and one using back-end tables. The former is known to
  97    --  only work for GNAT3 and the latter is known to only work for GNAT5.
  98    --  Both are present in this implementation and it would be good to have
  99    --  separate bodies at some point.
 100    --
 101    --  Note that although we currently do not support it, the GCC3 back-end
 102    --  tables are also potentially useable for setjmp/longjmp processing.
 103
 104    Nline : constant String := String' (1 => ASCII.LF);
 105    --  Convenient shortcut
 106
 107    ------------------------------------------------
 108    -- Entities to interface with the GCC runtime --
 109    ------------------------------------------------
 110
 111    --  These come from "C++ ABI for Itanium : Exception handling", which is
 112    --  the reference for GCC. They are used only when we are relying on
 113    --  back-end tables for exception propagation, which in turn is currenly
 114    --  only the case for Zero_Cost_Exceptions in GNAT5.
 115
 116    --  Return codes from the GCC runtime functions used to propagate
 117    --  an exception.
 118
 119    type Unwind_Reason_Code is
 120      (URC_NO_REASON,
 121       URC_FOREIGN_EXCEPTION_CAUGHT,
 122       URC_PHASE2_ERROR,
 123       URC_PHASE1_ERROR,
 124       URC_NORMAL_STOP,
 125       URC_END_OF_STACK,
 126       URC_HANDLER_FOUND,
 127       URC_INSTALL_CONTEXT,
 128       URC_CONTINUE_UNWIND);
 129
 130    --  ??? pragma Unreferenced is unknown until 3.15, so we need to disable
 131    --  warnings around it to fix the bootstrap path.
 132
 133    pragma Warnings (Off);
 134    pragma Unreferenced
 135      (URC_NO_REASON,
 136       URC_FOREIGN_EXCEPTION_CAUGHT,
 137       URC_PHASE2_ERROR,
 138       URC_PHASE1_ERROR,
 139       URC_NORMAL_STOP,
 140       URC_END_OF_STACK,
 141       URC_HANDLER_FOUND,
 142       URC_INSTALL_CONTEXT,
 143       URC_CONTINUE_UNWIND);
 144    pragma Warnings (On);
 145
 146    pragma Convention (C, Unwind_Reason_Code);
 147
 148    --  Mandatory common header for any exception object handled by the
 149    --  GCC unwinding runtime.
 150
 151    subtype Exception_Class is String (1 .. 8);
 152
 153    GNAT_Exception_Class : constant Exception_Class
 154      := "GNU" & ASCII.NUL & "Ada" & ASCII.NUL;
 155
 156    type Unwind_Exception is record
 157       Class    : Exception_Class := GNAT_Exception_Class;
 158       Cleanup  : System.Address  := System.Null_Address;
 159       Private1 : Integer;
 160       Private2 : Integer;
 161    end record;
 162
 163    pragma Convention (C, Unwind_Exception);
 164
 165    for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
 166
 167    --  A GNAT exception object to be dealt with by the personality routine
 168    --  called by the GCC unwinding runtime. This structure shall match the
 169    --  one in raise.c and is currently experimental as it might be merged
 170    --  with the GNAT runtime definition some day.
 171
 172    type GNAT_GCC_Exception is record
 173       Header : Unwind_Exception;
 174       --  Exception header first, as required by the ABI.
 175
 176       Id : Exception_Id;
 177       --  Usual Exception identifier
 178
 179       Handled_By_Others : Boolean;
 180       --  Is this exception handled by "when others" ?
 181
 182       Has_Cleanup : Boolean;
 183       --  Did we see any at-end handler while walking up the stack
 184       --  searching for a handler ? This is used to determine if we
 185       --  start the propagation again after having tried once without
 186       --  finding a true handler for the exception.
 187
 188       Select_Cleanups : Boolean;
 189       --  Do we consider at-end handlers as legitimate handlers for the
 190       --  exception ? This is used to control the propagation process
 191       --  as described in Raise_Current_Excep.
 192    end record;
 193
 194    pragma Convention (C, GNAT_GCC_Exception);
 195
 196    --  GCC runtime functions used
 197
 198    function Unwind_RaiseException
 199      (E    : access GNAT_GCC_Exception)
 200       return Unwind_Reason_Code;
 201    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 202
 203    -----------------------
 204    -- Local Subprograms --
 205    -----------------------
 206
 207    --  Note: the exported subprograms in this package body are called directly
 208    --  from C clients using the given external name, even though they are not
 209    --  technically visible in the Ada sense.
 210
 211    procedure AAA;
 212    --  Mark start of procedures in this unit
 213
 214    procedure ZZZ;
 215    --  Mark end of procedures in this package
 216
 217    function Address_Image (A : System.Address) return String;
 218    --  Returns at string of the form 0xhhhhhhhhh for 32-bit addresses
 219    --  or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are
 220    --  in lower case.
 221
 222    procedure Call_Chain (Excep : EOA);
 223    --  Store up to Max_Tracebacks in Excep, corresponding to the current
 224    --  call chain.
 225
 226    procedure Free
 227      is new Ada.Unchecked_Deallocation
 228        (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr);
 229
 230    procedure Process_Raise_Exception
 231      (E                   : Exception_Id;
 232       From_Signal_Handler : Boolean);
 233    pragma Inline (Process_Raise_Exception);
 234    pragma No_Return (Process_Raise_Exception);
 235    --  This is the lowest level raise routine. It raises the exception
 236    --  referenced by Current_Excep.all in the TSD, without deferring abort
 237    --  (the caller must ensure that abort is deferred on entry).
 238    --
 239    --  This is actually the common implementation for Raise_Current_Excep and
 240    --  Raise_From_Signal_Handler, with a couple of operations inhibited when
 241    --  called from the latter. The origin of the call is indicated by the
 242    --  From_Signal_Handler argument.
 243    --
 244    --  The Inline pragma is there for efficiency reasons.
 245
 246    procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State);
 247    pragma No_Return (Propagate_Exception_With_FE_Support);
 248    --  This procedure propagates the exception represented by the occurrence
 249    --  referenced by Current_Excep in the TSD for the current task. M is the
 250    --  initial machine state, representing the site of the exception raise
 251    --  operation.
 252    --
 253    --  The procedure searches the front end exception tables for an applicable
 254    --  handler, calling Pop_Frame as needed. If and when it locates an
 255    --  applicable handler, Enter_Handler is called to actually enter this
 256    --  handler. If the search is unable to locate an applicable handler,
 257    --  execution is terminated by calling Unhandled_Exception_Terminate.
 258
 259    procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State);
 260    pragma No_Return (Propagate_Exception_With_GCC_Support);
 261    --  This procedure propagates the exception represented by the occurrence
 262    --  referenced by Current_Excep in the TSD for the current task. M is the
 263    --  initial machine state, representing the site of the exception raise
 264    --  operation. It is currently not used and is there for the purpose of
 265    --  interface consistency against Propagate_Exception_With_FE_Support.
 266    --
 267    --  The procedure builds an object suitable for the libgcc processing and
 268    --  calls Unwind_RaiseException to actually throw, taking care of handling
 269    --  the two phase scheme it implements.
 270
 271    procedure Raise_Current_Excep (E : Exception_Id);
 272    pragma No_Return (Raise_Current_Excep);
 273    pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
 274    --  This is a simple wrapper to Process_Raise_Exception setting the
 275    --  From_Signal_Handler argument to False.
 276    --
 277    --  This external name for Raise_Current_Excep is historical, and probably
 278    --  should be changed but for now we keep it, because gdb and gigi know
 279    --  about it.
 280
 281    procedure Raise_Exception_No_Defer
 282       (E : Exception_Id; Message : String := "");
 283    pragma Export (Ada, Raise_Exception_No_Defer,
 284      "ada__exceptions__raise_exception_no_defer");
 285    pragma No_Return (Raise_Exception_No_Defer);
 286    --  Similar to Raise_Exception, but with no abort deferral
 287
 288    procedure Raise_With_Msg (E : Exception_Id);
 289    pragma No_Return (Raise_With_Msg);
 290    pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
 291    --  Raises an exception with given exception id value. A message
 292    --  is associated with the raise, and has already been stored in the
 293    --  exception occurrence referenced by the Current_Excep in the TSD.
 294    --  Abort is deferred before the raise call.
 295
 296    procedure Raise_With_Location
 297      (E : Exception_Id;
 298       F : Big_String_Ptr;
 299       L : Integer);
 300    pragma No_Return (Raise_With_Location);
 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.
 304
 305    procedure Raise_With_Location_And_Msg
 306      (E : Exception_Id;
 307       F : Big_String_Ptr;
 308       L : Integer;
 309       M : Big_String_Ptr);
 310    pragma No_Return (Raise_With_Location_And_Msg);
 311    --  Raise an exception with given exception id value. A filename and line
 312    --  number is associated with the raise and is stored in the exception
 313    --  occurrence and in addition a string message M is appended to this.
 314
 315    procedure Raise_Constraint_Error
 316      (File : Big_String_Ptr;
 317       Line : Integer);
 318    pragma No_Return (Raise_Constraint_Error);
 319    pragma Export
 320      (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
 321    --  Raise constraint error with file:line information
 322
 323    procedure Raise_Constraint_Error_Msg
 324      (File : Big_String_Ptr;
 325       Line : Integer;
 326       Msg  : Big_String_Ptr);
 327    pragma No_Return (Raise_Constraint_Error_Msg);
 328    pragma Export
 329      (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
 330    --  Raise constraint error with file:line + msg information
 331
 332    procedure Raise_Program_Error
 333      (File : Big_String_Ptr;
 334       Line : Integer);
 335    pragma No_Return (Raise_Program_Error);
 336    pragma Export
 337      (C, Raise_Program_Error, "__gnat_raise_program_error");
 338    --  Raise program error with file:line information
 339
 340    procedure Raise_Program_Error_Msg
 341      (File : Big_String_Ptr;
 342       Line : Integer;
 343       Msg  : Big_String_Ptr);
 344    pragma No_Return (Raise_Program_Error_Msg);
 345    pragma Export
 346      (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
 347    --  Raise program error with file:line + msg information
 348
 349    procedure Raise_Storage_Error
 350      (File : Big_String_Ptr;
 351       Line : Integer);
 352    pragma No_Return (Raise_Storage_Error);
 353    pragma Export
 354      (C, Raise_Storage_Error, "__gnat_raise_storage_error");
 355    --  Raise storage error with file:line information
 356
 357    procedure Raise_Storage_Error_Msg
 358      (File : Big_String_Ptr;
 359       Line : Integer;
 360       Msg  : Big_String_Ptr);
 361    pragma No_Return (Raise_Storage_Error_Msg);
 362    pragma Export
 363      (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
 364    --  Raise storage error with file:line + reason msg information
 365
 366    --  The exception raising process and the automatic tracing mechanism rely
 367    --  on some careful use of flags attached to the exception occurrence. The
 368    --  graph below illustrates the relations between the Raise_ subprograms
 369    --  and identifies the points where basic flags such as Exception_Raised
 370    --  are initialized.
 371    --
 372    --  (i) signs indicate the flags initialization points. R stands for Raise,
 373    --  W for With, and E for Exception.
 374    --
 375    --                   R_No_Msg    R_E   R_Pe  R_Ce  R_Se
 376    --                       |        |     |     |     |
 377    --                       +--+  +--+     +---+ | +---+
 378    --                          |  |            | | |
 379    --     R_E_No_Defer(i)    R_W_Msg(i)       R_W_Loc      R_W_C_Msg
 380    --           |               |              |   |        |    |
 381    --           +------------+  |  +-----------+   +--+  +--+    |
 382    --                        |  |  |                  |  |       |
 383    --                        |  |  |              Set_E_C_Msg(i) |
 384    --                        |  |  |                             |
 385    --                        |  |  |  +--------------------------+
 386    --                        |  |  |  |
 387    --                   Raise_Current_Excep
 388
 389    procedure Reraise;
 390    pragma No_Return (Reraise);
 391    pragma Export (C, Reraise, "__gnat_reraise");
 392    --  Reraises the exception referenced by the Current_Excep field of
 393    --  the TSD (all fields of this exception occurrence are set). Abort
 394    --  is deferred before the reraise operation.
 395
 396    function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean;
 397    --  Used in call to sort SDP table (SDP_Table_Build), compares two elements
 398
 399    procedure SDP_Table_Sort_Move (From : Natural; To : Natural);
 400    --  Used in call to sort SDP table (SDP_Table_Build), moves one element
 401
 402    procedure Set_Exception_C_Msg
 403      (Id   : Exception_Id;
 404       Msg1 : Big_String_Ptr;
 405       Line : Integer        := 0;
 406       Msg2 : Big_String_Ptr := null);
 407    --  This routine is called to setup the exception referenced by the
 408    --  Current_Excep field in the TSD to contain the indicated Id value
 409    --  and message. Msg1 is a null terminated string which is generated
 410    --  as the exception message. If line is non-zero, then a colon and
 411    --  the decimal representation of this integer is appended to the
 412    --  message. When Msg2 is non-null, a space and this additional null
 413    --  terminated string is added to the message.
 414
 415    procedure To_Stderr (S : String);
 416    pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
 417    --  Little routine to output string to stderr that is also used
 418    --  in the tasking run time.
 419
 420    procedure Unhandled_Exception_Terminate;
 421    pragma No_Return (Unhandled_Exception_Terminate);
 422    --  This procedure is called to terminate execution following an unhandled
 423    --  exception. The exception information, including traceback if available
 424    --  is output, and execution is then terminated. Note that at the point
 425    --  where this routine is called, the stack has typically been destroyed
 426
 427    ---------------------------------
 428    -- Debugger Interface Routines --
 429    ---------------------------------
 430
 431    --  The routines here are null routines that normally have no effect.
 432    --  they are provided for the debugger to place breakpoints on their
 433    --  entry points to get control on an exception.
 434
 435    procedure Notify_Exception
 436      (Id        : Exception_Id;
 437       Handler   : Code_Loc;
 438       Is_Others : Boolean);
 439    pragma Export (C, Notify_Exception, "__gnat_notify_exception");
 440    --  This routine is called whenever an exception is signalled. The Id
 441    --  parameter is the Exception_Id of the exception being raised. The
 442    --  second parameter Handler is Null_Loc if the exception is unhandled,
 443    --  and is otherwise the entry point of the handler that will handle
 444    --  the exception. Is_Others is True if the handler is an others handler
 445    --  and False otherwise. In the unhandled exception case, if possible
 446    --  (and certainly if zero cost exception handling is active), the
 447    --  stack is still intact when this procedure is called. Note that this
 448    --  routine is entered before any finalization handlers are entered if
 449    --  the exception is unhandled by a "real" exception handler.
 450
 451    procedure Unhandled_Exception;
 452    pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception");
 453    --  This routine is called in addition to Notify_Exception in the
 454    --  unhandled exception case. The fact that there are two routines
 455    --  which are somewhat redundant is historical. Notify_Exception
 456    --  certainly is complete enough, but GDB still uses this routine.
 457
 458    -----------------------------
 459    -- Run-Time Check Routines --
 460    -----------------------------
 461
 462    --  These routines are called from the runtime to raise a specific
 463    --  exception with a reason message attached. The parameters are
 464    --  the file name and line number in each case. The names are keyed
 465    --  to the codes defined in Types.ads and a-types.h (for example,
 466    --  the name Rcheck_05 refers to the Reason whose Pos code is 5).
 467
 468    procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer);
 469    procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer);
 470    procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer);
 471    procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer);
 472    procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer);
 473    procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer);
 474    procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer);
 475    procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer);
 476    procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer);
 477    procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer);
 478    procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer);
 479    procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer);
 480    procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer);
 481    procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer);
 482    procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer);
 483    procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer);
 484    procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer);
 485    procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer);
 486    procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer);
 487    procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer);
 488    procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer);
 489    procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer);
 490    procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer);
 491    procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer);
 492    procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer);
 493    procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer);
 494    procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer);
 495    procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer);
 496    procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer);
 497
 498    pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
 499    pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
 500    pragma Export (C, Rcheck_02, "__gnat_rcheck_02");
 501    pragma Export (C, Rcheck_03, "__gnat_rcheck_03");
 502    pragma Export (C, Rcheck_04, "__gnat_rcheck_04");
 503    pragma Export (C, Rcheck_05, "__gnat_rcheck_05");
 504    pragma Export (C, Rcheck_06, "__gnat_rcheck_06");
 505    pragma Export (C, Rcheck_07, "__gnat_rcheck_07");
 506    pragma Export (C, Rcheck_08, "__gnat_rcheck_08");
 507    pragma Export (C, Rcheck_09, "__gnat_rcheck_09");
 508    pragma Export (C, Rcheck_10, "__gnat_rcheck_10");
 509    pragma Export (C, Rcheck_11, "__gnat_rcheck_11");
 510    pragma Export (C, Rcheck_12, "__gnat_rcheck_12");
 511    pragma Export (C, Rcheck_13, "__gnat_rcheck_13");
 512    pragma Export (C, Rcheck_14, "__gnat_rcheck_14");
 513    pragma Export (C, Rcheck_15, "__gnat_rcheck_15");
 514    pragma Export (C, Rcheck_16, "__gnat_rcheck_16");
 515    pragma Export (C, Rcheck_17, "__gnat_rcheck_17");
 516    pragma Export (C, Rcheck_18, "__gnat_rcheck_18");
 517    pragma Export (C, Rcheck_19, "__gnat_rcheck_19");
 518    pragma Export (C, Rcheck_20, "__gnat_rcheck_20");
 519    pragma Export (C, Rcheck_21, "__gnat_rcheck_21");
 520    pragma Export (C, Rcheck_22, "__gnat_rcheck_22");
 521    pragma Export (C, Rcheck_23, "__gnat_rcheck_23");
 522    pragma Export (C, Rcheck_24, "__gnat_rcheck_24");
 523    pragma Export (C, Rcheck_25, "__gnat_rcheck_25");
 524    pragma Export (C, Rcheck_26, "__gnat_rcheck_26");
 525    pragma Export (C, Rcheck_27, "__gnat_rcheck_27");
 526    pragma Export (C, Rcheck_28, "__gnat_rcheck_28");
 527
 528    ---------------------------------------------
 529    -- Reason Strings for Run-Time Check Calls --
 530    ---------------------------------------------
 531
 532    --  These strings are null-terminated and are used by Rcheck_nn. The
 533    --  strings correspond to the definitions for Types.RT_Exception_Code.
 534
 535    use ASCII;
 536
 537    Rmsg_00 : constant String := "access check failed"              & NUL;
 538    Rmsg_01 : constant String := "access parameter is null"         & NUL;
 539    Rmsg_02 : constant String := "discriminant check failed"        & NUL;
 540    Rmsg_03 : constant String := "divide by zero"                   & NUL;
 541    Rmsg_04 : constant String := "explicit raise"                   & NUL;
 542    Rmsg_05 : constant String := "index check failed"               & NUL;
 543    Rmsg_06 : constant String := "invalid data"                     & NUL;
 544    Rmsg_07 : constant String := "length check failed"              & NUL;
 545    Rmsg_08 : constant String := "overflow check failed"            & NUL;
 546    Rmsg_09 : constant String := "partition check failed"           & NUL;
 547    Rmsg_10 : constant String := "range check failed"               & NUL;
 548    Rmsg_11 : constant String := "tag check failed"                 & NUL;
 549    Rmsg_12 : constant String := "access before elaboration"        & NUL;
 550    Rmsg_13 : constant String := "accessibility check failed"       & NUL;
 551    Rmsg_14 : constant String := "all guards closed"                & NUL;
 552    Rmsg_15 : constant String := "duplicated entry address"         & NUL;
 553    Rmsg_16 : constant String := "explicit raise"                   & NUL;
 554    Rmsg_17 : constant String := "finalize raised exception"        & NUL;
 555    Rmsg_18 : constant String := "invalid data"                     & NUL;
 556    Rmsg_19 : constant String := "misaligned address value"         & NUL;
 557    Rmsg_20 : constant String := "missing return"                   & NUL;
 558    Rmsg_21 : constant String := "potentially blocking operation"   & NUL;
 559    Rmsg_22 : constant String := "stubbed subprogram called"        & NUL;
 560    Rmsg_23 : constant String := "unchecked union restriction"      & NUL;
 561    Rmsg_24 : constant String := "empty storage pool"               & NUL;
 562    Rmsg_25 : constant String := "explicit raise"                   & NUL;
 563    Rmsg_26 : constant String := "infinite recursion"               & NUL;
 564    Rmsg_27 : constant String := "object too large"                 & NUL;
 565    Rmsg_28 : constant String := "restriction violation"            & NUL;
 566
 567    --------------------------------------
 568    -- Calls to Run-Time Check Routines --
 569    --------------------------------------
 570
 571    procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is
 572    begin
 573       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address));
 574    end Rcheck_00;
 575
 576    procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is
 577    begin
 578       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address));
 579    end Rcheck_01;
 580
 581    procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is
 582    begin
 583       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address));
 584    end Rcheck_02;
 585
 586    procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is
 587    begin
 588       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address));
 589    end Rcheck_03;
 590
 591    procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is
 592    begin
 593       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address));
 594    end Rcheck_04;
 595
 596    procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is
 597    begin
 598       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address));
 599    end Rcheck_05;
 600
 601    procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is
 602    begin
 603       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address));
 604    end Rcheck_06;
 605
 606    procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is
 607    begin
 608       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address));
 609    end Rcheck_07;
 610
 611    procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is
 612    begin
 613       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address));
 614    end Rcheck_08;
 615
 616    procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is
 617    begin
 618       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address));
 619    end Rcheck_09;
 620
 621    procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is
 622    begin
 623       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address));
 624    end Rcheck_10;
 625
 626    procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is
 627    begin
 628       Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address));
 629    end Rcheck_11;
 630
 631    procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is
 632    begin
 633       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address));
 634    end Rcheck_12;
 635
 636    procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is
 637    begin
 638       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address));
 639    end Rcheck_13;
 640
 641    procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is
 642    begin
 643       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address));
 644    end Rcheck_14;
 645
 646    procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is
 647    begin
 648       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address));
 649    end Rcheck_15;
 650
 651    procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is
 652    begin
 653       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address));
 654    end Rcheck_16;
 655
 656    procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is
 657    begin
 658       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address));
 659    end Rcheck_17;
 660
 661    procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is
 662    begin
 663       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address));
 664    end Rcheck_18;
 665
 666    procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is
 667    begin
 668       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address));
 669    end Rcheck_19;
 670
 671    procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is
 672    begin
 673       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address));
 674    end Rcheck_20;
 675
 676    procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is
 677    begin
 678       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address));
 679    end Rcheck_21;
 680
 681    procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is
 682    begin
 683       Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address));
 684    end Rcheck_22;
 685
 686    procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is
 687    begin
 688       Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address));
 689    end Rcheck_23;
 690
 691    procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is
 692    begin
 693       Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address));
 694    end Rcheck_24;
 695
 696    procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is
 697    begin
 698       Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address));
 699    end Rcheck_25;
 700
 701    procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is
 702    begin
 703       Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address));
 704    end Rcheck_26;
 705
 706    procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is
 707    begin
 708       Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address));
 709    end Rcheck_27;
 710
 711    procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is
 712    begin
 713       Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address));
 714    end Rcheck_28;
 715
 716    ---------------------------------------
 717    -- Exception backtracing subprograms --
 718    ---------------------------------------
 719
 720    --  What is automatically output when exception tracing is on basically
 721    --  corresponds to the usual exception information, but with the call
 722    --  chain backtrace possibly tailored by a backtrace decorator. Modifying
 723    --  Exception_Information itself is not a good idea because the decorated
 724    --  output is completely out of control and would break all our code
 725    --  related to the streaming of exceptions.
 726    --
 727    --  We then provide an alternative function to Exception_Information to
 728    --  compute the possibly tailored output, which is equivalent if no
 729    --  decorator is currently set :
 730
 731    function Tailored_Exception_Information
 732      (X    : Exception_Occurrence)
 733       return String;
 734    --  Exception information to be output in the case of automatic tracing
 735    --  requested through GNAT.Exception_Traces.
 736    --
 737    --  This is the same as Exception_Information if no backtrace decorator
 738    --  is currently in place. Otherwise, this is Exception_Information with
 739    --  the call chain raw addresses replaced by the result of a call to the
 740    --  current decorator provided with the call chain addresses.
 741
 742    pragma Export
 743      (Ada, Tailored_Exception_Information,
 744       "__gnat_tailored_exception_information");
 745    --  This function is used within this package but also from within
 746    --  System.Tasking.Stages.
 747    --
 748    --  The output of Exception_Information and Tailored_Exception_Information
 749    --  share a common part which was formerly built using local procedures
 750    --  within Exception_Information. These procedures have been extracted from
 751    --  their original place to be available to Tailored_Exception_Information
 752    --  also.
 753    --
 754    --  Each of these procedures appends some input to an information string
 755    --  currently being built. The Ptr argument represents the last position
 756    --  in this string at which a character has been written.
 757
 758    procedure Append_Info_Nat
 759      (N    : Natural;
 760       Info : in out String;
 761       Ptr  : in out Natural);
 762    --  Append the image of N at the end of the provided information string
 763
 764    procedure Append_Info_NL
 765      (Info : in out String;
 766       Ptr  : in out Natural);
 767    --  Append a LF at the end of the provided information string
 768
 769    procedure Append_Info_String
 770      (S    : String;
 771       Info : in out String;
 772       Ptr  : in out Natural);
 773    --  Append a string at the end of the provided information string
 774
 775    --  To build Exception_Information and Tailored_Exception_Information,
 776    --  we then use three intermediate functions :
 777
 778    function Basic_Exception_Information
 779      (X    : Exception_Occurrence)
 780       return String;
 781    --  Returns the basic exception information string associated with a
 782    --  given exception occurrence. This is the common part shared by both
 783    --  Exception_Information and Tailored_Exception_Infomation.
 784
 785    function Basic_Exception_Traceback
 786      (X    : Exception_Occurrence)
 787       return String;
 788    --  Returns an image of the complete call chain associated with an
 789    --  exception occurrence in its most basic form, that is as a raw sequence
 790    --  of hexadecimal binary addresses.
 791
 792    function Tailored_Exception_Traceback
 793      (X    : Exception_Occurrence)
 794       return String;
 795    --  Returns an image of the complete call chain associated with an
 796    --  exception occurrence, either in its basic form if no decorator is
 797    --  in place, or as formatted by the decorator otherwise.
 798
 799    --  The overall organization of the exception information related code
 800    --  is summarized below :
 801    --
 802    --           Exception_Information
 803    --                    |
 804    --            +-------+--------+
 805    --            |                |
 806    --     Basic_Exc_Info & Basic_Exc_Tback
 807    --
 808    --
 809    --       Tailored_Exception_Information
 810    --                    |
 811    --         +----------+----------+
 812    --         |                     |
 813    --  Basic_Exc_Info    &  Tailored_Exc_Tback
 814    --                               |
 815    --                   +-----------+------------+
 816    --                   |                        |
 817    --            Basic_Exc_Tback    Or    Tback_Decorator
 818    --          if no decorator set           otherwise
 819
 820    ----------------------------------------------
 821    -- Run-Time Exception Notification Routines --
 822    ----------------------------------------------
 823
 824    --  The notification routines described above are low level "handles" for
 825    --  the debugger but what needs to be done at the notification points
 826    --  always involves more than just calling one of these routines. The
 827    --  routines below provide a common run-time interface for this purpose,
 828    --  with variations depending on the handled/not handled status of the
 829    --  occurrence. They are exported to be usable by the Ada exception
 830    --  handling personality routine when the GCC 3 mechanism is used.
 831
 832    procedure Notify_Handled_Exception
 833      (Handler    : Code_Loc;
 834       Is_Others  : Boolean;
 835       Low_Notify : Boolean);
 836    pragma Export (C, Notify_Handled_Exception,
 837       "__gnat_notify_handled_exception");
 838    --  Routine to call when a handled occurrence is about to be propagated.
 839    --  Low_Notify might be set to false to skip the low level debugger
 840    --  notification, which is useful when the information it requires is
 841    --  not available, like in the SJLJ case.
 842
 843    procedure Notify_Unhandled_Exception (Id : Exception_Id);
 844    pragma Export (C, Notify_Unhandled_Exception,
 845      "__gnat_notify_unhandled_exception");
 846    --  Routine to call when an unhandled occurrence is about to be propagated.
 847
 848    --------------------------------
 849    -- Import Run-Time C Routines --
 850    --------------------------------
 851
 852    --  The purpose of the following pragma Imports is to ensure that we
 853    --  generate appropriate subprogram descriptors for all C routines in
 854    --  the standard GNAT library that can raise exceptions. This ensures
 855    --  that the exception propagation can properly find these routines
 856
 857    pragma Warnings (Off);        -- so old compiler does not complain
 858    pragma Propagate_Exceptions;
 859
 860    procedure Unhandled_Terminate;
 861    pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
 862
 863    -----------------------
 864    -- Polling Interface --
 865    -----------------------
 866
 867    type Unsigned is mod 2 ** 32;
 868
 869    Counter : Unsigned := 0;
 870    --  This counter is provided for convenience. It can be used in Poll to
 871    --  perform periodic but not systematic operations.
 872
 873    procedure Poll is separate;
 874    --  The actual polling routine is separate, so that it can easily
 875    --  be replaced with a target dependent version.
 876
 877    ---------
 878    -- AAA --
 879    ---------
 880
 881    --  This dummy procedure gives us the start of the PC range for addresses
 882    --  within the exception unit itself. We hope that gigi/gcc keep all the
 883    --  procedures in their original order!
 884
 885    procedure AAA is
 886    begin
 887       null;
 888    end AAA;
 889
 890    -------------------
 891    -- Address_Image --
 892    -------------------
 893
 894    function Address_Image (A : Address) return String is
 895       S : String (1 .. 18);
 896       P : Natural;
 897       N : Integer_Address;
 898
 899       H : constant array (Integer range 0 .. 15) of Character :=
 900                                                          "0123456789abcdef";
 901    begin
 902       P := S'Last;
 903       N := To_Integer (A);
 904       while N /= 0 loop
 905          S (P) := H (Integer (N mod 16));
 906          P := P - 1;
 907          N := N / 16;
 908       end loop;
 909
 910       S (P - 1) := '0';
 911       S (P) := 'x';
 912       return S (P - 1 .. S'Last);
 913    end Address_Image;
 914
 915    ---------------------
 916    -- Append_Info_Nat --
 917    ---------------------
 918
 919    procedure Append_Info_Nat
 920      (N    : Natural;
 921       Info : in out String;
 922       Ptr  : in out Natural)
 923    is
 924    begin
 925       if N > 9 then
 926          Append_Info_Nat (N / 10, Info, Ptr);
 927       end if;
 928
 929       Ptr := Ptr + 1;
 930       Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10);
 931    end Append_Info_Nat;
 932
 933    --------------------
 934    -- Append_Info_NL --
 935    --------------------
 936
 937    procedure Append_Info_NL
 938      (Info : in out String;
 939       Ptr  : in out Natural)
 940    is
 941    begin
 942       Ptr := Ptr + 1;
 943       Info (Ptr) := ASCII.LF;
 944    end Append_Info_NL;
 945
 946    ------------------------
 947    -- Append_Info_String --
 948    ------------------------
 949
 950    procedure Append_Info_String
 951      (S    : String;
 952       Info : in out String;
 953       Ptr  : in out Natural)
 954    is
 955    begin
 956       Info (Ptr + 1 .. Ptr + S'Length) := S;
 957       Ptr := Ptr + S'Length;
 958    end Append_Info_String;
 959
 960    ---------------------------------
 961    -- Basic_Exception_Information --
 962    ---------------------------------
 963
 964    function Basic_Exception_Information
 965      (X    : Exception_Occurrence)
 966       return String
 967    is
 968       Name : constant String  := Exception_Name (X);
 969       Msg  : constant String  := Exception_Message (X);
 970       --  Exception name and message that are going to be included in the
 971       --  information to return, if not empty.
 972
 973       Name_Len : constant Natural := Name'Length;
 974       Msg_Len  : constant Natural := Msg'Length;
 975       --  Length of these strings, useful to compute the size of the string
 976       --  we have to allocate for the complete result as well as in the body
 977       --  of this procedure.
 978
 979       Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len;
 980       --  Maximum length of the information string we will build, with :
 981       --
 982       --  50 =    16 + 2   for the text associated with the name
 983       --        +  9 + 2   for the text associated with the message
 984       --        +  5 + 2   for the text associated with the pid
 985       --        + 14       for the text image of the pid itself and a margin.
 986       --
 987       --  This is indeed a maximum since some data may not appear at all if
 988       --  not relevant. For example, nothing related to the exception message
 989       --  will be there if this message is empty.
 990       --
 991       --  WARNING : Do not forget to update these numbers if anything
 992       --  involved in the computation changes.
 993
 994       Info : String (1 .. Info_Maxlen);
 995       --  Information string we are going to build, containing the common
 996       --  part shared by Exc_Info and Tailored_Exc_Info.
 997
 998       Ptr  : Natural := 0;
 999
1000    begin
1001       --  Output exception name and message except for _ABORT_SIGNAL, where
1002       --  these two lines are omitted (see discussion above).
1003
1004       if Name (1) /= '_' then
1005          Append_Info_String ("Exception name: ", Info, Ptr);
1006          Append_Info_String (Name, Info, Ptr);
1007          Append_Info_NL (Info, Ptr);
1008
1009          if Msg_Len /= 0 then
1010             Append_Info_String ("Message: ", Info, Ptr);
1011             Append_Info_String (Msg, Info, Ptr);
1012             Append_Info_NL (Info, Ptr);
1013          end if;
1014       end if;
1015
1016       --  Output PID line if non-zero
1017
1018       if X.Pid /= 0 then
1019          Append_Info_String ("PID: ", Info, Ptr);
1020          Append_Info_Nat (X.Pid, Info, Ptr);
1021          Append_Info_NL (Info, Ptr);
1022       end if;
1023
1024       return Info (1 .. Ptr);
1025    end Basic_Exception_Information;
1026
1027    -------------------------------
1028    -- Basic_Exception_Traceback --
1029    -------------------------------
1030
1031    function Basic_Exception_Traceback
1032      (X    : Exception_Occurrence)
1033       return String
1034    is
1035       Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
1036       --  Maximum length of the information string we are building, with :
1037       --  33 = 31 + 4      for the text before and after the traceback, and
1038       --  19 =  2 + 16 + 1 for each address ("0x" + HHHH + " ")
1039       --
1040       --  WARNING : Do not forget to update these numbers if anything
1041       --  involved in the computation changes.
1042
1043       Info : String (1 .. Info_Maxlen);
1044       --  Information string we are going to build, containing an image
1045       --  of the call chain associated with the exception occurrence in its
1046       --  most basic form, that is as a sequence of binary addresses.
1047
1048       Ptr  : Natural := 0;
1049
1050    begin
1051       if X.Num_Tracebacks > 0 then
1052          Append_Info_String ("Call stack traceback locations:", Info, Ptr);
1053          Append_Info_NL (Info, Ptr);
1054
1055          for J in 1 .. X.Num_Tracebacks loop
1056             Append_Info_String (Address_Image (X.Tracebacks (J)), Info, Ptr);
1057             exit when J = X.Num_Tracebacks;
1058             Append_Info_String (" ", Info, Ptr);
1059          end loop;
1060
1061          Append_Info_NL (Info, Ptr);
1062       end if;
1063
1064       return Info (1 .. Ptr);
1065    end Basic_Exception_Traceback;
1066
1067    -----------------
1068    -- Break_Start --
1069    -----------------
1070
1071    procedure Break_Start is
1072    begin
1073       null;
1074    end Break_Start;
1075
1076    ----------------
1077    -- Call_Chain --
1078    ----------------
1079
1080    procedure Call_Chain (Excep : EOA) is
1081    begin
1082       if Excep.Num_Tracebacks /= 0 then
1083          --  This is a reraise, no need to store a new (wrong) chain.
1084          return;
1085       end if;
1086
1087       System.Traceback.Call_Chain
1088         (Excep.Tracebacks'Address,
1089          Max_Tracebacks,
1090          Excep.Num_Tracebacks,
1091          AAA'Address,
1092          ZZZ'Address);
1093    end Call_Chain;
1094
1095    ------------------------------
1096    -- Current_Target_Exception --
1097    ------------------------------
1098
1099    function Current_Target_Exception return Exception_Occurrence is
1100    begin
1101       return Null_Occurrence;
1102    end Current_Target_Exception;
1103
1104    -------------------
1105    -- EId_To_String --
1106    -------------------
1107
1108    function EId_To_String (X : Exception_Id) return String is
1109    begin
1110       if X = Null_Id then
1111          return "";
1112       else
1113          return Exception_Name (X);
1114       end if;
1115    end EId_To_String;
1116
1117    ------------------
1118    -- EO_To_String --
1119    ------------------
1120
1121    --  We use the null string to represent the null occurrence, otherwise
1122    --  we output the Exception_Information string for the occurrence.
1123
1124    function EO_To_String (X : Exception_Occurrence) return String is
1125    begin
1126       if X.Id = Null_Id then
1127          return "";
1128       else
1129          return Exception_Information (X);
1130       end if;
1131    end EO_To_String;
1132
1133    ------------------------
1134    -- Exception_Identity --
1135    ------------------------
1136
1137    function Exception_Identity
1138      (X    : Exception_Occurrence)
1139       return Exception_Id
1140    is
1141    begin
1142       if X.Id = Null_Id then
1143          raise Constraint_Error;
1144       else
1145          return X.Id;
1146       end if;
1147    end Exception_Identity;
1148
1149    ---------------------------
1150    -- Exception_Information --
1151    ---------------------------
1152
1153    --  The format of the string is:
1154
1155    --    Exception_Name: nnnnn
1156    --    Message: mmmmm
1157    --    PID: ppp
1158    --    Call stack traceback locations:
1159    --    0xhhhh 0xhhhh 0xhhhh ... 0xhhh
1160
1161    --  where
1162
1163    --    nnnn is the fully qualified name of the exception in all upper
1164    --    case letters. This line is always present.
1165
1166    --    mmmm is the message (this line present only if message is non-null)
1167
1168    --    ppp is the Process Id value as a decimal integer (this line is
1169    --    present only if the Process Id is non-zero). Currently we are
1170    --    not making use of this field.
1171
1172    --    The Call stack traceback locations line and the following values
1173    --    are present only if at least one traceback location was recorded.
1174    --    the values are given in C style format, with lower case letters
1175    --    for a-f, and only as many digits present as are necessary.
1176
1177    --  The line terminator sequence at the end of each line, including the
1178    --  last line is a CR-LF sequence (16#0D# followed by 16#0A#).
1179
1180    --  The Exception_Name and Message lines are omitted in the abort
1181    --  signal case, since this is not really an exception, and the only
1182    --  use of this routine is internal for printing termination output.
1183
1184    --  WARNING: if the format of the generated string is changed, please note
1185    --  that an equivalent modification to the routine String_To_EO must be
1186    --  made to preserve proper functioning of the stream attributes.
1187
1188    function Exception_Information (X : Exception_Occurrence) return String is
1189
1190       --  This information is now built using the circuitry introduced in
1191       --  association with the support of traceback decorators, as the
1192       --  catenation of the exception basic information and the call chain
1193       --  backtrace in its basic form.
1194
1195       Basic_Info : constant String  := Basic_Exception_Information (X);
1196       Tback_Info : constant String  := Basic_Exception_Traceback (X);
1197
1198       Basic_Len  : constant Natural := Basic_Info'Length;
1199       Tback_Len  : constant Natural := Tback_Info'Length;
1200
1201       Info : String (1 .. Basic_Len + Tback_Len);
1202       Ptr  : Natural := 0;
1203
1204    begin
1205       Append_Info_String (Basic_Info, Info, Ptr);
1206       Append_Info_String (Tback_Info, Info, Ptr);
1207
1208       return Info;
1209    end Exception_Information;
1210
1211    -----------------------
1212    -- Exception_Message --
1213    -----------------------
1214
1215    function Exception_Message (X : Exception_Occurrence) return String is
1216    begin
1217       if X.Id = Null_Id then
1218          raise Constraint_Error;
1219       end if;
1220
1221       return X.Msg (1 .. X.Msg_Length);
1222    end Exception_Message;
1223
1224    --------------------
1225    -- Exception_Name --
1226    --------------------
1227
1228    function Exception_Name (Id : Exception_Id) return String is
1229    begin
1230       if Id = null then
1231          raise Constraint_Error;
1232       end if;
1233
1234       return Id.Full_Name.all (1 .. Id.Name_Length - 1);
1235    end Exception_Name;
1236
1237    function Exception_Name (X : Exception_Occurrence) return String is
1238    begin
1239       return Exception_Name (X.Id);
1240    end Exception_Name;
1241
1242    ---------------------------
1243    -- Exception_Name_Simple --
1244    ---------------------------
1245
1246    function Exception_Name_Simple (X : Exception_Occurrence) return String is
1247       Name : constant String := Exception_Name (X);
1248       P    : Natural;
1249
1250    begin
1251       P := Name'Length;
1252       while P > 1 loop
1253          exit when Name (P - 1) = '.';
1254          P := P - 1;
1255       end loop;
1256
1257       return Name (P .. Name'Length);
1258    end Exception_Name_Simple;
1259
1260    -----------------------------
1261    -- Process_Raise_Exception --
1262    -----------------------------
1263
1264    procedure Process_Raise_Exception
1265      (E                   : Exception_Id;
1266       From_Signal_Handler : Boolean)
1267    is
1268       pragma Inspection_Point (E);
1269       --  This is so the debugger can reliably inspect the parameter
1270
1271       Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
1272       Mstate_Ptr  : constant Machine_State :=
1273                       Machine_State (Get_Machine_State_Addr.all);
1274       Excep       : EOA := Get_Current_Excep.all;
1275
1276    begin
1277       --  WARNING : There should be no exception handler for this body
1278       --  because this would cause gigi to prepend a setup for a new
1279       --  jmpbuf to the sequence of statements. We would then always get
1280       --  this new buf in Jumpbuf_Ptr instead of the one for the exception
1281       --  we are handling, which would completely break the whole design
1282       --  of this procedure.
1283
1284       --  Processing varies between zero cost and setjmp/lonjmp processing.
1285
1286       if Zero_Cost_Exceptions /= 0 then
1287
1288          --  Use the front-end tables to propagate if we have them, otherwise
1289          --  resort to the GCC back-end alternative. The backtrace for the
1290          --  occurrence is stored while walking up the stack, and thus stops
1291          --  in the handler's frame if there is one. Notifications are also
1292          --  not performed here since it is not yet known if the exception is
1293          --  handled.
1294
1295          --  Set the machine state unless we are raising from a signal handler
1296          --  since it has already been set properly in that case.
1297
1298          if not From_Signal_Handler then
1299             Set_Machine_State (Mstate_Ptr);
1300          end if;
1301
1302          if Subprogram_Descriptors /= null then
1303             Propagate_Exception_With_FE_Support (Mstate_Ptr);
1304          else
1305             Propagate_Exception_With_GCC_Support (Mstate_Ptr);
1306          end if;
1307
1308       else
1309
1310          --  Compute the backtrace for this occurrence if the corresponding
1311          --  binder option has been set and we are not raising from a signal
1312          --  handler. Call_Chain takes care of the reraise case.
1313
1314          if not From_Signal_Handler
1315            and then Exception_Tracebacks /= 0
1316          then
1317             Call_Chain (Excep);
1318          end if;
1319
1320          --  If the jump buffer pointer is non-null, transfer control using
1321          --  it. Otherwise announce an unhandled exception (note that this
1322          --  means that we have no finalizations to do other than at the outer
1323          --  level). Perform the necessary notification tasks in both cases.
1324
1325          if Jumpbuf_Ptr /= Null_Address then
1326
1327             if not Excep.Exception_Raised then
1328                Excep.Exception_Raised := True;
1329                Notify_Handled_Exception (Null_Loc, False, False);
1330
1331                --  The low level debugger notification is skipped from the
1332                --  call above because we do not have the necessary information
1333                --  to "feed" it properly.
1334
1335             end if;
1336
1337             builtin_longjmp (Jumpbuf_Ptr, 1);
1338
1339          else
1340             Notify_Unhandled_Exception (E);
1341             Unhandled_Exception_Terminate;
1342          end if;
1343       end if;
1344
1345    end Process_Raise_Exception;
1346
1347    -----------------------------------------
1348    -- Propagate_Exception_With_FE_Support --
1349    -----------------------------------------
1350
1351    procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State) is
1352       Excep  : constant EOA := Get_Current_Excep.all;
1353       Loc    : Code_Loc;
1354       Lo, Hi : Natural;
1355       Pdesc  : Natural;
1356       Hrec   : Handler_Record_Ptr;
1357       Info   : Subprogram_Info_Type;
1358
1359       type Machine_State_Record is
1360         new Storage_Array (1 .. Machine_State_Length);
1361       for Machine_State_Record'Alignment use Standard'Maximum_Alignment;
1362
1363       procedure Duplicate_Machine_State (Dest, Src : Machine_State);
1364       --  Copy Src into Dest, assuming that a Machine_State is pointing to
1365       --  an area of Machine_State_Length bytes.
1366
1367       procedure Duplicate_Machine_State (Dest, Src : Machine_State) is
1368          type Machine_State_Record_Access is access Machine_State_Record;
1369          function To_MSR is new Unchecked_Conversion
1370            (Machine_State, Machine_State_Record_Access);
1371
1372       begin
1373          To_MSR (Dest).all := To_MSR (Src).all;
1374       end Duplicate_Machine_State;
1375
1376       --  Data for handling the finalization handler case. A simple approach
1377       --  in this routine would simply to unwind stack frames till we find a
1378       --  handler and then enter it. But this is undesirable in the case where
1379       --  we have only finalization handlers, and no "real" handler, i.e. a
1380       --  case where we have an unhandled exception.
1381
1382       --  In this case we prefer to signal unhandled exception with the stack
1383       --  intact, and entering finalization handlers would destroy the stack
1384       --  state. To deal with this, as we unwind the stack, we note the first
1385       --  finalization handler, and remember it in the following variables.
1386       --  We then continue to unwind. If and when we find a "real", i.e. non-
1387       --  finalization handler, then we use these variables to pass control to
1388       --  the finalization handler.
1389
1390       FH_Found : Boolean := False;
1391       --  Set when a finalization handler is found
1392
1393       FH_Mstate : aliased Machine_State_Record;
1394       --  Records the machine state for the finalization handler
1395
1396       FH_Handler : Code_Loc := Null_Address;
1397       --  Record handler address for finalization handler
1398
1399       FH_Num_Trb : Natural := 0;
1400       --  Save number of tracebacks for finalization handler
1401
1402    begin
1403       --  Loop through stack frames as exception propagates
1404
1405       Main_Loop : loop
1406          Loc := Get_Code_Loc (Mstate);
1407          exit Main_Loop when Loc = Null_Loc;
1408
1409          --  Record location unless it is inside this unit. Note: this
1410          --  test should really say Code_Address, but Address is the same
1411          --  as Code_Address for unnested subprograms, and Code_Address
1412          --  would cause a bootstrap problem
1413
1414          if Loc < AAA'Address or else Loc > ZZZ'Address then
1415
1416             --  Record location unless we already recorded max tracebacks
1417
1418             if Excep.Num_Tracebacks /= Max_Tracebacks then
1419
1420                --  Do not record location if it is the return point from
1421                --  a reraise call from within a cleanup handler
1422
1423                if not Excep.Cleanup_Flag then
1424                   Excep.Num_Tracebacks := Excep.Num_Tracebacks + 1;
1425                   Excep.Tracebacks (Excep.Num_Tracebacks) := Loc;
1426
1427                --  For reraise call from cleanup handler, skip entry and
1428                --  clear the flag so that we will start to record again
1429
1430                else
1431                   Excep.Cleanup_Flag := False;
1432                end if;
1433             end if;
1434          end if;
1435
1436          --  Do binary search on procedure table
1437
1438          Lo := 1;
1439          Hi := Num_Subprogram_Descriptors;
1440
1441          --  Binary search loop
1442
1443          loop
1444             Pdesc := (Lo + Hi) / 2;
1445
1446             --  Note that Loc is expected to be the procedure's call point
1447             --  and not the return point.
1448
1449             if Loc < Subprogram_Descriptors (Pdesc).Code then
1450                Hi := Pdesc - 1;
1451
1452             elsif Pdesc < Num_Subprogram_Descriptors
1453               and then Loc > Subprogram_Descriptors (Pdesc + 1).Code
1454             then
1455                Lo := Pdesc + 1;
1456
1457             else
1458                exit;
1459             end if;
1460
1461             --  This happens when the current Loc is completely outside of
1462             --  the range of the program, which usually means that we reached
1463             --  the top level frame (e.g __start). In this case we have an
1464             --  unhandled exception.
1465
1466             exit Main_Loop when Hi < Lo;
1467          end loop;
1468
1469          --  Come here with Subprogram_Descriptors (Pdesc) referencing the
1470          --  procedure descriptor that applies to this PC value. Now do a
1471          --  serial search to see if any handler is applicable to this PC
1472          --  value, and to the exception that we are propagating
1473
1474          for J in 1 .. Subprogram_Descriptors (Pdesc).Num_Handlers loop
1475             Hrec := Subprogram_Descriptors (Pdesc).Handler_Records (J);
1476
1477             if Loc >= Hrec.Lo and then Loc < Hrec.Hi then
1478
1479                --  PC range is applicable, see if handler is for this exception
1480
1481                --  First test for case of "all others" (finalization) handler.
1482                --  We do not enter such a handler until we are sure there is
1483                --  a real handler further up the stack.
1484
1485                if Hrec.Id = All_Others_Id then
1486
1487                   --  If this is the first finalization handler, then
1488                   --  save the machine state so we can enter it later
1489                   --  without having to repeat the search.
1490
1491                   if not FH_Found then
1492                      FH_Found   := True;
1493                      Duplicate_Machine_State
1494                        (Machine_State (FH_Mstate'Address), Mstate);
1495                      FH_Handler := Hrec.Handler;
1496                      FH_Num_Trb := Excep.Num_Tracebacks;
1497                   end if;
1498
1499                --  Normal (non-finalization exception with matching Id)
1500
1501                elsif Excep.Id = Hrec.Id
1502                  or else (Hrec.Id = Others_Id
1503                             and not Excep.Id.Not_Handled_By_Others)
1504                then
1505                   --  Perform the necessary notification tasks.
1506
1507                   Notify_Handled_Exception
1508                     (Hrec.Handler, Hrec.Id = Others_Id, True);
1509
1510                   --  If we already encountered a finalization handler, then
1511                   --  reset the context to that handler, and enter it.
1512
1513                   if FH_Found then
1514                      Excep.Num_Tracebacks := FH_Num_Trb;
1515                      Excep.Cleanup_Flag   := True;
1516
1517                      Enter_Handler
1518                        (Machine_State (FH_Mstate'Address), FH_Handler);
1519
1520                   --  If we have not encountered a finalization handler,
1521                   --  then enter the current handler.
1522
1523                   else
1524                      Enter_Handler (Mstate, Hrec.Handler);
1525                   end if;
1526                end if;
1527             end if;
1528          end loop;
1529
1530          Info := Subprogram_Descriptors (Pdesc).Subprogram_Info;
1531          exit Main_Loop when Info = No_Info;
1532          Pop_Frame (Mstate, Info);
1533       end loop Main_Loop;
1534
1535       --  Fall through if no "real" exception handler found. First thing is to
1536       --  perform the necessary notification tasks with the stack intact.
1537
1538       Notify_Unhandled_Exception (Excep.Id);
1539
1540       --  If there were finalization handlers, then enter the top one.
1541       --  Just because there is no handler does not mean we don't have
1542       --  to still execute all finalizations and cleanups before
1543       --  terminating. Note that the process of calling cleanups
1544       --  does not disturb the back trace stack, since he same
1545       --  exception occurrence gets reraised, and new traceback
1546       --  entries added as we go along.
1547
1548       if FH_Found then
1549          Excep.Num_Tracebacks := FH_Num_Trb;
1550          Excep.Cleanup_Flag   := True;
1551          Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler);
1552       end if;
1553
1554       --  If no cleanups, then this is the real unhandled termination
1555
1556       Unhandled_Exception_Terminate;
1557
1558    end Propagate_Exception_With_FE_Support;
1559
1560    ------------------------------------------
1561    -- Propagate_Exception_With_GCC_Support --
1562    ------------------------------------------
1563
1564    procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State) is
1565       Excep          : EOA := Get_Current_Excep.all;
1566       This_Exception : aliased GNAT_GCC_Exception;
1567       Status         : Unwind_Reason_Code;
1568
1569    begin
1570       --  ??? Nothing is currently done for backtracing purposes. We could
1571       --  have used the personality routine to record the addresses while
1572       --  walking up the stack, but this method has two drawbacks : 1/ the
1573       --  trace is incomplete if the exception is handled since we don't walk
1574       --  up the frame with the handler, and 2/ we will miss frames if the
1575       --  exception propagates through frames for which our personality
1576       --  routine is not called (e.g. if C or C++ frames are on the way).
1577
1578       --  Fill in the useful flags for the personality routine called for each
1579       --  frame via the call to Unwind_RaiseException below.
1580
1581       This_Exception.Id := Excep.Id;
1582       This_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others;
1583       This_Exception.Has_Cleanup := False;
1584
1585       --  We are looking for a regular handler first. If there is one, either
1586       --  it or the first at-end handler before it will be entered. If there
1587       --  is none, control will normally get back to after the call, with
1588       --  Has_Cleanup set to true if at least one at-end handler has been
1589       --  found while walking up the stack.
1590
1591       This_Exception.Select_Cleanups := False;
1592
1593       Status := Unwind_RaiseException (This_Exception'Access);
1594
1595       --  If we get here we know the exception is not handled, as otherwise
1596       --  Unwind_RaiseException arranges for a handler to be entered. We might
1597       --  have met cleanups handlers, though, requiring to start again with
1598       --  the Select_Cleanups flag set to True.
1599
1600       --  Before restarting for cleanups, take the necessary steps to enable
1601       --  the debugger to gain control while the stack is still intact. Flag
1602       --  the occurrence as raised to avoid notifying again in case cleanup
1603       --  handlers are entered later.
1604
1605       if not Excep.Exception_Raised then
1606          Excep.Exception_Raised := True;
1607          Notify_Unhandled_Exception (Excep.Id);
1608       end if;
1609
1610       --  Now raise again selecting cleanups as true handlers. Only do this if
1611       --  we know at least one such handler exists since otherwise we would
1612       --  perform a complete stack upwalk for nothing.
1613
1614       if This_Exception.Has_Cleanup then
1615          This_Exception.Select_Cleanups := True;
1616          Status := Unwind_RaiseException (This_Exception'Access);
1617
1618          --  The first cleanup found is entered. It performs its job, raises
1619          --  the initial exception again, and the flow goes back to the first
1620          --  step above with the stack in a different state.
1621       end if;
1622
1623       --  We get here when there is no handler to be run at all. The debugger
1624       --  has been notified before the second step above.
1625
1626       Unhandled_Exception_Terminate;
1627
1628    end Propagate_Exception_With_GCC_Support;
1629
1630    ----------------------------
1631    -- Raise_Constraint_Error --
1632    ----------------------------
1633
1634    procedure Raise_Constraint_Error
1635      (File : Big_String_Ptr;
1636       Line : Integer)
1637    is
1638    begin
1639       Raise_With_Location (Constraint_Error_Def'Access, File, Line);
1640    end Raise_Constraint_Error;
1641
1642    --------------------------------
1643    -- Raise_Constraint_Error_Msg --
1644    --------------------------------
1645
1646    procedure Raise_Constraint_Error_Msg
1647      (File : Big_String_Ptr;
1648       Line : Integer;
1649       Msg  : Big_String_Ptr)
1650    is
1651    begin
1652       Raise_With_Location_And_Msg
1653         (Constraint_Error_Def'Access, File, Line, Msg);
1654    end Raise_Constraint_Error_Msg;
1655
1656    -------------------------
1657    -- Raise_Current_Excep --
1658    -------------------------
1659
1660    procedure Raise_Current_Excep (E : Exception_Id) is
1661    begin
1662       Process_Raise_Exception (E => E, From_Signal_Handler => False);
1663    end Raise_Current_Excep;
1664
1665    ---------------------
1666    -- Raise_Exception --
1667    ---------------------
1668
1669    procedure Raise_Exception
1670      (E       : Exception_Id;
1671       Message : String := "")
1672    is
1673       Len : constant Natural :=
1674               Natural'Min (Message'Length, Exception_Msg_Max_Length);
1675       Excep : constant EOA := Get_Current_Excep.all;
1676
1677    begin
1678       if E /= null then
1679          Excep.Msg_Length := Len;
1680          Excep.Msg (1 .. Len) := Message (1 .. Len);
1681          Raise_With_Msg (E);
1682       end if;
1683    end Raise_Exception;
1684
1685    ----------------------------
1686    -- Raise_Exception_Always --
1687    ----------------------------
1688
1689    procedure Raise_Exception_Always
1690      (E       : Exception_Id;
1691       Message : String := "")
1692    is
1693       Len : constant Natural :=
1694               Natural'Min (Message'Length, Exception_Msg_Max_Length);
1695
1696       Excep : constant EOA := Get_Current_Excep.all;
1697
1698    begin
1699       Excep.Msg_Length := Len;
1700       Excep.Msg (1 .. Len) := Message (1 .. Len);
1701       Raise_With_Msg (E);
1702    end Raise_Exception_Always;
1703
1704    -------------------------------
1705    -- Raise_From_Signal_Handler --
1706    -------------------------------
1707
1708    procedure Raise_From_Signal_Handler
1709      (E : Exception_Id;
1710       M : Big_String_Ptr)
1711    is
1712    begin
1713       Set_Exception_C_Msg (E, M);
1714       Abort_Defer.all;
1715       Process_Raise_Exception (E => E, From_Signal_Handler => True);
1716    end Raise_From_Signal_Handler;
1717
1718    ------------------
1719    -- Raise_No_Msg --
1720    ------------------
1721
1722    procedure Raise_No_Msg (E : Exception_Id) is
1723       Excep : constant EOA := Get_Current_Excep.all;
1724
1725    begin
1726       Excep.Msg_Length := 0;
1727       Raise_With_Msg (E);
1728    end Raise_No_Msg;
1729
1730    -------------------------
1731    -- Raise_Program_Error --
1732    -------------------------
1733
1734    procedure Raise_Program_Error
1735      (File : Big_String_Ptr;
1736       Line : Integer)
1737    is
1738    begin
1739       Raise_With_Location (Program_Error_Def'Access, File, Line);
1740    end Raise_Program_Error;
1741
1742    -----------------------------
1743    -- Raise_Program_Error_Msg --
1744    -----------------------------
1745
1746    procedure Raise_Program_Error_Msg
1747      (File : Big_String_Ptr;
1748       Line : Integer;
1749       Msg  : Big_String_Ptr)
1750    is
1751    begin
1752       Raise_With_Location_And_Msg
1753         (Program_Error_Def'Access, File, Line, Msg);
1754    end Raise_Program_Error_Msg;
1755
1756    -------------------------
1757    -- Raise_Storage_Error --
1758    -------------------------
1759
1760    procedure Raise_Storage_Error
1761      (File : Big_String_Ptr;
1762       Line : Integer)
1763    is
1764    begin
1765       Raise_With_Location (Storage_Error_Def'Access, File, Line);
1766    end Raise_Storage_Error;
1767
1768    -----------------------------
1769    -- Raise_Storage_Error_Msg --
1770    -----------------------------
1771
1772    procedure Raise_Storage_Error_Msg
1773      (File : Big_String_Ptr;
1774       Line : Integer;
1775       Msg  : Big_String_Ptr)
1776    is
1777    begin
1778       Raise_With_Location_And_Msg
1779         (Storage_Error_Def'Access, File, Line, Msg);
1780    end Raise_Storage_Error_Msg;
1781
1782    ----------------------
1783    -- Raise_With_C_Msg --
1784    ----------------------
1785
1786    procedure Raise_With_C_Msg
1787      (E : Exception_Id;
1788       M : Big_String_Ptr)
1789    is
1790    begin
1791       Set_Exception_C_Msg (E, M);
1792       Abort_Defer.all;
1793       Raise_Current_Excep (E);
1794    end Raise_With_C_Msg;
1795
1796    -------------------------
1797    -- Raise_With_Location --
1798    -------------------------
1799
1800    procedure Raise_With_Location
1801      (E : Exception_Id;
1802       F : Big_String_Ptr;
1803       L : Integer)
1804    is
1805    begin
1806       Set_Exception_C_Msg (E, F, L);
1807       Abort_Defer.all;
1808       Raise_Current_Excep (E);
1809    end Raise_With_Location;
1810
1811    ---------------------------------
1812    -- Raise_With_Location_And_Msg --
1813    ---------------------------------
1814
1815    procedure Raise_With_Location_And_Msg
1816      (E : Exception_Id;
1817       F : Big_String_Ptr;
1818       L : Integer;
1819       M : Big_String_Ptr)
1820    is
1821    begin
1822       Set_Exception_C_Msg (E, F, L, M);
1823       Abort_Defer.all;
1824       Raise_Current_Excep (E);
1825    end Raise_With_Location_And_Msg;
1826
1827    --------------------
1828    -- Raise_With_Msg --
1829    --------------------
1830
1831    procedure Raise_With_Msg (E : Exception_Id) is
1832       Excep : constant EOA := Get_Current_Excep.all;
1833
1834    begin
1835       Excep.Exception_Raised := False;
1836       Excep.Id               := E;
1837       Excep.Num_Tracebacks   := 0;
1838       Excep.Cleanup_Flag     := False;
1839       Excep.Pid              := Local_Partition_ID;
1840       Abort_Defer.all;
1841       Raise_Current_Excep (E);
1842    end Raise_With_Msg;
1843
1844    -------------
1845    -- Reraise --
1846    -------------
1847
1848    procedure Reraise is
1849       Excep : constant EOA := Get_Current_Excep.all;
1850
1851    begin
1852       Abort_Defer.all;
1853       Raise_Current_Excep (Excep.Id);
1854    end Reraise;
1855
1856    ------------------------
1857    -- Reraise_Occurrence --
1858    ------------------------
1859
1860    procedure Reraise_Occurrence (X : Exception_Occurrence) is
1861    begin
1862       if X.Id /= null then
1863          Abort_Defer.all;
1864          Save_Occurrence (Get_Current_Excep.all.all, X);
1865          Raise_Current_Excep (X.Id);
1866       end if;
1867    end Reraise_Occurrence;
1868
1869    -------------------------------
1870    -- Reraise_Occurrence_Always --
1871    -------------------------------
1872
1873    procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
1874    begin
1875       Abort_Defer.all;
1876       Save_Occurrence (Get_Current_Excep.all.all, X);
1877       Raise_Current_Excep (X.Id);
1878    end Reraise_Occurrence_Always;
1879
1880    ---------------------------------
1881    -- Reraise_Occurrence_No_Defer --
1882    ---------------------------------
1883
1884    procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
1885    begin
1886       Save_Occurrence (Get_Current_Excep.all.all, X);
1887       Raise_Current_Excep (X.Id);
1888    end Reraise_Occurrence_No_Defer;
1889
1890    ---------------------
1891    -- Save_Occurrence --
1892    ---------------------
1893
1894    procedure Save_Occurrence
1895      (Target : out Exception_Occurrence;
1896       Source : Exception_Occurrence)
1897    is
1898    begin
1899       Target.Id             := Source.Id;
1900       Target.Msg_Length     := Source.Msg_Length;
1901       Target.Num_Tracebacks := Source.Num_Tracebacks;
1902       Target.Pid            := Source.Pid;
1903       Target.Cleanup_Flag   := Source.Cleanup_Flag;
1904
1905       Target.Msg (1 .. Target.Msg_Length) :=
1906         Source.Msg (1 .. Target.Msg_Length);
1907
1908       Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
1909         Source.Tracebacks (1 .. Target.Num_Tracebacks);
1910    end Save_Occurrence;
1911
1912    function Save_Occurrence
1913      (Source : Exception_Occurrence)
1914       return   EOA
1915    is
1916       Target : EOA := new Exception_Occurrence;
1917
1918    begin
1919       Save_Occurrence (Target.all, Source);
1920       return Target;
1921    end Save_Occurrence;
1922
1923    ---------------------
1924    -- SDP_Table_Build --
1925    ---------------------
1926
1927    procedure SDP_Table_Build
1928      (SDP_Addresses   : System.Address;
1929       SDP_Count       : Natural;
1930       Elab_Addresses  : System.Address;
1931       Elab_Addr_Count : Natural)
1932    is
1933       type SDLP_Array is array (1 .. SDP_Count) of Subprogram_Descriptors_Ptr;
1934       type SDLP_Array_Ptr is access all SDLP_Array;
1935
1936       function To_SDLP_Array_Ptr is new Unchecked_Conversion
1937         (System.Address, SDLP_Array_Ptr);
1938
1939       T : constant SDLP_Array_Ptr := To_SDLP_Array_Ptr (SDP_Addresses);
1940
1941       type Elab_Array is array (1 .. Elab_Addr_Count) of Code_Loc;
1942       type Elab_Array_Ptr is access all Elab_Array;
1943
1944       function To_Elab_Array_Ptr is new Unchecked_Conversion
1945         (System.Address, Elab_Array_Ptr);
1946
1947       EA : constant Elab_Array_Ptr := To_Elab_Array_Ptr (Elab_Addresses);
1948
1949       Ndes : Natural;
1950       Previous_Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
1951
1952    begin
1953       --  If first call, then initialize count of subprogram descriptors
1954
1955       if Subprogram_Descriptors = null then
1956          Num_Subprogram_Descriptors := 0;
1957       end if;
1958
1959       --  First count number of subprogram descriptors. This count includes
1960       --  entries with duplicated code addresses (resulting from Import).
1961
1962       Ndes := Num_Subprogram_Descriptors + Elab_Addr_Count;
1963       for J in T'Range loop
1964          Ndes := Ndes + T (J).Count;
1965       end loop;
1966
1967       --  Now, allocate the new table (extra zero'th element is for sort call)
1968       --  after having saved the previous one
1969
1970       Previous_Subprogram_Descriptors := Subprogram_Descriptors;
1971       Subprogram_Descriptors := new Subprogram_Descriptor_List (0 .. Ndes);
1972
1973       --  If there was a previous Subprogram_Descriptors table, copy it back
1974       --  into the new one being built. Then free the memory used for the
1975       --  previous table.
1976
1977       for J in 1 .. Num_Subprogram_Descriptors loop
1978          Subprogram_Descriptors (J) := Previous_Subprogram_Descriptors (J);
1979       end loop;
1980
1981       Free (Previous_Subprogram_Descriptors);
1982
1983       --  Next, append the elaboration routine addresses, building dummy
1984       --  SDP's for them as we go through the list.
1985
1986       Ndes := Num_Subprogram_Descriptors;
1987       for J in EA'Range loop
1988          Ndes := Ndes + 1;
1989          Subprogram_Descriptors (Ndes) := new Subprogram_Descriptor_0;
1990
1991          Subprogram_Descriptors (Ndes).all :=
1992            Subprogram_Descriptor'
1993              (Num_Handlers    => 0,
1994               Code            => Fetch_Code (EA (J)),
1995               Subprogram_Info => EA (J),
1996               Handler_Records => (1 .. 0 => null));
1997       end loop;
1998
1999       --  Now copy in pointers to SDP addresses of application subprograms
2000
2001       for J in T'Range loop
2002          for K in 1 .. T (J).Count loop
2003             Ndes := Ndes + 1;
2004             Subprogram_Descriptors (Ndes) := T (J).SDesc (K);
2005             Subprogram_Descriptors (Ndes).Code :=
2006               Fetch_Code (T (J).SDesc (K).Code);
2007          end loop;
2008       end loop;
2009
2010       --  Now we need to sort the table into ascending PC order
2011
2012       Sort (Ndes, SDP_Table_Sort_Move'Access, SDP_Table_Sort_Lt'Access);
2013
2014       --  Now eliminate duplicate entries. Note that in the case where
2015       --  entries have duplicate code addresses, the code for the Lt
2016       --  routine ensures that the interesting one (i.e. the one with
2017       --  handler entries if there are any) comes first.
2018
2019       Num_Subprogram_Descriptors := 1;
2020
2021       for J in 2 .. Ndes loop
2022          if Subprogram_Descriptors (J).Code /=
2023             Subprogram_Descriptors (Num_Subprogram_Descriptors).Code
2024          then
2025             Num_Subprogram_Descriptors := Num_Subprogram_Descriptors + 1;
2026             Subprogram_Descriptors (Num_Subprogram_Descriptors) :=
2027               Subprogram_Descriptors (J);
2028          end if;
2029       end loop;
2030
2031    end SDP_Table_Build;
2032
2033    -----------------------
2034    -- SDP_Table_Sort_Lt --
2035    -----------------------
2036
2037    function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean is
2038       SDC1 : constant Code_Loc := Subprogram_Descriptors (Op1).Code;
2039       SDC2 : constant Code_Loc := Subprogram_Descriptors (Op2).Code;
2040
2041    begin
2042       if SDC1 < SDC2 then
2043          return True;
2044
2045       elsif SDC1 > SDC2 then
2046          return False;
2047
2048       --  For two descriptors for the same procedure, we want the more
2049       --  interesting one first. A descriptor with an exception handler
2050       --  is more interesting than one without. This happens if the less
2051       --  interesting one came from a pragma Import.
2052
2053       else
2054          return Subprogram_Descriptors (Op1).Num_Handlers /= 0
2055            and then Subprogram_Descriptors (Op2).Num_Handlers = 0;
2056       end if;
2057    end SDP_Table_Sort_Lt;
2058
2059    --------------------------
2060    -- SDP_Table_Sort_Move --
2061    --------------------------
2062
2063    procedure SDP_Table_Sort_Move (From : Natural; To : Natural) is
2064    begin
2065       Subprogram_Descriptors (To) := Subprogram_Descriptors (From);
2066    end SDP_Table_Sort_Move;
2067
2068    -------------------------
2069    -- Set_Exception_C_Msg --
2070    -------------------------
2071
2072    procedure Set_Exception_C_Msg
2073      (Id   : Exception_Id;
2074       Msg1 : Big_String_Ptr;
2075       Line : Integer        := 0;
2076       Msg2 : Big_String_Ptr := null)
2077    is
2078       Excep  : constant EOA := Get_Current_Excep.all;
2079       Val    : Integer := Line;
2080       Remind : Integer;
2081       Size   : Integer := 1;
2082       Ptr    : Natural;
2083
2084    begin
2085       Excep.Exception_Raised := False;
2086       Excep.Id               := Id;
2087       Excep.Num_Tracebacks   := 0;
2088       Excep.Pid              := Local_Partition_ID;
2089       Excep.Msg_Length       := 0;
2090       Excep.Cleanup_Flag     := False;
2091
2092       while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL
2093         and then Excep.Msg_Length < Exception_Msg_Max_Length
2094       loop
2095          Excep.Msg_Length := Excep.Msg_Length + 1;
2096          Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length);
2097       end loop;
2098
2099       --  Append line number if present
2100
2101       if Line > 0 then
2102
2103          --  Compute the number of needed characters
2104
2105          while Val > 0 loop
2106             Val := Val / 10;
2107             Size := Size + 1;
2108          end loop;
2109
2110          --  If enough characters are available, put the line number
2111
2112          if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
2113             Excep.Msg (Excep.Msg_Length + 1) := ':';
2114             Excep.Msg_Length := Excep.Msg_Length + Size;
2115             Val := Line;
2116             Size := 0;
2117
2118             while Val > 0 loop
2119                Remind := Val rem 10;
2120                Val := Val / 10;
2121                Excep.Msg (Excep.Msg_Length - Size) :=
2122                  Character'Val (Remind + Character'Pos ('0'));
2123                Size := Size + 1;
2124             end loop;
2125          end if;
2126       end if;
2127
2128       --  Append second message if present
2129
2130       if Msg2 /= null
2131         and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
2132       then
2133          Excep.Msg_Length := Excep.Msg_Length + 1;
2134          Excep.Msg (Excep.Msg_Length) := ' ';
2135
2136          Ptr := 1;
2137          while Msg2 (Ptr) /= ASCII.NUL
2138            and then Excep.Msg_Length < Exception_Msg_Max_Length
2139          loop
2140             Excep.Msg_Length := Excep.Msg_Length + 1;
2141             Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr);
2142             Ptr := Ptr + 1;
2143          end loop;
2144       end if;
2145    end Set_Exception_C_Msg;
2146
2147    -------------------
2148    -- String_To_EId --
2149    -------------------
2150
2151    function String_To_EId (S : String) return Exception_Id is
2152    begin
2153       if S = "" then
2154          return Null_Id;
2155       else
2156          return Exception_Id (Internal_Exception (S));
2157       end if;
2158    end String_To_EId;
2159
2160    ------------------
2161    -- String_To_EO --
2162    ------------------
2163
2164    function String_To_EO (S : String) return Exception_Occurrence is
2165       From : Natural;
2166       To   : Integer;
2167
2168       X : Exception_Occurrence;
2169       --  This is the exception occurrence we will create
2170
2171       procedure Bad_EO;
2172       pragma No_Return (Bad_EO);
2173       --  Signal bad exception occurrence string
2174
2175       procedure Next_String;
2176       --  On entry, To points to last character of previous line of the
2177       --  message, terminated by LF. On return, From .. To are set to
2178       --  specify the next string, or From > To if there are no more lines.
2179
2180       procedure Bad_EO is
2181       begin
2182          Raise_Exception
2183            (Program_Error'Identity,
2184             "bad exception occurrence in stream input");
2185       end Bad_EO;
2186
2187       procedure Next_String is
2188       begin
2189          From := To + 2;
2190
2191          if From < S'Last then
2192             To := From + 1;
2193
2194             while To < S'Last - 1 loop
2195                if To >= S'Last then
2196                   Bad_EO;
2197                elsif S (To + 1) = ASCII.LF then
2198                   exit;
2199                else
2200                   To := To + 1;
2201                end if;
2202             end loop;
2203          end if;
2204       end Next_String;
2205
2206    --  Start of processing for String_To_EO
2207
2208    begin
2209       if S = "" then
2210          return Null_Occurrence;
2211
2212       else
2213          X.Cleanup_Flag := False;
2214
2215          To := S'First - 2;
2216          Next_String;
2217
2218          if S (From .. From + 15) /= "Exception name: " then
2219             Bad_EO;
2220          end if;
2221
2222          X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
2223
2224          Next_String;
2225
2226          if From <= To and then S (From) = 'M' then
2227             if S (From .. From + 8) /= "Message: " then
2228                Bad_EO;
2229             end if;
2230
2231             X.Msg_Length := To - From - 8;
2232             X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
2233             Next_String;
2234
2235          else
2236             X.Msg_Length := 0;
2237          end if;
2238
2239          X.Pid := 0;
2240
2241          if From <= To and then S (From) = 'P' then
2242             if S (From .. From + 3) /= "PID:" then
2243                Bad_EO;
2244             end if;
2245
2246             From := From + 5; -- skip past PID: space
2247
2248             while From <= To loop
2249                X.Pid := X.Pid * 10 +
2250                           (Character'Pos (S (From)) - Character'Pos ('0'));
2251                From := From + 1;
2252             end loop;
2253
2254             Next_String;
2255          end if;
2256
2257          X.Num_Tracebacks := 0;
2258
2259          if From <= To then
2260             if S (From .. To) /= "Call stack traceback locations:" then
2261                Bad_EO;
2262             end if;
2263
2264             Next_String;
2265             loop
2266                exit when From > To;
2267
2268                declare
2269                   Ch : Character;
2270                   C  : Integer_Address;
2271                   N  : Integer_Address;
2272
2273                begin
2274                   if S (From) /= '0'
2275                     or else S (From + 1) /= 'x'
2276                   then
2277                      Bad_EO;
2278                   else
2279                      From := From + 2;
2280                   end if;
2281
2282                   C := 0;
2283                   while From <= To loop
2284                      Ch := S (From);
2285
2286                      if Ch in '0' .. '9' then
2287                         N :=
2288                           Character'Pos (S (From)) - Character'Pos ('0');
2289
2290                      elsif Ch in 'a' .. 'f' then
2291                         N :=
2292                           Character'Pos (S (From)) - Character'Pos ('a') + 10;
2293
2294                      elsif Ch = ' ' then
2295                         From := From + 1;
2296                         exit;
2297
2298                      else
2299                         Bad_EO;
2300                      end if;
2301
2302                      C := C * 16 + N;
2303
2304                      From := From + 1;
2305                   end loop;
2306
2307                   if X.Num_Tracebacks = Max_Tracebacks then
2308                      Bad_EO;
2309                   end if;
2310
2311                   X.Num_Tracebacks := X.Num_Tracebacks + 1;
2312                   X.Tracebacks (X.Num_Tracebacks) := To_Address (C);
2313                end;
2314             end loop;
2315          end if;
2316
2317          --  If an exception was converted to a string, it must have
2318          --  already been raised, so flag it accordingly and we are done.
2319
2320          X.Exception_Raised := True;
2321          return X;
2322       end if;
2323    end String_To_EO;
2324
2325    ----------------------------------
2326    -- Tailored_Exception_Traceback --
2327    ----------------------------------
2328
2329    function Tailored_Exception_Traceback
2330      (X    : Exception_Occurrence)
2331       return String
2332    is
2333       --  We indeed reference the decorator *wrapper* from here and not the
2334       --  decorator itself. The purpose of the local variable Wrapper is to
2335       --  prevent a potential crash by race condition in the code below. The
2336       --  atomicity of this assignment is enforced by pragma Atomic in
2337       --  System.Soft_Links.
2338
2339       --  The potential race condition here, if no local variable was used,
2340       --  relates to the test upon the wrapper's value and the call, which
2341       --  are not performed atomically. With the local variable, potential
2342       --  changes of the wrapper's global value between the test and the
2343       --  call become inoffensive.
2344
2345       Wrapper : constant Traceback_Decorator_Wrapper_Call :=
2346                   Traceback_Decorator_Wrapper;
2347
2348    begin
2349       if Wrapper = null then
2350          return Basic_Exception_Traceback (X);
2351       else
2352          return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
2353       end if;
2354    end Tailored_Exception_Traceback;
2355
2356    ------------------------------------
2357    -- Tailored_Exception_Information --
2358    ------------------------------------
2359
2360    function Tailored_Exception_Information
2361      (X    : Exception_Occurrence)
2362       return String
2363    is
2364       --  The tailored exception information is simply the basic information
2365       --  associated with the tailored call chain backtrace.
2366
2367       Basic_Info : constant String  := Basic_Exception_Information (X);
2368       Tback_Info : constant String  := Tailored_Exception_Traceback (X);
2369
2370       Basic_Len  : constant Natural := Basic_Info'Length;
2371       Tback_Len  : constant Natural := Tback_Info'Length;
2372
2373       Info : String (1 .. Basic_Len + Tback_Len);
2374       Ptr  : Natural := 0;
2375
2376    begin
2377       Append_Info_String (Basic_Info, Info, Ptr);
2378       Append_Info_String (Tback_Info, Info, Ptr);
2379
2380       return Info;
2381    end Tailored_Exception_Information;
2382
2383    -------------------------
2384    -- Unhandled_Exception --
2385    -------------------------
2386
2387    procedure Unhandled_Exception is
2388    begin
2389       null;
2390    end Unhandled_Exception;
2391
2392    ----------------------
2393    -- Notify_Exception --
2394    ----------------------
2395
2396    procedure Notify_Exception
2397      (Id        : Exception_Id;
2398       Handler   : Code_Loc;
2399       Is_Others : Boolean)
2400    is
2401    begin
2402       null;
2403    end Notify_Exception;
2404
2405    ------------------------------
2406    -- Notify_Handled_Exception --
2407    ------------------------------
2408
2409    procedure Notify_Handled_Exception
2410      (Handler    : Code_Loc;
2411       Is_Others  : Boolean;
2412       Low_Notify : Boolean)
2413    is
2414       Excep  : constant EOA := Get_Current_Excep.all;
2415
2416    begin
2417       --  Notify the debugger that we have found a handler and are about to
2418       --  propagate an exception, but only if specifically told to do so.
2419
2420       if Low_Notify then
2421          Notify_Exception (Excep.Id, Handler, Is_Others);
2422       end if;
2423
2424       --  Output some exception information if necessary, as specified by
2425       --  GNAT.Exception_Traces. Take care not to output information about
2426       --  internal exceptions.
2427       --
2428       --  ??? In the ZCX case, the traceback entries we have at this point
2429       --  only include the ones we stored while walking up the stack *up to
2430       --  the handler*. All the frames above the subprogram in which the
2431       --  handler is found are missing.
2432
2433       if Exception_Trace = Every_Raise
2434         and then not Excep.Id.Not_Handled_By_Others
2435       then
2436          To_Stderr (Nline);
2437          To_Stderr ("Exception raised");
2438          To_Stderr (Nline);
2439          To_Stderr (Tailored_Exception_Information (Excep.all));
2440       end if;
2441
2442    end Notify_Handled_Exception;
2443
2444    ------------------------------
2445    -- Notify_Handled_Exception --
2446    ------------------------------
2447
2448    procedure Notify_Unhandled_Exception (Id : Exception_Id) is
2449    begin
2450       --  Simply perform the two necessary low level notification calls.
2451
2452       Unhandled_Exception;
2453       Notify_Exception (Id, Null_Loc, False);
2454
2455    end Notify_Unhandled_Exception;
2456
2457    -----------------------------------
2458    -- Unhandled_Exception_Terminate --
2459    -----------------------------------
2460
2461    adafinal_Called : Boolean := False;
2462    --  Used to prevent recursive call to adafinal in the event that
2463    --  adafinal processing itself raises an unhandled exception.
2464
2465    type FILEs is new System.Address;
2466    type int is new Integer;
2467
2468    procedure Unhandled_Exception_Terminate is
2469
2470       Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all);
2471       --  This occurrence will be used to display a message after finalization.
2472       --  It is necessary to save a copy here, or else the designated value
2473       --  could be overwritten if an exception is raised during finalization
2474       --  (even if that exception is caught).
2475
2476       Msg : constant String := Exception_Message (Excep.all);
2477
2478    --  Start of processing for Unhandled_Exception_Terminate
2479
2480    begin
2481       --  First call adafinal
2482
2483       if not adafinal_Called then
2484          adafinal_Called := True;
2485          System.Soft_Links.Adafinal.all;
2486       end if;
2487
2488       --  Check for special case of raising _ABORT_SIGNAL, which is not
2489       --  really an exception at all. We recognize this by the fact that
2490       --  it is the only exception whose name starts with underscore.
2491
2492       if Exception_Name (Excep.all) (1) = '_' then
2493          To_Stderr (Nline);
2494          To_Stderr ("Execution terminated by abort of environment task");
2495          To_Stderr (Nline);
2496
2497       --  If no tracebacks, we print the unhandled exception in the old style
2498       --  (i.e. the style used before ZCX was implemented). We do this to
2499       --  retain compatibility, especially with the nightly scripts, but
2500       --  this can be removed at some point ???
2501
2502       elsif Excep.Num_Tracebacks = 0 then
2503          To_Stderr (Nline);
2504          To_Stderr ("raised ");
2505          To_Stderr (Exception_Name (Excep.all));
2506
2507          if Msg'Length /= 0 then
2508             To_Stderr (" : ");
2509             To_Stderr (Msg);
2510          end if;
2511
2512          To_Stderr (Nline);
2513
2514       --  New style, zero cost exception case
2515
2516       else
2517          --  Tailored_Exception_Information is also called here so that the
2518          --  backtrace decorator gets called if it has been set. This is
2519          --  currently required because some paths in Raise_Current_Excep
2520          --  do not go through the calls that display this information.
2521          --
2522          --  Note also that with the current scheme in Raise_Current_Excep
2523          --  we can have this whole information output twice, typically when
2524          --  some handler is found on the call chain but none deals with the
2525          --  occurrence or if this occurrence gets reraised up to here.
2526
2527          To_Stderr (Nline);
2528          To_Stderr ("Execution terminated by unhandled exception");
2529          To_Stderr (Nline);
2530          To_Stderr (Tailored_Exception_Information (Excep.all));
2531       end if;
2532
2533       --  Perform system dependent shutdown code
2534
2535       declare
2536          procedure Unhandled_Terminate;
2537          pragma No_Return (Unhandled_Terminate);
2538          pragma Import
2539            (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
2540
2541       begin
2542          Unhandled_Terminate;
2543       end;
2544
2545    end Unhandled_Exception_Terminate;
2546
2547    ------------------------------
2548    -- Raise_Exception_No_Defer --
2549    ------------------------------
2550
2551    procedure Raise_Exception_No_Defer
2552      (E       : Exception_Id;
2553       Message : String := "")
2554    is
2555       Len : constant Natural :=
2556               Natural'Min (Message'Length, Exception_Msg_Max_Length);
2557
2558       Excep : constant EOA := Get_Current_Excep.all;
2559
2560    begin
2561       Excep.Exception_Raised := False;
2562       Excep.Msg_Length       := Len;
2563       Excep.Msg (1 .. Len)   := Message (1 .. Len);
2564       Excep.Id               := E;
2565       Excep.Num_Tracebacks   := 0;
2566       Excep.Cleanup_Flag     := False;
2567       Excep.Pid              := Local_Partition_ID;
2568
2569       --  DO NOT CALL Abort_Defer.all; !!!!
2570
2571       Raise_Current_Excep (E);
2572    end Raise_Exception_No_Defer;
2573
2574    ---------------
2575    -- To_Stderr --
2576    ---------------
2577
2578    procedure To_Stderr (S : String) is
2579       procedure put_char_stderr (C : int);
2580       pragma Import (C, put_char_stderr, "put_char_stderr");
2581
2582    begin
2583       for J in 1 .. S'Length loop
2584          if S (J) /= ASCII.CR then
2585             put_char_stderr (Character'Pos (S (J)));
2586          end if;
2587       end loop;
2588    end To_Stderr;
2589
2590    ---------
2591    -- ZZZ --
2592    ---------
2593
2594    --  This dummy procedure gives us the end of the PC range for addresses
2595    --  within the exception unit itself. We hope that gigi/gcc keeps all the
2596    --  procedures in their original order!
2597
2598    procedure ZZZ is
2599    begin
2600       null;
2601    end ZZZ;
2602
2603 begin
2604    --  Allocate the Non-Tasking Machine_State
2605
2606    Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State));
2607 end Ada.Exceptions;