URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-trasym-vms-ia64.adb] - Rev 724
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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-2010, 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 : Exception_Occurrence) return String is begin return Symbolic_Traceback (Tracebacks (E)); end Symbolic_Traceback; end GNAT.Traceback.Symbolic;
Go to most recent revision | Compare with Previous | Blame | View Log