diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/g-trasym-vms-ia64.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/g-trasym-vms-ia64.adb | 345 |
1 files changed, 0 insertions, 345 deletions
diff --git a/gcc-4.8/gcc/ada/g-trasym-vms-ia64.adb b/gcc-4.8/gcc/ada/g-trasym-vms-ia64.adb deleted file mode 100644 index 897e2ebb2..000000000 --- a/gcc-4.8/gcc/ada/g-trasym-vms-ia64.adb +++ /dev/null @@ -1,345 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T R A C E B A C K . S Y M B O L I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2010, 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. -- --- -- ------------------------------------------------------------------------------- - --- Run-time symbolic traceback support for IA64/VMS - -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with System; -with System.Aux_DEC; -with System.Soft_Links; -with System.Traceback_Entries; - -package body GNAT.Traceback.Symbolic is - - use System; - use System.Aux_DEC; - use System.Traceback_Entries; - - subtype Var_String_Buf is String (1 .. 254); - - type Var_String is record - Curlen : Unsigned_Word := 0; - Buf : Var_String_Buf; - end record; - pragma Convention (C, Var_String); - for Var_String'Size use 8 * 256; - - type Descriptor64 is record - Mbo : Unsigned_Word; - Dtype : Unsigned_Byte; - Class : Unsigned_Byte; - Mbmo : Unsigned_Longword; - Maxstrlen : Integer_64; - Pointer : Address; - end record; - pragma Convention (C, Descriptor64); - - subtype Cond_Value_Type is Unsigned_Longword; - - -- TBK_API_PARAM as defined in TBKDEF - - type Tbk_Api_Param is record - Length : Unsigned_Word; - T_Type : Unsigned_Byte; - Version : Unsigned_Byte; - Reserveda : Unsigned_Longword; - Faulting_Pc : Address; - Faulting_Fp : Address; - Filename_Desc : Address; - Library_Module_Desc : Address; - Record_Number : Address; - Image_Desc : Address; - Module_Desc : Address; - Routine_Desc : Address; - Listing_Lineno : Address; - Rel_Pc : Address; - Image_Base_Addr : Address; - Module_Base_Addr : Address; - Malloc_Rtn : Address; - Free_Rtn : Address; - Symbolize_Flags : Address; - Reserved0 : Unsigned_Quadword; - Reserved1 : Unsigned_Quadword; - Reserved2 : Unsigned_Quadword; - end record; - pragma Convention (C, Tbk_Api_Param); - - K_Version : constant Unsigned_Byte := 1; - -- Current API version - - K_Length : constant Unsigned_Word := 152; - -- Length of the parameter - - pragma Compile_Time_Error (Tbk_Api_Param'Size = K_Length * 8, - "Bad length for tbk_api_param"); - -- Sanity check - - function Symbolize (Param : Address) return Cond_Value_Type; - pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE"); - - function Decode_Ada_Name (Encoded_Name : String) return String; - -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing - -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.' - - procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address); - -- Setup descriptor Desc for address Var - - --------------------- - -- Decode_Ada_Name -- - --------------------- - - function Decode_Ada_Name (Encoded_Name : String) return String is - Decoded_Name : String (1 .. Encoded_Name'Length); - Pos : Integer := Encoded_Name'First; - Last : Integer := Encoded_Name'Last; - DPos : Integer := 1; - - begin - if Pos > Last then - return ""; - end if; - - -- Skip leading _ada_ - - if Encoded_Name'Length > 4 - and then Encoded_Name (Pos .. Pos + 4) = "_ada_" - then - Pos := Pos + 5; - end if; - - -- Skip trailing __{DIGIT}+ or ${DIGIT}+ - - if Encoded_Name (Last) in '0' .. '9' then - for J in reverse Pos + 2 .. Last - 1 loop - case Encoded_Name (J) is - when '0' .. '9' => - null; - - when '$' => - Last := J - 1; - exit; - - when '_' => - if Encoded_Name (J - 1) = '_' then - Last := J - 2; - end if; - exit; - - when others => - exit; - end case; - end loop; - end if; - - -- Now just copy encoded name to decoded name, converting "__" to '.' - - while Pos <= Last loop - if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_' - and then Pos /= Encoded_Name'First - then - Decoded_Name (DPos) := '.'; - Pos := Pos + 2; - else - Decoded_Name (DPos) := Encoded_Name (Pos); - Pos := Pos + 1; - end if; - - DPos := DPos + 1; - end loop; - - return Decoded_Name (1 .. DPos - 1); - end Decode_Ada_Name; - - --------------------------- - -- Setup_Descriptor64_Vs -- - --------------------------- - - procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is - K_Dtype_Vt : constant Unsigned_Byte := 37; - K_Class_Vs : constant Unsigned_Byte := 11; - begin - Desc.Mbo := 1; - Desc.Dtype := K_Dtype_Vt; - Desc.Class := K_Class_Vs; - Desc.Mbmo := -1; - Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length); - Desc.Pointer := Var; - end Setup_Descriptor64_Vs; - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is - Param : Tbk_Api_Param; - Status : Cond_Value_Type; - Record_Number : Unsigned_Longword; - Image_Name : Var_String; - Image_Dsc : Descriptor64; - Module_Name : Var_String; - Module_Dsc : Descriptor64; - Routine_Name : Var_String; - Routine_Dsc : Descriptor64; - Line_Number : Unsigned_Longword; - Res : String (1 .. 256 * Traceback'Length); - Len : Integer; - - begin - if Traceback'Length = 0 then - return ""; - end if; - - Len := 0; - - -- Since image computation is not thread-safe we need task lockout - - System.Soft_Links.Lock_Task.all; - - -- Initialize descriptors - - Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address); - Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address); - Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address); - - for J in Traceback'Range loop - -- Initialize fields in case they are not written - - Record_Number := 0; - Line_Number := 0; - Image_Name.Curlen := 0; - Module_Name.Curlen := 0; - Routine_Name.Curlen := 0; - - -- Symbolize - - Param := (Length => K_Length, - T_Type => 0, - Version => K_Version, - Reserveda => 0, - Faulting_Pc => PC_For (Traceback (J)), - Faulting_Fp => 0, - Filename_Desc => Null_Address, - Library_Module_Desc => Null_Address, - Record_Number => Record_Number'Address, - Image_Desc => Image_Dsc'Address, - Module_Desc => Module_Dsc'Address, - Routine_Desc => Routine_Dsc'Address, - Listing_Lineno => Line_Number'Address, - Rel_Pc => Null_Address, - Image_Base_Addr => Null_Address, - Module_Base_Addr => Null_Address, - Malloc_Rtn => Null_Address, - Free_Rtn => Null_Address, - Symbolize_Flags => Null_Address, - Reserved0 => (0, 0), - Reserved1 => (0, 0), - Reserved2 => (0, 0)); - - Status := Symbolize (Param'Address); - - -- Check for success (marked by bit 0) - - if (Status rem 2) = 1 then - - -- Success - - if Line_Number = 0 then - - -- As GCC doesn't emit source file correlation, use record - -- number of line number is not set - - Line_Number := Record_Number; - end if; - - declare - First : constant Integer := Len + 1; - Last : Integer := First + 80 - 1; - Pos : Integer; - - Routine_Name_D : constant String := - Decode_Ada_Name - (Routine_Name.Buf - (1 .. Natural (Routine_Name.Curlen))); - - Lineno : constant String := - Unsigned_Longword'Image (Line_Number); - - begin - Res (First .. Last) := (others => ' '); - - Res (First .. First + Natural (Image_Name.Curlen) - 1) := - Image_Name.Buf (1 .. Natural (Image_Name.Curlen)); - - Res (First + 10 .. - First + 10 + Natural (Module_Name.Curlen) - 1) := - Module_Name.Buf (1 .. Natural (Module_Name.Curlen)); - - Res (First + 30 .. - First + 30 + Routine_Name_D'Length - 1) := - Routine_Name_D; - - -- If routine name doesn't fit 20 characters, output the line - -- number on next line at 50th position. - - if Routine_Name_D'Length > 20 then - Pos := First + 30 + Routine_Name_D'Length; - Res (Pos) := ASCII.LF; - Last := Pos + 80; - Res (Pos + 1 .. Last) := (others => ' '); - Pos := Pos + 51; - else - Pos := First + 50; - end if; - - Res (Pos .. Pos + Lineno'Length - 1) := Lineno; - - Res (Last) := ASCII.LF; - Len := Last; - end; - - -- Failure (bit 0 clear) - - else - Res (Len + 1 .. Len + 6) := "ERROR" & ASCII.LF; - Len := Len + 6; - end if; - end loop; - - System.Soft_Links.Unlock_Task.all; - return Res (1 .. Len); - end Symbolic_Traceback; - - function Symbolic_Traceback (E : Exception_Occurrence) return String is - begin - return Symbolic_Traceback (Tracebacks (E)); - end Symbolic_Traceback; - -end GNAT.Traceback.Symbolic; |