diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/a-exexda.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/a-exexda.adb | 724 |
1 files changed, 0 insertions, 724 deletions
diff --git a/gcc-4.8/gcc/ada/a-exexda.adb b/gcc-4.8/gcc/ada/a-exexda.adb deleted file mode 100644 index 85b519a5e..000000000 --- a/gcc-4.8/gcc/ada/a-exexda.adb +++ /dev/null @@ -1,724 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- ADA.EXCEPTIONS.EXCEPTION_DATA -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; use System.Storage_Elements; - -separate (Ada.Exceptions) -package body Exception_Data is - - -- This unit implements the Exception_Information related services for - -- both the Ada standard requirements and the GNAT.Exception_Traces - -- facility. - - -- There are common parts between the contents of Exception_Information - -- (the regular Ada interface) and Tailored_Exception_Information (what - -- the automatic backtracing output includes). The overall structure is - -- sketched below: - - -- - -- Exception_Information - -- | - -- +-------+--------+ - -- | | - -- Basic_Exc_Info & Basic_Exc_Tback - -- (B_E_I) (B_E_TB) - - -- o-- - -- (B_E_I) | Exception_Name: <exception name> (as in Exception_Name) - -- | Message: <message> (or a null line if no message) - -- | PID=nnnn (if != 0) - -- o-- - -- (B_E_TB) | Call stack traceback locations: - -- | <0xyyyyyyyy 0xyyyyyyyy ...> - -- o-- - - -- Tailored_Exception_Information - -- | - -- +----------+----------+ - -- | | - -- Basic_Exc_Info & Tailored_Exc_Tback - -- | - -- +-----------+------------+ - -- | | - -- Basic_Exc_Tback Or Tback_Decorator - -- if no decorator set otherwise - - -- Functions returning String imply secondary stack use, which is a heavy - -- mechanism requiring run-time support. Besides, some of the routines we - -- provide here are to be used by the default Last_Chance_Handler, at the - -- critical point where the runtime is about to be finalized. Since most - -- of the items we have at hand are of bounded length, we also provide a - -- procedural interface able to incrementally append the necessary bits to - -- a preallocated buffer or output them straight to stderr. - - -- The procedural interface is composed of two major sections: a neutral - -- section for basic types like Address, Character, Natural or String, and - -- an exception oriented section for the e.g. Basic_Exception_Information. - -- This is the Append_Info family of procedures below. - - -- Output to stderr is commanded by passing an empty buffer to update, and - -- care is taken not to overflow otherwise. - - -------------------------------------------- - -- Procedural Interface - Neutral section -- - -------------------------------------------- - - procedure Append_Info_Address - (A : Address; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Character - (C : Character; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Nat - (N : Natural; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_NL - (Info : in out String; - Ptr : in out Natural); - pragma Inline (Append_Info_NL); - - procedure Append_Info_String - (S : String; - Info : in out String; - Ptr : in out Natural); - - ------------------------------------------------------- - -- Procedural Interface - Exception oriented section -- - ------------------------------------------------------- - - procedure Append_Info_Exception_Name - (Id : Exception_Id; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Exception_Name - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Exception_Message - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Basic_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Basic_Exception_Traceback - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - -- The "functional" interface to the exception information not involving - -- a traceback decorator uses preallocated intermediate buffers to avoid - -- the use of secondary stack. Preallocation requires preliminary length - -- computation, for which a series of functions are introduced: - - --------------------------------- - -- Length evaluation utilities -- - --------------------------------- - - function Basic_Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural; - - function Basic_Exception_Tback_Maxlength - (X : Exception_Occurrence) return Natural; - - function Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural; - - function Exception_Name_Length - (Id : Exception_Id) return Natural; - - function Exception_Name_Length - (X : Exception_Occurrence) return Natural; - - function Exception_Message_Length - (X : Exception_Occurrence) return Natural; - - -------------------------- - -- Functional Interface -- - -------------------------- - - 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. - - ----------------------------------------------------------------------- - -- Services for the default Last_Chance_Handler and the task wrapper -- - ----------------------------------------------------------------------- - - pragma Export - (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg"); - - pragma Export - (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info"); - - pragma Export - (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); - - ------------------------- - -- Append_Info_Address -- - ------------------------- - - procedure Append_Info_Address - (A : Address; - Info : in out String; - Ptr : in out Natural) - 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); - loop - S (P) := H (Integer (N mod 16)); - P := P - 1; - N := N / 16; - exit when N = 0; - end loop; - - S (P - 1) := '0'; - S (P) := 'x'; - - Append_Info_String (S (P - 1 .. S'Last), Info, Ptr); - end Append_Info_Address; - - --------------------------- - -- Append_Info_Character -- - --------------------------- - - procedure Append_Info_Character - (C : Character; - Info : in out String; - Ptr : in out Natural) - is - begin - if Info'Length = 0 then - To_Stderr (C); - elsif Ptr < Info'Last then - Ptr := Ptr + 1; - Info (Ptr) := C; - end if; - end Append_Info_Character; - - --------------------- - -- 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; - - Append_Info_Character - (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr); - end Append_Info_Nat; - - -------------------- - -- Append_Info_NL -- - -------------------- - - procedure Append_Info_NL - (Info : in out String; - Ptr : in out Natural) - is - begin - Append_Info_Character (ASCII.LF, Info, Ptr); - end Append_Info_NL; - - ------------------------ - -- Append_Info_String -- - ------------------------ - - procedure Append_Info_String - (S : String; - Info : in out String; - Ptr : in out Natural) - is - begin - if Info'Length = 0 then - To_Stderr (S); - else - declare - Last : constant Natural := - Integer'Min (Ptr + S'Length, Info'Last); - begin - Info (Ptr + 1 .. Last) := S; - Ptr := Last; - end; - end if; - end Append_Info_String; - - --------------------------------------------- - -- Append_Info_Basic_Exception_Information -- - --------------------------------------------- - - -- To ease the maximum length computation, we define and pull out a couple - -- of string constants: - - BEI_Name_Header : constant String := "Exception name: "; - BEI_Msg_Header : constant String := "Message: "; - BEI_PID_Header : constant String := "PID: "; - - procedure Append_Info_Basic_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - Name : String (1 .. Exception_Name_Length (X)); - -- Buffer in which to fetch the exception name, in order to check - -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. - - Name_Ptr : Natural := Name'First - 1; - - begin - -- Output exception name and message except for _ABORT_SIGNAL, where - -- these two lines are omitted. - - Append_Info_Exception_Name (X, Name, Name_Ptr); - - if Name (Name'First) /= '_' then - Append_Info_String (BEI_Name_Header, Info, Ptr); - Append_Info_String (Name, Info, Ptr); - Append_Info_NL (Info, Ptr); - - if Exception_Message_Length (X) /= 0 then - Append_Info_String (BEI_Msg_Header, Info, Ptr); - Append_Info_Exception_Message (X, 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 (BEI_PID_Header, Info, Ptr); - Append_Info_Nat (X.Pid, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - end Append_Info_Basic_Exception_Information; - - ------------------------------------------- - -- Basic_Exception_Information_Maxlength -- - ------------------------------------------- - - function Basic_Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural is - begin - return - BEI_Name_Header'Length + Exception_Name_Length (X) + 1 - + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 - + BEI_PID_Header'Length + 15; - end Basic_Exception_Info_Maxlength; - - ------------------------------------------- - -- Append_Info_Basic_Exception_Traceback -- - ------------------------------------------- - - -- As for Basic_Exception_Information: - - BETB_Header : constant String := "Call stack traceback locations:"; - - procedure Append_Info_Basic_Exception_Traceback - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - if X.Num_Tracebacks = 0 then - return; - end if; - - Append_Info_String (BETB_Header, Info, Ptr); - Append_Info_NL (Info, Ptr); - - for J in 1 .. X.Num_Tracebacks loop - Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr); - exit when J = X.Num_Tracebacks; - Append_Info_Character (' ', Info, Ptr); - end loop; - - Append_Info_NL (Info, Ptr); - end Append_Info_Basic_Exception_Traceback; - - ----------------------------------------- - -- Basic_Exception_Traceback_Maxlength -- - ----------------------------------------- - - function Basic_Exception_Tback_Maxlength - (X : Exception_Occurrence) return Natural - is - Space_Per_Traceback : constant := 2 + 16 + 1; - -- Space for "0x" + HHHHHHHHHHHHHHHH + " " - begin - return BETB_Header'Length + 1 + - X.Num_Tracebacks * Space_Per_Traceback + 1; - end Basic_Exception_Tback_Maxlength; - - --------------------------------------- - -- Append_Info_Exception_Information -- - --------------------------------------- - - procedure Append_Info_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - Append_Info_Basic_Exception_Information (X, Info, Ptr); - Append_Info_Basic_Exception_Traceback (X, Info, Ptr); - end Append_Info_Exception_Information; - - ------------------------------ - -- Exception_Info_Maxlength -- - ------------------------------ - - function Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural - is - begin - return - Basic_Exception_Info_Maxlength (X) - + Basic_Exception_Tback_Maxlength (X); - end Exception_Info_Maxlength; - - ----------------------------------- - -- Append_Info_Exception_Message -- - ----------------------------------- - - procedure Append_Info_Exception_Message - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - if X.Id = Null_Id then - raise Constraint_Error; - end if; - - declare - Len : constant Natural := Exception_Message_Length (X); - Msg : constant String (1 .. Len) := X.Msg (1 .. Len); - begin - Append_Info_String (Msg, Info, Ptr); - end; - end Append_Info_Exception_Message; - - -------------------------------- - -- Append_Info_Exception_Name -- - -------------------------------- - - procedure Append_Info_Exception_Name - (Id : Exception_Id; - Info : in out String; - Ptr : in out Natural) - is - begin - if Id = Null_Id then - raise Constraint_Error; - end if; - - declare - Len : constant Natural := Exception_Name_Length (Id); - Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); - begin - Append_Info_String (Name, Info, Ptr); - end; - end Append_Info_Exception_Name; - - procedure Append_Info_Exception_Name - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - Append_Info_Exception_Name (X.Id, Info, Ptr); - end Append_Info_Exception_Name; - - --------------------------- - -- Exception_Name_Length -- - --------------------------- - - function Exception_Name_Length - (Id : Exception_Id) return Natural - is - begin - -- What is stored in the internal Name buffer includes a terminating - -- null character that we never care about. - - return Id.Name_Length - 1; - end Exception_Name_Length; - - function Exception_Name_Length - (X : Exception_Occurrence) return Natural is - begin - return Exception_Name_Length (X.Id); - end Exception_Name_Length; - - ------------------------------ - -- Exception_Message_Length -- - ------------------------------ - - function Exception_Message_Length - (X : Exception_Occurrence) return Natural - is - begin - return X.Msg_Length; - end Exception_Message_Length; - - ------------------------------- - -- Basic_Exception_Traceback -- - ------------------------------- - - function Basic_Exception_Traceback - (X : Exception_Occurrence) return String - is - Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X)); - Ptr : Natural := Info'First - 1; - begin - Append_Info_Basic_Exception_Traceback (X, Info, Ptr); - return Info (Info'First .. Ptr); - end Basic_Exception_Traceback; - - --------------------------- - -- Exception_Information -- - --------------------------- - - function Exception_Information - (X : Exception_Occurrence) return String - is - Info : String (1 .. Exception_Info_Maxlength (X)); - Ptr : Natural := Info'First - 1; - begin - Append_Info_Exception_Information (X, Info, Ptr); - return Info (Info'First .. Ptr); - end Exception_Information; - - ------------------------- - -- Set_Exception_C_Msg -- - ------------------------- - - procedure Set_Exception_C_Msg - (Excep : EOA; - Id : Exception_Id; - Msg1 : System.Address; - Line : Integer := 0; - Column : Integer := 0; - Msg2 : System.Address := System.Null_Address) - is - Remind : Integer; - Ptr : Natural; - - procedure Append_Number (Number : Integer); - -- Append given number to Excep.Msg - - ------------------- - -- Append_Number -- - ------------------- - - procedure Append_Number (Number : Integer) is - Val : Integer; - Size : Integer; - - begin - if Number <= 0 then - return; - end if; - - -- Compute the number of needed characters - - Size := 1; - Val := Number; - 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 := Number; - 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 Append_Number; - - -- Start of processing for Set_Exception_C_Msg - - begin - Excep.Exception_Raised := False; - Excep.Id := Id; - Excep.Num_Tracebacks := 0; - Excep.Pid := Local_Partition_ID; - Excep.Msg_Length := 0; - - while To_Ptr (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) := To_Ptr (Msg1) (Excep.Msg_Length); - end loop; - - Append_Number (Line); - Append_Number (Column); - - -- Append second message if present - - if Msg2 /= System.Null_Address - 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 To_Ptr (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) := To_Ptr (Msg2) (Ptr); - Ptr := Ptr + 1; - end loop; - end if; - end Set_Exception_C_Msg; - - ----------------------- - -- Set_Exception_Msg -- - ----------------------- - - procedure Set_Exception_Msg - (Excep : EOA; - Id : Exception_Id; - Message : String) - is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); - First : constant Integer := Message'First; - begin - Excep.Exception_Raised := False; - Excep.Msg_Length := Len; - Excep.Msg (1 .. Len) := Message (First .. First + Len - 1); - Excep.Id := Id; - Excep.Num_Tracebacks := 0; - Excep.Pid := Local_Partition_ID; - end Set_Exception_Msg; - - ---------------------------------- - -- Tailored_Exception_Traceback -- - ---------------------------------- - - function Tailored_Exception_Traceback - (X : Exception_Occurrence) return String - is - -- We reference the decorator *wrapper* here and not the decorator - -- itself. The purpose of the local variable Wrapper is to prevent a - -- potential 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 the basic information - -- associated with the tailored call chain backtrace. - - Tback_Info : constant String := Tailored_Exception_Traceback (X); - Tback_Len : constant Natural := Tback_Info'Length; - - Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len); - Ptr : Natural := Info'First - 1; - - begin - Append_Info_Basic_Exception_Information (X, Info, Ptr); - Append_Info_String (Tback_Info, Info, Ptr); - return Info (Info'First .. Ptr); - end Tailored_Exception_Information; - -end Exception_Data; |