From 52627911786069aabae42e6393f536ae288adf6d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 4 Aug 2014 09:53:47 +0200 Subject: [PATCH] Removed. From-SVN: r213531 --- gcc/ada/g-trasym-vms-alpha.adb | 305 ----------------------------- gcc/ada/g-trasym-vms-ia64.adb | 347 --------------------------------- 2 files changed, 652 deletions(-) delete mode 100644 gcc/ada/g-trasym-vms-alpha.adb delete mode 100644 gcc/ada/g-trasym-vms-ia64.adb diff --git a/gcc/ada/g-trasym-vms-alpha.adb b/gcc/ada/g-trasym-vms-alpha.adb deleted file mode 100644 index 6af947f725d..00000000000 --- a/gcc/ada/g-trasym-vms-alpha.adb +++ /dev/null @@ -1,305 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/g-trasym-vms-ia64.adb b/gcc/ada/g-trasym-vms-ia64.adb deleted file mode 100644 index 6ffb7f715bc..00000000000 --- a/gcc/ada/g-trasym-vms-ia64.adb +++ /dev/null @@ -1,347 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; -- 2.30.2