+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- A D A . E X C E P T I O N S --
--- --
--- B o d y --
--- --
--- $Revision: 1.3.10.1 $
--- --
--- Copyright (C) 1992-2001 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.
-
- Nline : constant String := String' (1 => ASCII.LF);
- -- Convenient shortcut
-
- -----------------------
- -- 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
-
- Address_Image_Length : constant :=
- 13 + 10 * Boolean'Pos (Standard'Address_Size > 32);
- -- Length of string returned by Address_Image function
-
- 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 Free
- is new Ada.Unchecked_Deallocation
- (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr);
-
- 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 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).
- -- The parameter E is ignored.
- --
- -- This external name for Raise_Current_Excep is historical, and probably
- -- should be changed but for now we keep it, because gdb knows about it.
- -- The parameter is also present for historical compatibility. ???
-
- 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 : SSL.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_Constraint_Error
- (File : SSL.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_Program_Error
- (File : SSL.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_Storage_Error
- (File : SSL.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
-
- -- 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;
- Msg : SSL.Big_String_Ptr;
- Line : Integer := 0);
- -- 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. Msg is a null terminated string. when Line > 0,
- -- Msg is the filename and line the line number of the exception location.
-
- 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.
-
- ---------------------------------------
- -- 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 CR/LF couple 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");
-
- procedure Propagate_Exception (Mstate : Machine_State);
- pragma No_Return (Propagate_Exception);
- -- 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. Propagate_Exception searches the exception tables
- -- for an applicable handler, calling Pop_Frame as needed. If and when
- -- it locates an applicable handler Propagate_Exception makes a call
- -- to Enter_Handler to actually enter the handler. If the search is
- -- unable to locate an applicable handler, execution is terminated by
- -- calling Unhandled_Exception_Terminate.
-
- procedure Call_Chain (Excep : EOA);
- -- Store up to Max_Tracebacks in Excep, corresponding to the current
- -- call chain.
-
- -----------------------
- -- 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.CR;
- 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;
-
- -------------------------
- -- Propagate_Exception --
- -------------------------
-
- procedure Propagate_Exception (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;
- -- Record handler address for finalization handler
-
- FH_Num_Trb : Natural;
- -- 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;
-
- -------------------------
- -- Raise_Current_Excep --
- -------------------------
-
- procedure Raise_Current_Excep (E : Exception_Id) 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;
-
- 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.
-
- -- If the jump buffer pointer is non-null, it means that a jump
- -- buffer was allocated (obviously that happens only in the case
- -- of zero cost exceptions not implemented, or if a jump buffer
- -- was manually set up by C code).
-
- if Jumpbuf_Ptr /= Null_Address then
- Excep := Get_Current_Excep.all;
-
- if Exception_Tracebacks /= 0 then
- Call_Chain (Excep);
- end if;
-
- -- Perform the necessary notification tasks if this is not a
- -- reraise. Actually ask to skip the low level debugger notification
- -- call since we do not have the necessary information to "feed"
- -- it properly.
-
- if not Excep.Exception_Raised then
- Excep.Exception_Raised := True;
- Notify_Handled_Exception (Null_Loc, False, False);
- end if;
-
- builtin_longjmp (Jumpbuf_Ptr, 1);
-
- -- If we have no jump buffer, then either zero cost exception
- -- handling is in place, or we have no handlers anyway. In
- -- either case we have an unhandled exception. If zero cost
- -- exception handling is in place, propagate the exception
-
- elsif Subprogram_Descriptors /= null then
- Set_Machine_State (Mstate_Ptr);
- Propagate_Exception (Mstate_Ptr);
-
- -- Otherwise, we know the exception is unhandled by the absence
- -- of an allocated jump buffer. Note that this means that we also
- -- have no finalizations to do other than at the outer level.
-
- else
- if Exception_Tracebacks /= 0 then
- Call_Chain (Get_Current_Excep.all);
- end if;
-
- Notify_Unhandled_Exception (E);
- Unhandled_Exception_Terminate;
- end if;
- 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 : SSL.Big_String_Ptr)
- is
- Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
- Mstate_Ptr : constant Machine_State :=
- Machine_State (Get_Machine_State_Addr.all);
-
- begin
- Set_Exception_C_Msg (E, M);
- Abort_Defer.all;
-
- -- Now we raise the exception. The following code is essentially
- -- identical to the Raise_Current_Excep routine, except that in the
- -- zero cost exception case, we do not call Set_Machine_State, since
- -- the signal handler that passed control here has already set the
- -- machine state directly.
- --
- -- We also do not compute the backtrace for the occurrence since going
- -- through the signal handler is far from trivial and it is not a
- -- problem to fail providing a backtrace in the "raised from signal
- -- handler" case.
-
- -- If the jump buffer pointer is non-null, it means that a jump
- -- buffer was allocated (obviously that happens only in the case
- -- of zero cost exceptions not implemented, or if a jump buffer
- -- was manually set up by C code).
-
- if Jumpbuf_Ptr /= Null_Address then
- builtin_longjmp (Jumpbuf_Ptr, 1);
-
- -- If we have no jump buffer, then either zero cost exception
- -- handling is in place, or we have no handlers anyway. In
- -- either case we have an unhandled exception. If zero cost
- -- exception handling is in place, propagate the exception
-
- elsif Subprogram_Descriptors /= null then
- Propagate_Exception (Mstate_Ptr);
-
- -- Otherwise, we know the exception is unhandled by the absence
- -- of an allocated jump buffer. Note that this means that we also
- -- have no finalizations to do other than at the outer level.
-
- else
- Notify_Unhandled_Exception (E);
- Unhandled_Exception_Terminate;
- end if;
- 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_With_Location --
- -------------------------
-
- procedure Raise_With_Location
- (E : Exception_Id;
- F : SSL.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_Constraint_Error --
- ----------------------------
-
- procedure Raise_Constraint_Error
- (File : SSL.Big_String_Ptr; Line : Integer) is
- begin
- Raise_With_Location (Constraint_Error_Def'Access, File, Line);
- end Raise_Constraint_Error;
-
- -------------------------
- -- Raise_Program_Error --
- -------------------------
-
- procedure Raise_Program_Error
- (File : SSL.Big_String_Ptr; Line : Integer) is
- begin
- Raise_With_Location (Program_Error_Def'Access, File, Line);
- end Raise_Program_Error;
-
- -------------------------
- -- Raise_Storage_Error --
- -------------------------
-
- procedure Raise_Storage_Error
- (File : SSL.Big_String_Ptr; Line : Integer) is
- begin
- Raise_With_Location (Storage_Error_Def'Access, File, Line);
- end Raise_Storage_Error;
-
- ----------------------
- -- Raise_With_C_Msg --
- ----------------------
-
- procedure Raise_With_C_Msg
- (E : Exception_Id;
- M : SSL.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_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;
- Msg : Big_String_Ptr;
- Line : Integer := 0)
- is
- Excep : constant EOA := Get_Current_Excep.all;
- Val : Integer := Line;
- Remind : Integer;
- Size : Integer := 1;
-
- 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 Msg (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) := Msg (Excep.Msg_Length);
- end loop;
-
- 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;
- 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 CR/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 + 3;
-
- if From < S'Last then
- To := From + 1;
-
- while To < S'Last - 2 loop
- if To >= S'Last then
- Bad_EO;
- elsif S (To + 1) = ASCII.CR 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 - 3;
- 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 := Get_Current_Excep.all;
- 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;
projects / msp430-gcc.git / blobdiff