+++ /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) 1999-2014, 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- 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 Import (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 : Ada.Exceptions.Exception_Occurrence) return String
- is
- begin
- return Symbolic_Traceback (Tracebacks (E));
- end Symbolic_Traceback;
-
-end GNAT.Traceback.Symbolic;
+++ /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-2014, 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- 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 System;
-with System.Aux_DEC;
-with System.Soft_Links;
-with System.Traceback_Entries;
-
-package body GNAT.Traceback.Symbolic is
-
- use System;
- use System.Aux_DEC;
- use System.Traceback_Entries;
-
- subtype Var_String_Buf is String (1 .. 254);
-
- type Var_String is record
- Curlen : Unsigned_Word := 0;
- Buf : Var_String_Buf;
- end record;
- 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;
- pragma Convention (C, Descriptor64);
-
- subtype Cond_Value_Type is Unsigned_Longword;
-
- -- TBK_API_PARAM as defined in TBKDEF
-
- type Tbk_Api_Param is record
- Length : Unsigned_Word;
- T_Type : Unsigned_Byte;
- Version : Unsigned_Byte;
- Reserveda : Unsigned_Longword;
- Faulting_Pc : Address;
- Faulting_Fp : Address;
- Filename_Desc : Address;
- Library_Module_Desc : Address;
- Record_Number : Address;
- Image_Desc : Address;
- Module_Desc : Address;
- Routine_Desc : Address;
- Listing_Lineno : Address;
- Rel_Pc : Address;
- Image_Base_Addr : Address;
- Module_Base_Addr : Address;
- Malloc_Rtn : Address;
- Free_Rtn : Address;
- Symbolize_Flags : Address;
- Reserved0 : Unsigned_Quadword;
- Reserved1 : Unsigned_Quadword;
- Reserved2 : Unsigned_Quadword;
- end record;
- pragma Convention (C, Tbk_Api_Param);
-
- K_Version : constant Unsigned_Byte := 1;
- -- Current API version
-
- K_Length : constant Unsigned_Word := 152;
- -- Length of the parameter
-
- pragma Compile_Time_Error (Tbk_Api_Param'Size = K_Length * 8,
- "Bad length for tbk_api_param");
- -- Sanity check
-
- function Symbolize (Param : 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 --
- ---------------------
-
- 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;
-
- ---------------------------
- -- 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
- Param : Tbk_Api_Param;
- Status : Cond_Value_Type;
- Record_Number : Unsigned_Longword;
- Image_Name : Var_String;
- Image_Dsc : Descriptor64;
- Module_Name : Var_String;
- Module_Dsc : Descriptor64;
- Routine_Name : Var_String;
- Routine_Dsc : Descriptor64;
- Line_Number : Unsigned_Longword;
- Res : String (1 .. 256 * Traceback'Length);
- Len : Integer;
-
- begin
- 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;
-
- -- Initialize descriptors
-
- 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
- -- Initialize fields in case they are not written
-
- Record_Number := 0;
- Line_Number := 0;
- Image_Name.Curlen := 0;
- Module_Name.Curlen := 0;
- Routine_Name.Curlen := 0;
-
- -- Symbolize
-
- Param := (Length => K_Length,
- T_Type => 0,
- Version => K_Version,
- Reserveda => 0,
- Faulting_Pc => PC_For (Traceback (J)),
- Faulting_Fp => 0,
- Filename_Desc => Null_Address,
- Library_Module_Desc => Null_Address,
- Record_Number => Record_Number'Address,
- Image_Desc => Image_Dsc'Address,
- Module_Desc => Module_Dsc'Address,
- Routine_Desc => Routine_Dsc'Address,
- Listing_Lineno => Line_Number'Address,
- Rel_Pc => Null_Address,
- Image_Base_Addr => Null_Address,
- Module_Base_Addr => Null_Address,
- Malloc_Rtn => Null_Address,
- Free_Rtn => Null_Address,
- Symbolize_Flags => Null_Address,
- Reserved0 => (0, 0),
- Reserved1 => (0, 0),
- Reserved2 => (0, 0));
-
- Status := Symbolize (Param'Address);
-
- -- Check for success (marked by bit 0)
-
- if (Status rem 2) = 1 then
-
- -- Success
-
- if Line_Number = 0 then
-
- -- As GCC doesn't emit source file correlation, use record
- -- number of line number is not set
-
- Line_Number := Record_Number;
- end if;
-
- declare
- First : constant Integer := Len + 1;
- Last : Integer := First + 80 - 1;
- Pos : Integer;
-
- Routine_Name_D : constant String :=
- Decode_Ada_Name
- (Routine_Name.Buf
- (1 .. Natural (Routine_Name.Curlen)));
-
- Lineno : constant String :=
- Unsigned_Longword'Image (Line_Number);
-
- 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 + Lineno'Length - 1) := Lineno;
-
- Res (Last) := ASCII.LF;
- Len := Last;
- end;
-
- -- Failure (bit 0 clear)
-
- else
- Res (Len + 1 .. Len + 6) := "ERROR" & ASCII.LF;
- Len := Len + 6;
- end if;
- end loop;
-
- System.Soft_Links.Unlock_Task.all;
- return Res (1 .. Len);
- end Symbolic_Traceback;
-
- function Symbolic_Traceback
- (E : Ada.Exceptions.Exception_Occurrence) return String
- is
- begin
- return Symbolic_Traceback (Tracebacks (E));
- end Symbolic_Traceback;
-
-end GNAT.Traceback.Symbolic;
projects / gcc.git / commitdiff