diff options
Diffstat (limited to 'gcc-4.3.1/gcc/ada/g-trasym-vms-ia64.adb')
| -rw-r--r-- | gcc-4.3.1/gcc/ada/g-trasym-vms-ia64.adb | 279 |
1 files changed, 279 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/g-trasym-vms-ia64.adb b/gcc-4.3.1/gcc/ada/g-trasym-vms-ia64.adb new file mode 100644 index 000000000..374b0ae0c --- /dev/null +++ b/gcc-4.3.1/gcc/ada/g-trasym-vms-ia64.adb @@ -0,0 +1,279 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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 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 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; + + function Symbolize + (Current_PC : Address; + Filename_Dsc : Address; + Library_Dsc : Address; + Record_Number : Address; + Image_Dsc : Address; + Module_Dsc : Address; + Routine_Dsc : Address; + Line_Number : Address; + Relative_PC : 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 + Status : Cond_Value_Type; + Filename_Name : Var_String; + Filename_Dsc : Descriptor64; + Library_Name : Var_String; + Library_Dsc : Descriptor64; + Record_Number : Integer_64; + Image_Name : Var_String; + Image_Dsc : Descriptor64; + Module_Name : Var_String; + Module_Dsc : Descriptor64; + Routine_Name : Var_String; + Routine_Dsc : Descriptor64; + Line_Number : Integer_64; + Relative_PC : Integer_64; + 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; + + Setup_Descriptor64_Vs (Filename_Dsc, Filename_Name'Address); + Setup_Descriptor64_Vs (Library_Dsc, Library_Name'Address); + 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 + Status := Symbolize + (PC_For (Traceback (J)), + Filename_Dsc'Address, + Library_Dsc'Address, + Record_Number'Address, + Image_Dsc'Address, + Module_Dsc'Address, + Routine_Dsc'Address, + Line_Number'Address, + Relative_PC'Address); + + declare + First : Integer := Len + 1; + Last : Integer := First + 80 - 1; + Pos : Integer; + + Routine_Name_D : String := + Decode_Ada_Name + (Routine_Name.Buf + (1 .. Natural (Routine_Name.Curlen))); + + 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 + Integer_64'Image (Line_Number)'Length - 1) := + Integer_64'Image (Line_Number); + + Res (Last) := ASCII.LF; + Len := Last; + end; + 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; |