------------------------------------------------------------------------------ -- -- -- 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) 1999-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 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 -- -- . -- -- -- -- 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 Alpha/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); -- 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; 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); ----------------------- -- Local Subprograms -- ----------------------- function Dummy_User_Act_Proc (Msgvec : Address := Null_Address; Actrtn : Address := Null_Address; Facnam : Address := Null_Address; Actprm : User_Arg_Type := 0) return Cond_Value_Type; -- Dummy routine with SYS$PUTMSG signature procedure Symbolize (Status : out Cond_Value_Type; Current_PC : Address; Adjusted_PC : Address; Current_FP : Address; Current_R26 : Address; Image_Name : out Address; Module_Name : out Address; Routine_Name : out Address; Line_Number : out Integer; Relative_PC : out Address; Absolute_PC : out Address; PC_Is_Valid : out Long_Integer; User_Act_Proc : Address := Dummy_User_Act_Proc'Address; User_Arg_Value : User_Arg_Type := 0); -- Comment on above procedure required ??? pragma Interface (External, Symbolize); pragma Import_Valued_Procedure (Symbolize, "TBK$SYMBOLIZE", (Cond_Value_Type, Address, Address, Address, Address, Address, Address, Address, Integer, Address, Address, Long_Integer, Address, User_Arg_Type), (Value, Value, Value, Value, Value, Reference, Reference, Reference, Reference, Reference, Reference, Reference, Value, Value)); 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; ------------------------- -- Dummy_User_Act_Proc -- ------------------------- function Dummy_User_Act_Proc (Msgvec : Address := Null_Address; Actrtn : Address := Null_Address; Facnam : Address := Null_Address; Actprm : User_Arg_Type := 0) return Cond_Value_Type is begin return 0; end Dummy_User_Act_Proc; ------------------------ -- Symbolic_Traceback -- ------------------------ function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is Status : Cond_Value_Type; 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; Absolute_PC : Address; PC_Is_Valid : Long_Integer; Return_Address : 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 Return_Address := (if J = Traceback'Last then Address_Zero else PC_For (Traceback (J + 1))); Symbolize (Status, PC_For (Traceback (J)), PC_For (Traceback (J)), PV_For (Traceback (J)), Return_Address, Image_Name_Addr, Module_Name_Addr, Routine_Name_Addr, Line_Number, Relative_PC, Absolute_PC, PC_Is_Valid); 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;