| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2003 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 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; |
| Adjusted_PC : in Address; |
| Current_FP : in Address; |
| Current_R26 : in 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 := Address'Null_Parameter; |
| User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter); |
| |
| 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), |
| User_Act_Proc); |
| |
| 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; |
| 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 |
| if J = Traceback'Last then |
| Return_Address := Address_Zero; |
| else |
| Return_Address := PC_For (Traceback (J + 1)); |
| end if; |
| |
| 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; |
