diff options
| -rw-r--r-- | gcc/ada/g-trasym-vms-alpha.adb (renamed from gcc/ada/g-trasym-vms.adb) | 4 | ||||
| -rw-r--r-- | gcc/ada/g-trasym-vms-ia64.adb | 270 |
2 files changed, 272 insertions, 2 deletions
diff --git a/gcc/ada/g-trasym-vms.adb b/gcc/ada/g-trasym-vms-alpha.adb index 85f541d018b..95c4a243a27 100644 --- a/gcc/ada/g-trasym-vms.adb +++ b/gcc/ada/g-trasym-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2005 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- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- Run-time symbolic traceback support for VMS +-- Run-time symbolic traceback support for Alpha/VMS with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with Interfaces.C; diff --git a/gcc/ada/g-trasym-vms-ia64.adb b/gcc/ada/g-trasym-vms-ia64.adb new file mode 100644 index 00000000000..6519cf63385 --- /dev/null +++ b/gcc/ada/g-trasym-vms-ia64.adb @@ -0,0 +1,270 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support for IA64/VMS + +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with Interfaces.C; +with System; +with System.Aux_DEC; +with System.Soft_Links; +with System.Traceback_Entries; + +package body GNAT.Traceback.Symbolic is + + pragma Warnings (Off); + pragma Linker_Options ("--for-linker=sys$library:trace.exe"); + + use Interfaces.C; + use System; + use System.Aux_DEC; + use System.Traceback_Entries; + + subtype User_Arg_Type is Unsigned_Longword; + subtype Cond_Value_Type is Unsigned_Longword; + + type ASCIC is record + Count : unsigned_char; + Data : char_array (1 .. 255); + end record; + pragma Convention (C, ASCIC); + + for ASCIC use record + Count at 0 range 0 .. 7; + Data at 1 range 0 .. 8 * 255 - 1; + end record; + for ASCIC'Size use 8 * 256; + + function Fetch_ASCIC is new Fetch_From_Address (ASCIC); + + procedure Symbolize + (Status : out Cond_Value_Type; + Current_PC : in Address; + Filename_Name : out Address; + Library_Name : out Address; + Record_Number : out Integer; + Image_Name : out Address; + Module_Name : out Address; + Routine_Name : out Address; + Line_Number : out Integer; + Relative_PC : out Address); + + pragma Interface (External, Symbolize); + + pragma Import_Valued_Procedure + (Symbolize, "TBK$I64_SYMBOLIZE", + (Cond_Value_Type, Address, + Address, Address, Integer, + Address, Address, Address, Integer, + Address), + (Value, Value, + Reference, Reference, Reference, + Reference, Reference, Reference, Reference, + Reference)); + + 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 '.' + + --------------------- + -- 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; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is + Status : Cond_Value_Type; + Filename_Name_Addr : Address; + Library_Name_Addr : Address; + Record_Number : Integer; + Image_Name : ASCIC; + Image_Name_Addr : Address; + Module_Name : ASCIC; + Module_Name_Addr : Address; + Routine_Name : ASCIC; + Routine_Name_Addr : Address; + Line_Number : Integer; + Relative_PC : Address; + Res : String (1 .. 256 * Traceback'Length); + Len : Integer; + + begin + if Traceback'Length > 0 then + Len := 0; + + -- Since image computation is not thread-safe we need task lockout + + System.Soft_Links.Lock_Task.all; + + for J in Traceback'Range loop + + Symbolize + (Status, + PC_For (Traceback (J)), + Filename_Name_Addr, + Library_Name_Addr, + Record_Number, + Image_Name_Addr, + Module_Name_Addr, + Routine_Name_Addr, + Line_Number, + Relative_PC); + + Image_Name := Fetch_ASCIC (Image_Name_Addr); + Module_Name := Fetch_ASCIC (Module_Name_Addr); + Routine_Name := Fetch_ASCIC (Routine_Name_Addr); + + declare + First : Integer := Len + 1; + Last : Integer := First + 80 - 1; + Pos : Integer; + Routine_Name_D : String := Decode_Ada_Name + (To_Ada + (Routine_Name.Data (1 .. size_t (Routine_Name.Count)), + False)); + + begin + Res (First .. Last) := (others => ' '); + + Res (First .. First + Integer (Image_Name.Count) - 1) := + To_Ada + (Image_Name.Data (1 .. size_t (Image_Name.Count)), + False); + + Res (First + 10 .. + First + 10 + Integer (Module_Name.Count) - 1) := + To_Ada + (Module_Name.Data (1 .. size_t (Module_Name.Count)), + False); + + 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 + Integer'Image (Line_Number)'Length - 1) := + Integer'Image (Line_Number); + + Res (Last) := ASCII.LF; + Len := Last; + end; + end loop; + + System.Soft_Links.Unlock_Task.all; + return Res (1 .. Len); + + else + return ""; + end if; + 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; |