X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fg-trasym-vms-ia64.adb;h=28dab4729bd5b1c1045960b42f34ae96c8401cc6;hb=a34480d83b68142f300347d89d233f971438cf5d;hp=2e1834bffa095e7da413895aacda97302f1dce5f;hpb=f27cea3abf8ded22456f5f46a812cc3915969815;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/g-trasym-vms-ia64.adb b/gcc/ada/g-trasym-vms-ia64.adb index 2e1834bffa0..28dab4729bd 100644 --- a/gcc/ada/g-trasym-vms-ia64.adb +++ b/gcc/ada/g-trasym-vms-ia64.adb @@ -6,25 +6,23 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2009, 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- -- +-- 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. 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- --- 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. -- +-- 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 -- +-- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -34,7 +32,6 @@ -- 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; @@ -42,60 +39,53 @@ with System.Traceback_Entries; package body GNAT.Traceback.Symbolic is - pragma Warnings (Off); + pragma Warnings (Off); -- ??? needs comment 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; + subtype Var_String_Buf is String (1 .. 254); - type ASCIC is record - Count : unsigned_char; - Data : char_array (1 .. 255); + type Var_String is record + Curlen : Unsigned_Word := 0; + Buf : Var_String_Buf; end record; - pragma Convention (C, ASCIC); - - for ASCIC use record - Count at 0 range 0 .. 7; - Data at 1 range 0 .. 8 * 255 - 1; + 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; - 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)); + pragma Convention (C, Descriptor64); + + subtype Cond_Value_Type is Unsigned_Longword; + + function Symbolize + (Current_PC : Address; + Filename_Dsc : Address; + Library_Dsc : Address; + Record_Number : Address; + Image_Dsc : Address; + Module_Dsc : Address; + Routine_Dsc : Address; + Line_Number : Address; + Relative_PC : 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 -- --------------------- @@ -126,14 +116,17 @@ package body GNAT.Traceback.Symbolic is 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; @@ -148,7 +141,6 @@ package body GNAT.Traceback.Symbolic is then Decoded_Name (DPos) := '.'; Pos := Pos + 2; - else Decoded_Name (DPos) := Encoded_Name (Pos); Pos := Pos + 1; @@ -160,106 +152,121 @@ package body GNAT.Traceback.Symbolic is 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 - 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; + Status : Cond_Value_Type; + Filename_Name : Var_String; + Filename_Dsc : Descriptor64; + Library_Name : Var_String; + Library_Dsc : Descriptor64; + Record_Number : Integer_64; + Image_Name : Var_String; + Image_Dsc : Descriptor64; + Module_Name : Var_String; + Module_Dsc : Descriptor64; + Routine_Name : Var_String; + Routine_Dsc : Descriptor64; + Line_Number : Integer_64; + Relative_PC : Integer_64; + 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 + 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; + + Setup_Descriptor64_Vs (Filename_Dsc, Filename_Name'Address); + Setup_Descriptor64_Vs (Library_Dsc, Library_Name'Address); + 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 + Status := Symbolize + (PC_For (Traceback (J)), + Filename_Dsc'Address, + Library_Dsc'Address, + Record_Number'Address, + Image_Dsc'Address, + Module_Dsc'Address, + Routine_Dsc'Address, + Line_Number'Address, + Relative_PC'Address); + + declare + First : Integer := Len + 1; + Last : Integer := First + 80 - 1; + Pos : Integer; + + Routine_Name_D : String := + Decode_Ada_Name + (Routine_Name.Buf + (1 .. Natural (Routine_Name.Curlen))); + + 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 + Integer_64'Image (Line_Number)'Length - 1) := + Integer_64'Image (Line_Number); + + Res (Last) := ASCII.LF; + Len := Last; + end; + end loop; + + System.Soft_Links.Unlock_Task.all; + return Res (1 .. Len); end Symbolic_Traceback; function Symbolic_Traceback (E : Exception_Occurrence) return String is