aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/g-trasym-vms-ia64.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/g-trasym-vms-ia64.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/g-trasym-vms-ia64.adb277
1 files changed, 0 insertions, 277 deletions
diff --git a/gcc-4.4.3/gcc/ada/g-trasym-vms-ia64.adb b/gcc-4.4.3/gcc/ada/g-trasym-vms-ia64.adb
deleted file mode 100644
index 7e2195409..000000000
--- a/gcc-4.4.3/gcc/ada/g-trasym-vms-ia64.adb
+++ /dev/null
@@ -1,277 +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-2009, 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
-
- 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;
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-25 05:33:07 +0000