--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / platform / upstream / gcc.git / commitdiff