------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A D A . E X C E P T I O N S -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with System.Exception_Tables. with Ada.Unchecked_Deallocation; with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; with System; use System; with System.Exception_Table; use System.Exception_Table; with System.Exceptions; use System.Exceptions; with System.Standard_Library; use System.Standard_Library; with System.Storage_Elements; use System.Storage_Elements; with System.Soft_Links; use System.Soft_Links; with System.Machine_State_Operations; use System.Machine_State_Operations; with System.Traceback; with Unchecked_Conversion; package body Ada.Exceptions is procedure builtin_longjmp (buffer : Address; Flag : Integer); pragma No_Return (builtin_longjmp); pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp"); pragma Suppress (All_Checks); -- We definitely do not want exceptions occurring within this unit, or -- we are in big trouble. If an exceptional situation does occur, better -- that it not be raised, since raising it can cause confusing chaos. type Subprogram_Descriptor_List_Ptr is access all Subprogram_Descriptor_List; Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr; -- This location is initialized by Register_Exceptions to point to a -- list of pointers to procedure descriptors, sorted into ascending -- order of PC addresses. -- -- Note that SDP_Table_Build is called *before* this unit (or any -- other unit) is elaborated. That's important, because exceptions can -- and do occur during elaboration of units, and must be handled during -- elaboration. This means that we are counting on the fact that the -- initialization of Subprogram_Descriptors to null is done by the -- load process and NOT by an explicit assignment during elaboration. Num_Subprogram_Descriptors : Natural; -- Number of subprogram descriptors, the useful descriptors are stored -- in Subprogram_Descriptors (1 .. Num_Subprogram_Descriptors). There -- can be unused entries at the end of the array due to elimination of -- duplicated entries (which can arise from use of pragma Import). Exception_Tracebacks : Integer; pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks"); -- Boolean indicating whether tracebacks should be stored in exception -- occurrences. Zero_Cost_Exceptions : Integer; pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions"); -- Boolean indicating if we are handling exceptions using a zero cost -- mechanism. -- -- ??? We currently have two alternatives for this scheme : one using -- front-end tables and one using back-end tables. The former is known to -- only work for GNAT3 and the latter is known to only work for GNAT5. -- Both are present in this implementation and it would be good to have -- separate bodies at some point. -- -- Note that although we currently do not support it, the GCC3 back-end -- tables are also potentially useable for setjmp/longjmp processing. Nline : constant String := String' (1 => ASCII.LF); -- Convenient shortcut ------------------------------------------------ -- Entities to interface with the GCC runtime -- ------------------------------------------------ -- These come from "C++ ABI for Itanium : Exception handling", which is -- the reference for GCC. They are used only when we are relying on -- back-end tables for exception propagation, which in turn is currenly -- only the case for Zero_Cost_Exceptions in GNAT5. -- Return codes from the GCC runtime functions used to propagate -- an exception. type Unwind_Reason_Code is (URC_NO_REASON, URC_FOREIGN_EXCEPTION_CAUGHT, URC_PHASE2_ERROR, URC_PHASE1_ERROR, URC_NORMAL_STOP, URC_END_OF_STACK, URC_HANDLER_FOUND, URC_INSTALL_CONTEXT, URC_CONTINUE_UNWIND); -- ??? pragma Unreferenced is unknown until 3.15, so we need to disable -- warnings around it to fix the bootstrap path. pragma Warnings (Off); pragma Unreferenced (URC_NO_REASON, URC_FOREIGN_EXCEPTION_CAUGHT, URC_PHASE2_ERROR, URC_PHASE1_ERROR, URC_NORMAL_STOP, URC_END_OF_STACK, URC_HANDLER_FOUND, URC_INSTALL_CONTEXT, URC_CONTINUE_UNWIND); pragma Warnings (On); pragma Convention (C, Unwind_Reason_Code); -- Mandatory common header for any exception object handled by the -- GCC unwinding runtime. subtype Exception_Class is String (1 .. 8); GNAT_Exception_Class : constant Exception_Class := "GNU" & ASCII.NUL & "Ada" & ASCII.NUL; type Unwind_Exception is record Class : Exception_Class := GNAT_Exception_Class; Cleanup : System.Address := System.Null_Address; Private1 : Integer; Private2 : Integer; end record; pragma Convention (C, Unwind_Exception); for Unwind_Exception'Alignment use Standard'Maximum_Alignment; -- A GNAT exception object to be dealt with by the personality routine -- called by the GCC unwinding runtime. This structure shall match the -- one in raise.c and is currently experimental as it might be merged -- with the GNAT runtime definition some day. type GNAT_GCC_Exception is record Header : Unwind_Exception; -- Exception header first, as required by the ABI. Id : Exception_Id; -- Usual Exception identifier Handled_By_Others : Boolean; -- Is this exception handled by "when others" ? Has_Cleanup : Boolean; -- Did we see any at-end handler while walking up the stack -- searching for a handler ? This is used to determine if we -- start the propagation again after having tried once without -- finding a true handler for the exception. Select_Cleanups : Boolean; -- Do we consider at-end handlers as legitimate handlers for the -- exception ? This is used to control the propagation process -- as described in Raise_Current_Excep. end record; pragma Convention (C, GNAT_GCC_Exception); -- GCC runtime functions used function Unwind_RaiseException (E : access GNAT_GCC_Exception) return Unwind_Reason_Code; pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); ----------------------- -- Local Subprograms -- ----------------------- -- Note: the exported subprograms in this package body are called directly -- from C clients using the given external name, even though they are not -- technically visible in the Ada sense. procedure AAA; -- Mark start of procedures in this unit procedure ZZZ; -- Mark end of procedures in this package function Address_Image (A : System.Address) return String; -- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses -- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are -- in lower case. procedure Call_Chain (Excep : EOA); -- Store up to Max_Tracebacks in Excep, corresponding to the current -- call chain. procedure Free is new Ada.Unchecked_Deallocation (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr); procedure Process_Raise_Exception (E : Exception_Id; From_Signal_Handler : Boolean); pragma Inline (Process_Raise_Exception); pragma No_Return (Process_Raise_Exception); -- This is the lowest level raise routine. It raises the exception -- referenced by Current_Excep.all in the TSD, without deferring abort -- (the caller must ensure that abort is deferred on entry). -- -- This is actually the common implementation for Raise_Current_Excep and -- Raise_From_Signal_Handler, with a couple of operations inhibited when -- called from the latter. The origin of the call is indicated by the -- From_Signal_Handler argument. -- -- The Inline pragma is there for efficiency reasons. procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State); pragma No_Return (Propagate_Exception_With_FE_Support); -- This procedure propagates the exception represented by the occurrence -- referenced by Current_Excep in the TSD for the current task. M is the -- initial machine state, representing the site of the exception raise -- operation. -- -- The procedure searches the front end exception tables for an applicable -- handler, calling Pop_Frame as needed. If and when it locates an -- applicable handler, Enter_Handler is called to actually enter this -- handler. If the search is unable to locate an applicable handler, -- execution is terminated by calling Unhandled_Exception_Terminate. procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State); pragma No_Return (Propagate_Exception_With_GCC_Support); -- This procedure propagates the exception represented by the occurrence -- referenced by Current_Excep in the TSD for the current task. M is the -- initial machine state, representing the site of the exception raise -- operation. It is currently not used and is there for the purpose of -- interface consistency against Propagate_Exception_With_FE_Support. -- -- The procedure builds an object suitable for the libgcc processing and -- calls Unwind_RaiseException to actually throw, taking care of handling -- the two phase scheme it implements. procedure Raise_Current_Excep (E : Exception_Id); pragma No_Return (Raise_Current_Excep); pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); -- This is a simple wrapper to Process_Raise_Exception setting the -- From_Signal_Handler argument to False. -- -- This external name for Raise_Current_Excep is historical, and probably -- should be changed but for now we keep it, because gdb and gigi know -- about it. procedure Raise_Exception_No_Defer (E : Exception_Id; Message : String := ""); pragma Export (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_exception_no_defer"); pragma No_Return (Raise_Exception_No_Defer); -- Similar to Raise_Exception, but with no abort deferral procedure Raise_With_Msg (E : Exception_Id); pragma No_Return (Raise_With_Msg); pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg"); -- Raises an exception with given exception id value. A message -- is associated with the raise, and has already been stored in the -- exception occurrence referenced by the Current_Excep in the TSD. -- Abort is deferred before the raise call. procedure Raise_With_Location (E : Exception_Id; F : Big_String_Ptr; L : Integer); pragma No_Return (Raise_With_Location); -- Raise an exception with given exception id value. A filename and line -- number is associated with the raise and is stored in the exception -- occurrence. procedure Raise_With_Location_And_Msg (E : Exception_Id; F : Big_String_Ptr; L : Integer; M : Big_String_Ptr); pragma No_Return (Raise_With_Location_And_Msg); -- Raise an exception with given exception id value. A filename and line -- number is associated with the raise and is stored in the exception -- occurrence and in addition a string message M is appended to this. procedure Raise_Constraint_Error (File : Big_String_Ptr; Line : Integer); pragma No_Return (Raise_Constraint_Error); pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); -- Raise constraint error with file:line information procedure Raise_Constraint_Error_Msg (File : Big_String_Ptr; Line : Integer; Msg : Big_String_Ptr); pragma No_Return (Raise_Constraint_Error_Msg); pragma Export (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); -- Raise constraint error with file:line + msg information procedure Raise_Program_Error (File : Big_String_Ptr; Line : Integer); pragma No_Return (Raise_Program_Error); pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error"); -- Raise program error with file:line information procedure Raise_Program_Error_Msg (File : Big_String_Ptr; Line : Integer; Msg : Big_String_Ptr); pragma No_Return (Raise_Program_Error_Msg); pragma Export (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); -- Raise program error with file:line + msg information procedure Raise_Storage_Error (File : Big_String_Ptr; Line : Integer); pragma No_Return (Raise_Storage_Error); pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error"); -- Raise storage error with file:line information procedure Raise_Storage_Error_Msg (File : Big_String_Ptr; Line : Integer; Msg : Big_String_Ptr); pragma No_Return (Raise_Storage_Error_Msg); pragma Export (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); -- Raise storage error with file:line + reason msg information -- The exception raising process and the automatic tracing mechanism rely -- on some careful use of flags attached to the exception occurrence. The -- graph below illustrates the relations between the Raise_ subprograms -- and identifies the points where basic flags such as Exception_Raised -- are initialized. -- -- (i) signs indicate the flags initialization points. R stands for Raise, -- W for With, and E for Exception. -- -- R_No_Msg R_E R_Pe R_Ce R_Se -- | | | | | -- +--+ +--+ +---+ | +---+ -- | | | | | -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc R_W_C_Msg -- | | | | | | -- +------------+ | +-----------+ +--+ +--+ | -- | | | | | | -- | | | Set_E_C_Msg(i) | -- | | | | -- | | | +--------------------------+ -- | | | | -- Raise_Current_Excep procedure Reraise; pragma No_Return (Reraise); pragma Export (C, Reraise, "__gnat_reraise"); -- Reraises the exception referenced by the Current_Excep field of -- the TSD (all fields of this exception occurrence are set). Abort -- is deferred before the reraise operation. function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean; -- Used in call to sort SDP table (SDP_Table_Build), compares two elements procedure SDP_Table_Sort_Move (From : Natural; To : Natural); -- Used in call to sort SDP table (SDP_Table_Build), moves one element procedure Set_Exception_C_Msg (Id : Exception_Id; Msg1 : Big_String_Ptr; Line : Integer := 0; Msg2 : Big_String_Ptr := null); -- This routine is called to setup the exception referenced by the -- Current_Excep field in the TSD to contain the indicated Id value -- and message. Msg1 is a null terminated string which is generated -- as the exception message. If line is non-zero, then a colon and -- the decimal representation of this integer is appended to the -- message. When Msg2 is non-null, a space and this additional null -- terminated string is added to the message. procedure To_Stderr (S : String); pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); -- Little routine to output string to stderr that is also used -- in the tasking run time. procedure Unhandled_Exception_Terminate; pragma No_Return (Unhandled_Exception_Terminate); -- This procedure is called to terminate execution following an unhandled -- exception. The exception information, including traceback if available -- is output, and execution is then terminated. Note that at the point -- where this routine is called, the stack has typically been destroyed --------------------------------- -- Debugger Interface Routines -- --------------------------------- -- The routines here are null routines that normally have no effect. -- they are provided for the debugger to place breakpoints on their -- entry points to get control on an exception. procedure Notify_Exception (Id : Exception_Id; Handler : Code_Loc; Is_Others : Boolean); pragma Export (C, Notify_Exception, "__gnat_notify_exception"); -- This routine is called whenever an exception is signalled. The Id -- parameter is the Exception_Id of the exception being raised. The -- second parameter Handler is Null_Loc if the exception is unhandled, -- and is otherwise the entry point of the handler that will handle -- the exception. Is_Others is True if the handler is an others handler -- and False otherwise. In the unhandled exception case, if possible -- (and certainly if zero cost exception handling is active), the -- stack is still intact when this procedure is called. Note that this -- routine is entered before any finalization handlers are entered if -- the exception is unhandled by a "real" exception handler. procedure Unhandled_Exception; pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception"); -- This routine is called in addition to Notify_Exception in the -- unhandled exception case. The fact that there are two routines -- which are somewhat redundant is historical. Notify_Exception -- certainly is complete enough, but GDB still uses this routine. ----------------------------- -- Run-Time Check Routines -- ----------------------------- -- These routines are called from the runtime to raise a specific -- exception with a reason message attached. The parameters are -- the file name and line number in each case. The names are keyed -- to the codes defined in Types.ads and a-types.h (for example, -- the name Rcheck_05 refers to the Reason whose Pos code is 5). procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer); procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer); pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); pragma Export (C, Rcheck_02, "__gnat_rcheck_02"); pragma Export (C, Rcheck_03, "__gnat_rcheck_03"); pragma Export (C, Rcheck_04, "__gnat_rcheck_04"); pragma Export (C, Rcheck_05, "__gnat_rcheck_05"); pragma Export (C, Rcheck_06, "__gnat_rcheck_06"); pragma Export (C, Rcheck_07, "__gnat_rcheck_07"); pragma Export (C, Rcheck_08, "__gnat_rcheck_08"); pragma Export (C, Rcheck_09, "__gnat_rcheck_09"); pragma Export (C, Rcheck_10, "__gnat_rcheck_10"); pragma Export (C, Rcheck_11, "__gnat_rcheck_11"); pragma Export (C, Rcheck_12, "__gnat_rcheck_12"); pragma Export (C, Rcheck_13, "__gnat_rcheck_13"); pragma Export (C, Rcheck_14, "__gnat_rcheck_14"); pragma Export (C, Rcheck_15, "__gnat_rcheck_15"); pragma Export (C, Rcheck_16, "__gnat_rcheck_16"); pragma Export (C, Rcheck_17, "__gnat_rcheck_17"); pragma Export (C, Rcheck_18, "__gnat_rcheck_18"); pragma Export (C, Rcheck_19, "__gnat_rcheck_19"); pragma Export (C, Rcheck_20, "__gnat_rcheck_20"); pragma Export (C, Rcheck_21, "__gnat_rcheck_21"); pragma Export (C, Rcheck_22, "__gnat_rcheck_22"); pragma Export (C, Rcheck_23, "__gnat_rcheck_23"); pragma Export (C, Rcheck_24, "__gnat_rcheck_24"); pragma Export (C, Rcheck_25, "__gnat_rcheck_25"); pragma Export (C, Rcheck_26, "__gnat_rcheck_26"); pragma Export (C, Rcheck_27, "__gnat_rcheck_27"); pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); --------------------------------------------- -- Reason Strings for Run-Time Check Calls -- --------------------------------------------- -- These strings are null-terminated and are used by Rcheck_nn. The -- strings correspond to the definitions for Types.RT_Exception_Code. use ASCII; Rmsg_00 : constant String := "access check failed" & NUL; Rmsg_01 : constant String := "access parameter is null" & NUL; Rmsg_02 : constant String := "discriminant check failed" & NUL; Rmsg_03 : constant String := "divide by zero" & NUL; Rmsg_04 : constant String := "explicit raise" & NUL; Rmsg_05 : constant String := "index check failed" & NUL; Rmsg_06 : constant String := "invalid data" & NUL; Rmsg_07 : constant String := "length check failed" & NUL; Rmsg_08 : constant String := "overflow check failed" & NUL; Rmsg_09 : constant String := "partition check failed" & NUL; Rmsg_10 : constant String := "range check failed" & NUL; Rmsg_11 : constant String := "tag check failed" & NUL; Rmsg_12 : constant String := "access before elaboration" & NUL; Rmsg_13 : constant String := "accessibility check failed" & NUL; Rmsg_14 : constant String := "all guards closed" & NUL; Rmsg_15 : constant String := "duplicated entry address" & NUL; Rmsg_16 : constant String := "explicit raise" & NUL; Rmsg_17 : constant String := "finalize raised exception" & NUL; Rmsg_18 : constant String := "invalid data" & NUL; Rmsg_19 : constant String := "misaligned address value" & NUL; Rmsg_20 : constant String := "missing return" & NUL; Rmsg_21 : constant String := "potentially blocking operation" & NUL; Rmsg_22 : constant String := "stubbed subprogram called" & NUL; Rmsg_23 : constant String := "unchecked union restriction" & NUL; Rmsg_24 : constant String := "empty storage pool" & NUL; Rmsg_25 : constant String := "explicit raise" & NUL; Rmsg_26 : constant String := "infinite recursion" & NUL; Rmsg_27 : constant String := "object too large" & NUL; Rmsg_28 : constant String := "restriction violation" & NUL; -------------------------------------- -- Calls to Run-Time Check Routines -- -------------------------------------- procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address)); end Rcheck_00; procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address)); end Rcheck_01; procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address)); end Rcheck_02; procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address)); end Rcheck_03; procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address)); end Rcheck_04; procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address)); end Rcheck_05; procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address)); end Rcheck_06; procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address)); end Rcheck_07; procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address)); end Rcheck_08; procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address)); end Rcheck_09; procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address)); end Rcheck_10; procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is begin Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address)); end Rcheck_11; procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address)); end Rcheck_12; procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address)); end Rcheck_13; procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address)); end Rcheck_14; procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address)); end Rcheck_15; procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address)); end Rcheck_16; procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address)); end Rcheck_17; procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address)); end Rcheck_18; procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address)); end Rcheck_19; procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address)); end Rcheck_20; procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address)); end Rcheck_21; procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is begin Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address)); end Rcheck_22; procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is begin Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address)); end Rcheck_23; procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is begin Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address)); end Rcheck_24; procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is begin Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); end Rcheck_25; procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is begin Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address)); end Rcheck_26; procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is begin Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address)); end Rcheck_27; procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is begin Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address)); end Rcheck_28; --------------------------------------- -- Exception backtracing subprograms -- --------------------------------------- -- What is automatically output when exception tracing is on basically -- corresponds to the usual exception information, but with the call -- chain backtrace possibly tailored by a backtrace decorator. Modifying -- Exception_Information itself is not a good idea because the decorated -- output is completely out of control and would break all our code -- related to the streaming of exceptions. -- -- We then provide an alternative function to Exception_Information to -- compute the possibly tailored output, which is equivalent if no -- decorator is currently set : function Tailored_Exception_Information (X : Exception_Occurrence) return String; -- Exception information to be output in the case of automatic tracing -- requested through GNAT.Exception_Traces. -- -- This is the same as Exception_Information if no backtrace decorator -- is currently in place. Otherwise, this is Exception_Information with -- the call chain raw addresses replaced by the result of a call to the -- current decorator provided with the call chain addresses. pragma Export (Ada, Tailored_Exception_Information, "__gnat_tailored_exception_information"); -- This function is used within this package but also from within -- System.Tasking.Stages. -- -- The output of Exception_Information and Tailored_Exception_Information -- share a common part which was formerly built using local procedures -- within Exception_Information. These procedures have been extracted from -- their original place to be available to Tailored_Exception_Information -- also. -- -- Each of these procedures appends some input to an information string -- currently being built. The Ptr argument represents the last position -- in this string at which a character has been written. procedure Append_Info_Nat (N : Natural; Info : in out String; Ptr : in out Natural); -- Append the image of N at the end of the provided information string procedure Append_Info_NL (Info : in out String; Ptr : in out Natural); -- Append a LF at the end of the provided information string procedure Append_Info_String (S : String; Info : in out String; Ptr : in out Natural); -- Append a string at the end of the provided information string -- To build Exception_Information and Tailored_Exception_Information, -- we then use three intermediate functions : function Basic_Exception_Information (X : Exception_Occurrence) return String; -- Returns the basic exception information string associated with a -- given exception occurrence. This is the common part shared by both -- Exception_Information and Tailored_Exception_Infomation. function Basic_Exception_Traceback (X : Exception_Occurrence) return String; -- Returns an image of the complete call chain associated with an -- exception occurrence in its most basic form, that is as a raw sequence -- of hexadecimal binary addresses. function Tailored_Exception_Traceback (X : Exception_Occurrence) return String; -- Returns an image of the complete call chain associated with an -- exception occurrence, either in its basic form if no decorator is -- in place, or as formatted by the decorator otherwise. -- The overall organization of the exception information related code -- is summarized below : -- -- Exception_Information -- | -- +-------+--------+ -- | | -- Basic_Exc_Info & Basic_Exc_Tback -- -- -- Tailored_Exception_Information -- | -- +----------+----------+ -- | | -- Basic_Exc_Info & Tailored_Exc_Tback -- | -- +-----------+------------+ -- | | -- Basic_Exc_Tback Or Tback_Decorator -- if no decorator set otherwise ---------------------------------------------- -- Run-Time Exception Notification Routines -- ---------------------------------------------- -- The notification routines described above are low level "handles" for -- the debugger but what needs to be done at the notification points -- always involves more than just calling one of these routines. The -- routines below provide a common run-time interface for this purpose, -- with variations depending on the handled/not handled status of the -- occurrence. They are exported to be usable by the Ada exception -- handling personality routine when the GCC 3 mechanism is used. procedure Notify_Handled_Exception (Handler : Code_Loc; Is_Others : Boolean; Low_Notify : Boolean); pragma Export (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); -- Routine to call when a handled occurrence is about to be propagated. -- Low_Notify might be set to false to skip the low level debugger -- notification, which is useful when the information it requires is -- not available, like in the SJLJ case. procedure Notify_Unhandled_Exception (Id : Exception_Id); pragma Export (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); -- Routine to call when an unhandled occurrence is about to be propagated. -------------------------------- -- Import Run-Time C Routines -- -------------------------------- -- The purpose of the following pragma Imports is to ensure that we -- generate appropriate subprogram descriptors for all C routines in -- the standard GNAT library that can raise exceptions. This ensures -- that the exception propagation can properly find these routines pragma Warnings (Off); -- so old compiler does not complain pragma Propagate_Exceptions; procedure Unhandled_Terminate; pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); ----------------------- -- Polling Interface -- ----------------------- type Unsigned is mod 2 ** 32; Counter : Unsigned := 0; -- This counter is provided for convenience. It can be used in Poll to -- perform periodic but not systematic operations. procedure Poll is separate; -- The actual polling routine is separate, so that it can easily -- be replaced with a target dependent version. --------- -- AAA -- --------- -- This dummy procedure gives us the start of the PC range for addresses -- within the exception unit itself. We hope that gigi/gcc keep all the -- procedures in their original order! procedure AAA is begin null; end AAA; ------------------- -- Address_Image -- ------------------- function Address_Image (A : Address) return String is S : String (1 .. 18); P : Natural; N : Integer_Address; H : constant array (Integer range 0 .. 15) of Character := "0123456789abcdef"; begin P := S'Last; N := To_Integer (A); while N /= 0 loop S (P) := H (Integer (N mod 16)); P := P - 1; N := N / 16; end loop; S (P - 1) := '0'; S (P) := 'x'; return S (P - 1 .. S'Last); end Address_Image; --------------------- -- Append_Info_Nat -- --------------------- procedure Append_Info_Nat (N : Natural; Info : in out String; Ptr : in out Natural) is begin if N > 9 then Append_Info_Nat (N / 10, Info, Ptr); end if; Ptr := Ptr + 1; Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10); end Append_Info_Nat; -------------------- -- Append_Info_NL -- -------------------- procedure Append_Info_NL (Info : in out String; Ptr : in out Natural) is begin Ptr := Ptr + 1; Info (Ptr) := ASCII.LF; end Append_Info_NL; ------------------------ -- Append_Info_String -- ------------------------ procedure Append_Info_String (S : String; Info : in out String; Ptr : in out Natural) is begin Info (Ptr + 1 .. Ptr + S'Length) := S; Ptr := Ptr + S'Length; end Append_Info_String; --------------------------------- -- Basic_Exception_Information -- --------------------------------- function Basic_Exception_Information (X : Exception_Occurrence) return String is Name : constant String := Exception_Name (X); Msg : constant String := Exception_Message (X); -- Exception name and message that are going to be included in the -- information to return, if not empty. Name_Len : constant Natural := Name'Length; Msg_Len : constant Natural := Msg'Length; -- Length of these strings, useful to compute the size of the string -- we have to allocate for the complete result as well as in the body -- of this procedure. Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len; -- Maximum length of the information string we will build, with : -- -- 50 = 16 + 2 for the text associated with the name -- + 9 + 2 for the text associated with the message -- + 5 + 2 for the text associated with the pid -- + 14 for the text image of the pid itself and a margin. -- -- This is indeed a maximum since some data may not appear at all if -- not relevant. For example, nothing related to the exception message -- will be there if this message is empty. -- -- WARNING : Do not forget to update these numbers if anything -- involved in the computation changes. Info : String (1 .. Info_Maxlen); -- Information string we are going to build, containing the common -- part shared by Exc_Info and Tailored_Exc_Info. Ptr : Natural := 0; begin -- Output exception name and message except for _ABORT_SIGNAL, where -- these two lines are omitted (see discussion above). if Name (1) /= '_' then Append_Info_String ("Exception name: ", Info, Ptr); Append_Info_String (Name, Info, Ptr); Append_Info_NL (Info, Ptr); if Msg_Len /= 0 then Append_Info_String ("Message: ", Info, Ptr); Append_Info_String (Msg, Info, Ptr); Append_Info_NL (Info, Ptr); end if; end if; -- Output PID line if non-zero if X.Pid /= 0 then Append_Info_String ("PID: ", Info, Ptr); Append_Info_Nat (X.Pid, Info, Ptr); Append_Info_NL (Info, Ptr); end if; return Info (1 .. Ptr); end Basic_Exception_Information; ------------------------------- -- Basic_Exception_Traceback -- ------------------------------- function Basic_Exception_Traceback (X : Exception_Occurrence) return String is Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19; -- Maximum length of the information string we are building, with : -- 33 = 31 + 4 for the text before and after the traceback, and -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ") -- -- WARNING : Do not forget to update these numbers if anything -- involved in the computation changes. Info : String (1 .. Info_Maxlen); -- Information string we are going to build, containing an image -- of the call chain associated with the exception occurrence in its -- most basic form, that is as a sequence of binary addresses. Ptr : Natural := 0; begin if X.Num_Tracebacks > 0 then Append_Info_String ("Call stack traceback locations:", Info, Ptr); Append_Info_NL (Info, Ptr); for J in 1 .. X.Num_Tracebacks loop Append_Info_String (Address_Image (X.Tracebacks (J)), Info, Ptr); exit when J = X.Num_Tracebacks; Append_Info_String (" ", Info, Ptr); end loop; Append_Info_NL (Info, Ptr); end if; return Info (1 .. Ptr); end Basic_Exception_Traceback; ----------------- -- Break_Start -- ----------------- procedure Break_Start is begin null; end Break_Start; ---------------- -- Call_Chain -- ---------------- procedure Call_Chain (Excep : EOA) is begin if Excep.Num_Tracebacks /= 0 then -- This is a reraise, no need to store a new (wrong) chain. return; end if; System.Traceback.Call_Chain (Excep.Tracebacks'Address, Max_Tracebacks, Excep.Num_Tracebacks, AAA'Address, ZZZ'Address); end Call_Chain; ------------------------------ -- Current_Target_Exception -- ------------------------------ function Current_Target_Exception return Exception_Occurrence is begin return Null_Occurrence; end Current_Target_Exception; ------------------- -- EId_To_String -- ------------------- function EId_To_String (X : Exception_Id) return String is begin if X = Null_Id then return ""; else return Exception_Name (X); end if; end EId_To_String; ------------------ -- EO_To_String -- ------------------ -- We use the null string to represent the null occurrence, otherwise -- we output the Exception_Information string for the occurrence. function EO_To_String (X : Exception_Occurrence) return String is begin if X.Id = Null_Id then return ""; else return Exception_Information (X); end if; end EO_To_String; ------------------------ -- Exception_Identity -- ------------------------ function Exception_Identity (X : Exception_Occurrence) return Exception_Id is begin if X.Id = Null_Id then raise Constraint_Error; else return X.Id; end if; end Exception_Identity; --------------------------- -- Exception_Information -- --------------------------- -- The format of the string is: -- Exception_Name: nnnnn -- Message: mmmmm -- PID: ppp -- Call stack traceback locations: -- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh -- where -- nnnn is the fully qualified name of the exception in all upper -- case letters. This line is always present. -- mmmm is the message (this line present only if message is non-null) -- ppp is the Process Id value as a decimal integer (this line is -- present only if the Process Id is non-zero). Currently we are -- not making use of this field. -- The Call stack traceback locations line and the following values -- are present only if at least one traceback location was recorded. -- the values are given in C style format, with lower case letters -- for a-f, and only as many digits present as are necessary. -- The line terminator sequence at the end of each line, including the -- last line is a CR-LF sequence (16#0D# followed by 16#0A#). -- The Exception_Name and Message lines are omitted in the abort -- signal case, since this is not really an exception, and the only -- use of this routine is internal for printing termination output. -- WARNING: if the format of the generated string is changed, please note -- that an equivalent modification to the routine String_To_EO must be -- made to preserve proper functioning of the stream attributes. function Exception_Information (X : Exception_Occurrence) return String is -- This information is now built using the circuitry introduced in -- association with the support of traceback decorators, as the -- catenation of the exception basic information and the call chain -- backtrace in its basic form. Basic_Info : constant String := Basic_Exception_Information (X); Tback_Info : constant String := Basic_Exception_Traceback (X); Basic_Len : constant Natural := Basic_Info'Length; Tback_Len : constant Natural := Tback_Info'Length; Info : String (1 .. Basic_Len + Tback_Len); Ptr : Natural := 0; begin Append_Info_String (Basic_Info, Info, Ptr); Append_Info_String (Tback_Info, Info, Ptr); return Info; end Exception_Information; ----------------------- -- Exception_Message -- ----------------------- function Exception_Message (X : Exception_Occurrence) return String is begin if X.Id = Null_Id then raise Constraint_Error; end if; return X.Msg (1 .. X.Msg_Length); end Exception_Message; -------------------- -- Exception_Name -- -------------------- function Exception_Name (Id : Exception_Id) return String is begin if Id = null then raise Constraint_Error; end if; return Id.Full_Name.all (1 .. Id.Name_Length - 1); end Exception_Name; function Exception_Name (X : Exception_Occurrence) return String is begin return Exception_Name (X.Id); end Exception_Name; --------------------------- -- Exception_Name_Simple -- --------------------------- function Exception_Name_Simple (X : Exception_Occurrence) return String is Name : constant String := Exception_Name (X); P : Natural; begin P := Name'Length; while P > 1 loop exit when Name (P - 1) = '.'; P := P - 1; end loop; return Name (P .. Name'Length); end Exception_Name_Simple; ----------------------------- -- Process_Raise_Exception -- ----------------------------- procedure Process_Raise_Exception (E : Exception_Id; From_Signal_Handler : Boolean) is pragma Inspection_Point (E); -- This is so the debugger can reliably inspect the parameter Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; Mstate_Ptr : constant Machine_State := Machine_State (Get_Machine_State_Addr.all); Excep : EOA := Get_Current_Excep.all; begin -- WARNING : There should be no exception handler for this body -- because this would cause gigi to prepend a setup for a new -- jmpbuf to the sequence of statements. We would then always get -- this new buf in Jumpbuf_Ptr instead of the one for the exception -- we are handling, which would completely break the whole design -- of this procedure. -- Processing varies between zero cost and setjmp/lonjmp processing. if Zero_Cost_Exceptions /= 0 then -- Use the front-end tables to propagate if we have them, otherwise -- resort to the GCC back-end alternative. The backtrace for the -- occurrence is stored while walking up the stack, and thus stops -- in the handler's frame if there is one. Notifications are also -- not performed here since it is not yet known if the exception is -- handled. -- Set the machine state unless we are raising from a signal handler -- since it has already been set properly in that case. if not From_Signal_Handler then Set_Machine_State (Mstate_Ptr); end if; if Subprogram_Descriptors /= null then Propagate_Exception_With_FE_Support (Mstate_Ptr); else Propagate_Exception_With_GCC_Support (Mstate_Ptr); end if; else -- Compute the backtrace for this occurrence if the corresponding -- binder option has been set and we are not raising from a signal -- handler. Call_Chain takes care of the reraise case. if not From_Signal_Handler and then Exception_Tracebacks /= 0 then Call_Chain (Excep); end if; -- If the jump buffer pointer is non-null, transfer control using -- it. Otherwise announce an unhandled exception (note that this -- means that we have no finalizations to do other than at the outer -- level). Perform the necessary notification tasks in both cases. if Jumpbuf_Ptr /= Null_Address then if not Excep.Exception_Raised then Excep.Exception_Raised := True; Notify_Handled_Exception (Null_Loc, False, False); -- The low level debugger notification is skipped from the -- call above because we do not have the necessary information -- to "feed" it properly. end if; builtin_longjmp (Jumpbuf_Ptr, 1); else Notify_Unhandled_Exception (E); Unhandled_Exception_Terminate; end if; end if; end Process_Raise_Exception; ----------------------------------------- -- Propagate_Exception_With_FE_Support -- ----------------------------------------- procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State) is Excep : constant EOA := Get_Current_Excep.all; Loc : Code_Loc; Lo, Hi : Natural; Pdesc : Natural; Hrec : Handler_Record_Ptr; Info : Subprogram_Info_Type; type Machine_State_Record is new Storage_Array (1 .. Machine_State_Length); for Machine_State_Record'Alignment use Standard'Maximum_Alignment; procedure Duplicate_Machine_State (Dest, Src : Machine_State); -- Copy Src into Dest, assuming that a Machine_State is pointing to -- an area of Machine_State_Length bytes. procedure Duplicate_Machine_State (Dest, Src : Machine_State) is type Machine_State_Record_Access is access Machine_State_Record; function To_MSR is new Unchecked_Conversion (Machine_State, Machine_State_Record_Access); begin To_MSR (Dest).all := To_MSR (Src).all; end Duplicate_Machine_State; -- Data for handling the finalization handler case. A simple approach -- in this routine would simply to unwind stack frames till we find a -- handler and then enter it. But this is undesirable in the case where -- we have only finalization handlers, and no "real" handler, i.e. a -- case where we have an unhandled exception. -- In this case we prefer to signal unhandled exception with the stack -- intact, and entering finalization handlers would destroy the stack -- state. To deal with this, as we unwind the stack, we note the first -- finalization handler, and remember it in the following variables. -- We then continue to unwind. If and when we find a "real", i.e. non- -- finalization handler, then we use these variables to pass control to -- the finalization handler. FH_Found : Boolean := False; -- Set when a finalization handler is found FH_Mstate : aliased Machine_State_Record; -- Records the machine state for the finalization handler FH_Handler : Code_Loc := Null_Address; -- Record handler address for finalization handler FH_Num_Trb : Natural := 0; -- Save number of tracebacks for finalization handler begin -- Loop through stack frames as exception propagates Main_Loop : loop Loc := Get_Code_Loc (Mstate); exit Main_Loop when Loc = Null_Loc; -- Record location unless it is inside this unit. Note: this -- test should really say Code_Address, but Address is the same -- as Code_Address for unnested subprograms, and Code_Address -- would cause a bootstrap problem if Loc < AAA'Address or else Loc > ZZZ'Address then -- Record location unless we already recorded max tracebacks if Excep.Num_Tracebacks /= Max_Tracebacks then -- Do not record location if it is the return point from -- a reraise call from within a cleanup handler if not Excep.Cleanup_Flag then Excep.Num_Tracebacks := Excep.Num_Tracebacks + 1; Excep.Tracebacks (Excep.Num_Tracebacks) := Loc; -- For reraise call from cleanup handler, skip entry and -- clear the flag so that we will start to record again else Excep.Cleanup_Flag := False; end if; end if; end if; -- Do binary search on procedure table Lo := 1; Hi := Num_Subprogram_Descriptors; -- Binary search loop loop Pdesc := (Lo + Hi) / 2; -- Note that Loc is expected to be the procedure's call point -- and not the return point. if Loc < Subprogram_Descriptors (Pdesc).Code then Hi := Pdesc - 1; elsif Pdesc < Num_Subprogram_Descriptors and then Loc > Subprogram_Descriptors (Pdesc + 1).Code then Lo := Pdesc + 1; else exit; end if; -- This happens when the current Loc is completely outside of -- the range of the program, which usually means that we reached -- the top level frame (e.g __start). In this case we have an -- unhandled exception. exit Main_Loop when Hi < Lo; end loop; -- Come here with Subprogram_Descriptors (Pdesc) referencing the -- procedure descriptor that applies to this PC value. Now do a -- serial search to see if any handler is applicable to this PC -- value, and to the exception that we are propagating for J in 1 .. Subprogram_Descriptors (Pdesc).Num_Handlers loop Hrec := Subprogram_Descriptors (Pdesc).Handler_Records (J); if Loc >= Hrec.Lo and then Loc < Hrec.Hi then -- PC range is applicable, see if handler is for this exception -- First test for case of "all others" (finalization) handler. -- We do not enter such a handler until we are sure there is -- a real handler further up the stack. if Hrec.Id = All_Others_Id then -- If this is the first finalization handler, then -- save the machine state so we can enter it later -- without having to repeat the search. if not FH_Found then FH_Found := True; Duplicate_Machine_State (Machine_State (FH_Mstate'Address), Mstate); FH_Handler := Hrec.Handler; FH_Num_Trb := Excep.Num_Tracebacks; end if; -- Normal (non-finalization exception with matching Id) elsif Excep.Id = Hrec.Id or else (Hrec.Id = Others_Id and not Excep.Id.Not_Handled_By_Others) then -- Perform the necessary notification tasks. Notify_Handled_Exception (Hrec.Handler, Hrec.Id = Others_Id, True); -- If we already encountered a finalization handler, then -- reset the context to that handler, and enter it. if FH_Found then Excep.Num_Tracebacks := FH_Num_Trb; Excep.Cleanup_Flag := True; Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler); -- If we have not encountered a finalization handler, -- then enter the current handler. else Enter_Handler (Mstate, Hrec.Handler); end if; end if; end if; end loop; Info := Subprogram_Descriptors (Pdesc).Subprogram_Info; exit Main_Loop when Info = No_Info; Pop_Frame (Mstate, Info); end loop Main_Loop; -- Fall through if no "real" exception handler found. First thing is to -- perform the necessary notification tasks with the stack intact. Notify_Unhandled_Exception (Excep.Id); -- If there were finalization handlers, then enter the top one. -- Just because there is no handler does not mean we don't have -- to still execute all finalizations and cleanups before -- terminating. Note that the process of calling cleanups -- does not disturb the back trace stack, since he same -- exception occurrence gets reraised, and new traceback -- entries added as we go along. if FH_Found then Excep.Num_Tracebacks := FH_Num_Trb; Excep.Cleanup_Flag := True; Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler); end if; -- If no cleanups, then this is the real unhandled termination Unhandled_Exception_Terminate; end Propagate_Exception_With_FE_Support; ------------------------------------------ -- Propagate_Exception_With_GCC_Support -- ------------------------------------------ procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State) is Excep : EOA := Get_Current_Excep.all; This_Exception : aliased GNAT_GCC_Exception; Status : Unwind_Reason_Code; begin -- ??? Nothing is currently done for backtracing purposes. We could -- have used the personality routine to record the addresses while -- walking up the stack, but this method has two drawbacks : 1/ the -- trace is incomplete if the exception is handled since we don't walk -- up the frame with the handler, and 2/ we will miss frames if the -- exception propagates through frames for which our personality -- routine is not called (e.g. if C or C++ frames are on the way). -- Fill in the useful flags for the personality routine called for each -- frame via the call to Unwind_RaiseException below. This_Exception.Id := Excep.Id; This_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others; This_Exception.Has_Cleanup := False; -- We are looking for a regular handler first. If there is one, either -- it or the first at-end handler before it will be entered. If there -- is none, control will normally get back to after the call, with -- Has_Cleanup set to true if at least one at-end handler has been -- found while walking up the stack. This_Exception.Select_Cleanups := False; Status := Unwind_RaiseException (This_Exception'Access); -- If we get here we know the exception is not handled, as otherwise -- Unwind_RaiseException arranges for a handler to be entered. We might -- have met cleanups handlers, though, requiring to start again with -- the Select_Cleanups flag set to True. -- Before restarting for cleanups, take the necessary steps to enable -- the debugger to gain control while the stack is still intact. Flag -- the occurrence as raised to avoid notifying again in case cleanup -- handlers are entered later. if not Excep.Exception_Raised then Excep.Exception_Raised := True; Notify_Unhandled_Exception (Excep.Id); end if; -- Now raise again selecting cleanups as true handlers. Only do this if -- we know at least one such handler exists since otherwise we would -- perform a complete stack upwalk for nothing. if This_Exception.Has_Cleanup then This_Exception.Select_Cleanups := True; Status := Unwind_RaiseException (This_Exception'Access); -- The first cleanup found is entered. It performs its job, raises -- the initial exception again, and the flow goes back to the first -- step above with the stack in a different state. end if; -- We get here when there is no handler to be run at all. The debugger -- has been notified before the second step above. Unhandled_Exception_Terminate; end Propagate_Exception_With_GCC_Support; ---------------------------- -- Raise_Constraint_Error -- ---------------------------- procedure Raise_Constraint_Error (File : Big_String_Ptr; Line : Integer) is begin Raise_With_Location (Constraint_Error_Def'Access, File, Line); end Raise_Constraint_Error; -------------------------------- -- Raise_Constraint_Error_Msg -- -------------------------------- procedure Raise_Constraint_Error_Msg (File : Big_String_Ptr; Line : Integer; Msg : Big_String_Ptr) is begin Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line, Msg); end Raise_Constraint_Error_Msg; ------------------------- -- Raise_Current_Excep -- ------------------------- procedure Raise_Current_Excep (E : Exception_Id) is begin Process_Raise_Exception (E => E, From_Signal_Handler => False); end Raise_Current_Excep; --------------------- -- Raise_Exception -- --------------------- procedure Raise_Exception (E : Exception_Id; Message : String := "") is Len : constant Natural := Natural'Min (Message'Length, Exception_Msg_Max_Length); Excep : constant EOA := Get_Current_Excep.all; begin if E /= null then Excep.Msg_Length := Len; Excep.Msg (1 .. Len) := Message (1 .. Len); Raise_With_Msg (E); end if; end Raise_Exception; ---------------------------- -- Raise_Exception_Always -- ---------------------------- procedure Raise_Exception_Always (E : Exception_Id; Message : String := "") is Len : constant Natural := Natural'Min (Message'Length, Exception_Msg_Max_Length); Excep : constant EOA := Get_Current_Excep.all; begin Excep.Msg_Length := Len; Excep.Msg (1 .. Len) := Message (1 .. Len); Raise_With_Msg (E); end Raise_Exception_Always; ------------------------------- -- Raise_From_Signal_Handler -- ------------------------------- procedure Raise_From_Signal_Handler (E : Exception_Id; M : Big_String_Ptr) is begin Set_Exception_C_Msg (E, M); Abort_Defer.all; Process_Raise_Exception (E => E, From_Signal_Handler => True); end Raise_From_Signal_Handler; ------------------ -- Raise_No_Msg -- ------------------ procedure Raise_No_Msg (E : Exception_Id) is Excep : constant EOA := Get_Current_Excep.all; begin Excep.Msg_Length := 0; Raise_With_Msg (E); end Raise_No_Msg; ------------------------- -- Raise_Program_Error -- ------------------------- procedure Raise_Program_Error (File : Big_String_Ptr; Line : Integer) is begin Raise_With_Location (Program_Error_Def'Access, File, Line); end Raise_Program_Error; ----------------------------- -- Raise_Program_Error_Msg -- ----------------------------- procedure Raise_Program_Error_Msg (File : Big_String_Ptr; Line : Integer; Msg : Big_String_Ptr) is begin Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line, Msg); end Raise_Program_Error_Msg; ------------------------- -- Raise_Storage_Error -- ------------------------- procedure Raise_Storage_Error (File : Big_String_Ptr; Line : Integer) is begin Raise_With_Location (Storage_Error_Def'Access, File, Line); end Raise_Storage_Error; ----------------------------- -- Raise_Storage_Error_Msg -- ----------------------------- procedure Raise_Storage_Error_Msg (File : Big_String_Ptr; Line : Integer; Msg : Big_String_Ptr) is begin Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line, Msg); end Raise_Storage_Error_Msg; ---------------------- -- Raise_With_C_Msg -- ---------------------- procedure Raise_With_C_Msg (E : Exception_Id; M : Big_String_Ptr) is begin Set_Exception_C_Msg (E, M); Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_C_Msg; ------------------------- -- Raise_With_Location -- ------------------------- procedure Raise_With_Location (E : Exception_Id; F : Big_String_Ptr; L : Integer) is begin Set_Exception_C_Msg (E, F, L); Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_Location; --------------------------------- -- Raise_With_Location_And_Msg -- --------------------------------- procedure Raise_With_Location_And_Msg (E : Exception_Id; F : Big_String_Ptr; L : Integer; M : Big_String_Ptr) is begin Set_Exception_C_Msg (E, F, L, M); Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_Location_And_Msg; -------------------- -- Raise_With_Msg -- -------------------- procedure Raise_With_Msg (E : Exception_Id) is Excep : constant EOA := Get_Current_Excep.all; begin Excep.Exception_Raised := False; Excep.Id := E; Excep.Num_Tracebacks := 0; Excep.Cleanup_Flag := False; Excep.Pid := Local_Partition_ID; Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_Msg; ------------- -- Reraise -- ------------- procedure Reraise is Excep : constant EOA := Get_Current_Excep.all; begin Abort_Defer.all; Raise_Current_Excep (Excep.Id); end Reraise; ------------------------ -- Reraise_Occurrence -- ------------------------ procedure Reraise_Occurrence (X : Exception_Occurrence) is begin if X.Id /= null then Abort_Defer.all; Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end if; end Reraise_Occurrence; ------------------------------- -- Reraise_Occurrence_Always -- ------------------------------- procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is begin Abort_Defer.all; Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_Always; --------------------------------- -- Reraise_Occurrence_No_Defer -- --------------------------------- procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is begin Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_No_Defer; --------------------- -- Save_Occurrence -- --------------------- procedure Save_Occurrence (Target : out Exception_Occurrence; Source : Exception_Occurrence) is begin Target.Id := Source.Id; Target.Msg_Length := Source.Msg_Length; Target.Num_Tracebacks := Source.Num_Tracebacks; Target.Pid := Source.Pid; Target.Cleanup_Flag := Source.Cleanup_Flag; Target.Msg (1 .. Target.Msg_Length) := Source.Msg (1 .. Target.Msg_Length); Target.Tracebacks (1 .. Target.Num_Tracebacks) := Source.Tracebacks (1 .. Target.Num_Tracebacks); end Save_Occurrence; function Save_Occurrence (Source : Exception_Occurrence) return EOA is Target : EOA := new Exception_Occurrence; begin Save_Occurrence (Target.all, Source); return Target; end Save_Occurrence; --------------------- -- SDP_Table_Build -- --------------------- procedure SDP_Table_Build (SDP_Addresses : System.Address; SDP_Count : Natural; Elab_Addresses : System.Address; Elab_Addr_Count : Natural) is type SDLP_Array is array (1 .. SDP_Count) of Subprogram_Descriptors_Ptr; type SDLP_Array_Ptr is access all SDLP_Array; function To_SDLP_Array_Ptr is new Unchecked_Conversion (System.Address, SDLP_Array_Ptr); T : constant SDLP_Array_Ptr := To_SDLP_Array_Ptr (SDP_Addresses); type Elab_Array is array (1 .. Elab_Addr_Count) of Code_Loc; type Elab_Array_Ptr is access all Elab_Array; function To_Elab_Array_Ptr is new Unchecked_Conversion (System.Address, Elab_Array_Ptr); EA : constant Elab_Array_Ptr := To_Elab_Array_Ptr (Elab_Addresses); Ndes : Natural; Previous_Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr; begin -- If first call, then initialize count of subprogram descriptors if Subprogram_Descriptors = null then Num_Subprogram_Descriptors := 0; end if; -- First count number of subprogram descriptors. This count includes -- entries with duplicated code addresses (resulting from Import). Ndes := Num_Subprogram_Descriptors + Elab_Addr_Count; for J in T'Range loop Ndes := Ndes + T (J).Count; end loop; -- Now, allocate the new table (extra zero'th element is for sort call) -- after having saved the previous one Previous_Subprogram_Descriptors := Subprogram_Descriptors; Subprogram_Descriptors := new Subprogram_Descriptor_List (0 .. Ndes); -- If there was a previous Subprogram_Descriptors table, copy it back -- into the new one being built. Then free the memory used for the -- previous table. for J in 1 .. Num_Subprogram_Descriptors loop Subprogram_Descriptors (J) := Previous_Subprogram_Descriptors (J); end loop; Free (Previous_Subprogram_Descriptors); -- Next, append the elaboration routine addresses, building dummy -- SDP's for them as we go through the list. Ndes := Num_Subprogram_Descriptors; for J in EA'Range loop Ndes := Ndes + 1; Subprogram_Descriptors (Ndes) := new Subprogram_Descriptor_0; Subprogram_Descriptors (Ndes).all := Subprogram_Descriptor' (Num_Handlers => 0, Code => Fetch_Code (EA (J)), Subprogram_Info => EA (J), Handler_Records => (1 .. 0 => null)); end loop; -- Now copy in pointers to SDP addresses of application subprograms for J in T'Range loop for K in 1 .. T (J).Count loop Ndes := Ndes + 1; Subprogram_Descriptors (Ndes) := T (J).SDesc (K); Subprogram_Descriptors (Ndes).Code := Fetch_Code (T (J).SDesc (K).Code); end loop; end loop; -- Now we need to sort the table into ascending PC order Sort (Ndes, SDP_Table_Sort_Move'Access, SDP_Table_Sort_Lt'Access); -- Now eliminate duplicate entries. Note that in the case where -- entries have duplicate code addresses, the code for the Lt -- routine ensures that the interesting one (i.e. the one with -- handler entries if there are any) comes first. Num_Subprogram_Descriptors := 1; for J in 2 .. Ndes loop if Subprogram_Descriptors (J).Code /= Subprogram_Descriptors (Num_Subprogram_Descriptors).Code then Num_Subprogram_Descriptors := Num_Subprogram_Descriptors + 1; Subprogram_Descriptors (Num_Subprogram_Descriptors) := Subprogram_Descriptors (J); end if; end loop; end SDP_Table_Build; ----------------------- -- SDP_Table_Sort_Lt -- ----------------------- function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean is SDC1 : constant Code_Loc := Subprogram_Descriptors (Op1).Code; SDC2 : constant Code_Loc := Subprogram_Descriptors (Op2).Code; begin if SDC1 < SDC2 then return True; elsif SDC1 > SDC2 then return False; -- For two descriptors for the same procedure, we want the more -- interesting one first. A descriptor with an exception handler -- is more interesting than one without. This happens if the less -- interesting one came from a pragma Import. else return Subprogram_Descriptors (Op1).Num_Handlers /= 0 and then Subprogram_Descriptors (Op2).Num_Handlers = 0; end if; end SDP_Table_Sort_Lt; -------------------------- -- SDP_Table_Sort_Move -- -------------------------- procedure SDP_Table_Sort_Move (From : Natural; To : Natural) is begin Subprogram_Descriptors (To) := Subprogram_Descriptors (From); end SDP_Table_Sort_Move; ------------------------- -- Set_Exception_C_Msg -- ------------------------- procedure Set_Exception_C_Msg (Id : Exception_Id; Msg1 : Big_String_Ptr; Line : Integer := 0; Msg2 : Big_String_Ptr := null) is Excep : constant EOA := Get_Current_Excep.all; Val : Integer := Line; Remind : Integer; Size : Integer := 1; Ptr : Natural; begin Excep.Exception_Raised := False; Excep.Id := Id; Excep.Num_Tracebacks := 0; Excep.Pid := Local_Partition_ID; Excep.Msg_Length := 0; Excep.Cleanup_Flag := False; while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL and then Excep.Msg_Length < Exception_Msg_Max_Length loop Excep.Msg_Length := Excep.Msg_Length + 1; Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length); end loop; -- Append line number if present if Line > 0 then -- Compute the number of needed characters while Val > 0 loop Val := Val / 10; Size := Size + 1; end loop; -- If enough characters are available, put the line number if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then Excep.Msg (Excep.Msg_Length + 1) := ':'; Excep.Msg_Length := Excep.Msg_Length + Size; Val := Line; Size := 0; while Val > 0 loop Remind := Val rem 10; Val := Val / 10; Excep.Msg (Excep.Msg_Length - Size) := Character'Val (Remind + Character'Pos ('0')); Size := Size + 1; end loop; end if; end if; -- Append second message if present if Msg2 /= null and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length then Excep.Msg_Length := Excep.Msg_Length + 1; Excep.Msg (Excep.Msg_Length) := ' '; Ptr := 1; while Msg2 (Ptr) /= ASCII.NUL and then Excep.Msg_Length < Exception_Msg_Max_Length loop Excep.Msg_Length := Excep.Msg_Length + 1; Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr); Ptr := Ptr + 1; end loop; end if; end Set_Exception_C_Msg; ------------------- -- String_To_EId -- ------------------- function String_To_EId (S : String) return Exception_Id is begin if S = "" then return Null_Id; else return Exception_Id (Internal_Exception (S)); end if; end String_To_EId; ------------------ -- String_To_EO -- ------------------ function String_To_EO (S : String) return Exception_Occurrence is From : Natural; To : Integer; X : Exception_Occurrence; -- This is the exception occurrence we will create procedure Bad_EO; pragma No_Return (Bad_EO); -- Signal bad exception occurrence string procedure Next_String; -- On entry, To points to last character of previous line of the -- message, terminated by LF. On return, From .. To are set to -- specify the next string, or From > To if there are no more lines. procedure Bad_EO is begin Raise_Exception (Program_Error'Identity, "bad exception occurrence in stream input"); end Bad_EO; procedure Next_String is begin From := To + 2; if From < S'Last then To := From + 1; while To < S'Last - 1 loop if To >= S'Last then Bad_EO; elsif S (To + 1) = ASCII.LF then exit; else To := To + 1; end if; end loop; end if; end Next_String; -- Start of processing for String_To_EO begin if S = "" then return Null_Occurrence; else X.Cleanup_Flag := False; To := S'First - 2; Next_String; if S (From .. From + 15) /= "Exception name: " then Bad_EO; end if; X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To))); Next_String; if From <= To and then S (From) = 'M' then if S (From .. From + 8) /= "Message: " then Bad_EO; end if; X.Msg_Length := To - From - 8; X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To); Next_String; else X.Msg_Length := 0; end if; X.Pid := 0; if From <= To and then S (From) = 'P' then if S (From .. From + 3) /= "PID:" then Bad_EO; end if; From := From + 5; -- skip past PID: space while From <= To loop X.Pid := X.Pid * 10 + (Character'Pos (S (From)) - Character'Pos ('0')); From := From + 1; end loop; Next_String; end if; X.Num_Tracebacks := 0; if From <= To then if S (From .. To) /= "Call stack traceback locations:" then Bad_EO; end if; Next_String; loop exit when From > To; declare Ch : Character; C : Integer_Address; N : Integer_Address; begin if S (From) /= '0' or else S (From + 1) /= 'x' then Bad_EO; else From := From + 2; end if; C := 0; while From <= To loop Ch := S (From); if Ch in '0' .. '9' then N := Character'Pos (S (From)) - Character'Pos ('0'); elsif Ch in 'a' .. 'f' then N := Character'Pos (S (From)) - Character'Pos ('a') + 10; elsif Ch = ' ' then From := From + 1; exit; else Bad_EO; end if; C := C * 16 + N; From := From + 1; end loop; if X.Num_Tracebacks = Max_Tracebacks then Bad_EO; end if; X.Num_Tracebacks := X.Num_Tracebacks + 1; X.Tracebacks (X.Num_Tracebacks) := To_Address (C); end; end loop; end if; -- If an exception was converted to a string, it must have -- already been raised, so flag it accordingly and we are done. X.Exception_Raised := True; return X; end if; end String_To_EO; ---------------------------------- -- Tailored_Exception_Traceback -- ---------------------------------- function Tailored_Exception_Traceback (X : Exception_Occurrence) return String is -- We indeed reference the decorator *wrapper* from here and not the -- decorator itself. The purpose of the local variable Wrapper is to -- prevent a potential crash by race condition in the code below. The -- atomicity of this assignment is enforced by pragma Atomic in -- System.Soft_Links. -- The potential race condition here, if no local variable was used, -- relates to the test upon the wrapper's value and the call, which -- are not performed atomically. With the local variable, potential -- changes of the wrapper's global value between the test and the -- call become inoffensive. Wrapper : constant Traceback_Decorator_Wrapper_Call := Traceback_Decorator_Wrapper; begin if Wrapper = null then return Basic_Exception_Traceback (X); else return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); end if; end Tailored_Exception_Traceback; ------------------------------------ -- Tailored_Exception_Information -- ------------------------------------ function Tailored_Exception_Information (X : Exception_Occurrence) return String is -- The tailored exception information is simply the basic information -- associated with the tailored call chain backtrace. Basic_Info : constant String := Basic_Exception_Information (X); Tback_Info : constant String := Tailored_Exception_Traceback (X); Basic_Len : constant Natural := Basic_Info'Length; Tback_Len : constant Natural := Tback_Info'Length; Info : String (1 .. Basic_Len + Tback_Len); Ptr : Natural := 0; begin Append_Info_String (Basic_Info, Info, Ptr); Append_Info_String (Tback_Info, Info, Ptr); return Info; end Tailored_Exception_Information; ------------------------- -- Unhandled_Exception -- ------------------------- procedure Unhandled_Exception is begin null; end Unhandled_Exception; ---------------------- -- Notify_Exception -- ---------------------- procedure Notify_Exception (Id : Exception_Id; Handler : Code_Loc; Is_Others : Boolean) is begin null; end Notify_Exception; ------------------------------ -- Notify_Handled_Exception -- ------------------------------ procedure Notify_Handled_Exception (Handler : Code_Loc; Is_Others : Boolean; Low_Notify : Boolean) is Excep : constant EOA := Get_Current_Excep.all; begin -- Notify the debugger that we have found a handler and are about to -- propagate an exception, but only if specifically told to do so. if Low_Notify then Notify_Exception (Excep.Id, Handler, Is_Others); end if; -- Output some exception information if necessary, as specified by -- GNAT.Exception_Traces. Take care not to output information about -- internal exceptions. -- -- ??? In the ZCX case, the traceback entries we have at this point -- only include the ones we stored while walking up the stack *up to -- the handler*. All the frames above the subprogram in which the -- handler is found are missing. if Exception_Trace = Every_Raise and then not Excep.Id.Not_Handled_By_Others then To_Stderr (Nline); To_Stderr ("Exception raised"); To_Stderr (Nline); To_Stderr (Tailored_Exception_Information (Excep.all)); end if; end Notify_Handled_Exception; ------------------------------ -- Notify_Handled_Exception -- ------------------------------ procedure Notify_Unhandled_Exception (Id : Exception_Id) is begin -- Simply perform the two necessary low level notification calls. Unhandled_Exception; Notify_Exception (Id, Null_Loc, False); end Notify_Unhandled_Exception; ----------------------------------- -- Unhandled_Exception_Terminate -- ----------------------------------- adafinal_Called : Boolean := False; -- Used to prevent recursive call to adafinal in the event that -- adafinal processing itself raises an unhandled exception. type FILEs is new System.Address; type int is new Integer; procedure Unhandled_Exception_Terminate is Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all); -- This occurrence will be used to display a message after finalization. -- It is necessary to save a copy here, or else the designated value -- could be overwritten if an exception is raised during finalization -- (even if that exception is caught). Msg : constant String := Exception_Message (Excep.all); -- Start of processing for Unhandled_Exception_Terminate begin -- First call adafinal if not adafinal_Called then adafinal_Called := True; System.Soft_Links.Adafinal.all; end if; -- Check for special case of raising _ABORT_SIGNAL, which is not -- really an exception at all. We recognize this by the fact that -- it is the only exception whose name starts with underscore. if Exception_Name (Excep.all) (1) = '_' then To_Stderr (Nline); To_Stderr ("Execution terminated by abort of environment task"); To_Stderr (Nline); -- If no tracebacks, we print the unhandled exception in the old style -- (i.e. the style used before ZCX was implemented). We do this to -- retain compatibility, especially with the nightly scripts, but -- this can be removed at some point ??? elsif Excep.Num_Tracebacks = 0 then To_Stderr (Nline); To_Stderr ("raised "); To_Stderr (Exception_Name (Excep.all)); if Msg'Length /= 0 then To_Stderr (" : "); To_Stderr (Msg); end if; To_Stderr (Nline); -- New style, zero cost exception case else -- Tailored_Exception_Information is also called here so that the -- backtrace decorator gets called if it has been set. This is -- currently required because some paths in Raise_Current_Excep -- do not go through the calls that display this information. -- -- Note also that with the current scheme in Raise_Current_Excep -- we can have this whole information output twice, typically when -- some handler is found on the call chain but none deals with the -- occurrence or if this occurrence gets reraised up to here. To_Stderr (Nline); To_Stderr ("Execution terminated by unhandled exception"); To_Stderr (Nline); To_Stderr (Tailored_Exception_Information (Excep.all)); end if; -- Perform system dependent shutdown code declare procedure Unhandled_Terminate; pragma No_Return (Unhandled_Terminate); pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); begin Unhandled_Terminate; end; end Unhandled_Exception_Terminate; ------------------------------ -- Raise_Exception_No_Defer -- ------------------------------ procedure Raise_Exception_No_Defer (E : Exception_Id; Message : String := "") is Len : constant Natural := Natural'Min (Message'Length, Exception_Msg_Max_Length); Excep : constant EOA := Get_Current_Excep.all; begin Excep.Exception_Raised := False; Excep.Msg_Length := Len; Excep.Msg (1 .. Len) := Message (1 .. Len); Excep.Id := E; Excep.Num_Tracebacks := 0; Excep.Cleanup_Flag := False; Excep.Pid := Local_Partition_ID; -- DO NOT CALL Abort_Defer.all; !!!! Raise_Current_Excep (E); end Raise_Exception_No_Defer; --------------- -- To_Stderr -- --------------- procedure To_Stderr (S : String) is procedure put_char_stderr (C : int); pragma Import (C, put_char_stderr, "put_char_stderr"); begin for J in 1 .. S'Length loop if S (J) /= ASCII.CR then put_char_stderr (Character'Pos (S (J))); end if; end loop; end To_Stderr; --------- -- ZZZ -- --------- -- This dummy procedure gives us the end of the PC range for addresses -- within the exception unit itself. We hope that gigi/gcc keeps all the -- procedures in their original order! procedure ZZZ is begin null; end ZZZ; begin -- Allocate the Non-Tasking Machine_State Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State)); end Ada.Exceptions;