From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/g-trasym-vms-ia64.adb | 345 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 345 insertions(+) create mode 100644 gcc/ada/g-trasym-vms-ia64.adb (limited to 'gcc/ada/g-trasym-vms-ia64.adb') diff --git a/gcc/ada/g-trasym-vms-ia64.adb b/gcc/ada/g-trasym-vms-ia64.adb new file mode 100644 index 000000000..897e2ebb2 --- /dev/null +++ b/gcc/ada/g-trasym-vms-ia64.adb @@ -0,0 +1,345 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; -- cgit v1.2.3