| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |