gcc/ada/g-trasym-vms-ia64.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --             G N A T . T R A C E B A C K . S Y M B O L I C                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --         Copyright (C) 2005-2009, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  Run-time symbolic traceback support for IA64/VMS
  33
  34 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
  35 with System;
  36 with System.Aux_DEC;
  37 with System.Soft_Links;
  38 with System.Traceback_Entries;
  39
  40 package body GNAT.Traceback.Symbolic is
  41
  42    pragma Warnings (Off); --  ??? needs comment
  43    pragma Linker_Options ("--for-linker=sys$library:trace.exe");
  44
  45    use System;
  46    use System.Aux_DEC;
  47    use System.Traceback_Entries;
  48
  49    subtype Var_String_Buf is String (1 .. 254);
  50
  51    type Var_String is record
  52       Curlen : Unsigned_Word := 0;
  53       Buf    : Var_String_Buf;
  54    end record;
  55    pragma Convention (C, Var_String);
  56    for Var_String'Size use 8 * 256;
  57
  58    type Descriptor64 is record
  59       Mbo       : Unsigned_Word;
  60       Dtype     : Unsigned_Byte;
  61       Class     : Unsigned_Byte;
  62       Mbmo      : Unsigned_Longword;
  63       Maxstrlen : Integer_64;
  64       Pointer   : Address;
  65    end record;
  66    pragma Convention (C, Descriptor64);
  67
  68    subtype Cond_Value_Type is Unsigned_Longword;
  69
  70    function Symbolize
  71      (Current_PC    : Address;
  72       Filename_Dsc  : Address;
  73       Library_Dsc   : Address;
  74       Record_Number : Address;
  75       Image_Dsc     : Address;
  76       Module_Dsc    : Address;
  77       Routine_Dsc   : Address;
  78       Line_Number   : Address;
  79       Relative_PC   : Address) return Cond_Value_Type;
  80    pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE");
  81
  82    function Decode_Ada_Name (Encoded_Name : String) return String;
  83    --  Decodes an Ada identifier name. Removes leading "_ada_" and trailing
  84    --  __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
  85
  86    procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address);
  87    --  Setup descriptor Desc for address Var
  88
  89    ---------------------
  90    -- Decode_Ada_Name --
  91    ---------------------
  92
  93    function Decode_Ada_Name (Encoded_Name : String) return String is
  94       Decoded_Name : String (1 .. Encoded_Name'Length);
  95       Pos          : Integer := Encoded_Name'First;
  96       Last         : Integer := Encoded_Name'Last;
  97       DPos         : Integer := 1;
  98
  99    begin
 100       if Pos > Last then
 101          return "";
 102       end if;
 103
 104       --  Skip leading _ada_
 105
 106       if Encoded_Name'Length > 4
 107         and then Encoded_Name (Pos .. Pos + 4) = "_ada_"
 108       then
 109          Pos := Pos + 5;
 110       end if;
 111
 112       --  Skip trailing __{DIGIT}+ or ${DIGIT}+
 113
 114       if Encoded_Name (Last) in '0' .. '9' then
 115          for J in reverse Pos + 2 .. Last - 1 loop
 116             case Encoded_Name (J) is
 117                when '0' .. '9' =>
 118                   null;
 119
 120                when '$' =>
 121                   Last := J - 1;
 122                   exit;
 123
 124                when '_' =>
 125                   if Encoded_Name (J - 1) = '_' then
 126                      Last := J - 2;
 127                   end if;
 128                   exit;
 129
 130                when others =>
 131                   exit;
 132             end case;
 133          end loop;
 134       end if;
 135
 136       --  Now just copy encoded name to decoded name, converting "__" to '.'
 137
 138       while Pos <= Last loop
 139          if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'
 140            and then Pos /= Encoded_Name'First
 141          then
 142             Decoded_Name (DPos) := '.';
 143             Pos := Pos + 2;
 144          else
 145             Decoded_Name (DPos) := Encoded_Name (Pos);
 146             Pos := Pos + 1;
 147          end if;
 148
 149          DPos := DPos + 1;
 150       end loop;
 151
 152       return Decoded_Name (1 .. DPos - 1);
 153    end Decode_Ada_Name;
 154
 155    ---------------------------
 156    -- Setup_Descriptor64_Vs --
 157    ---------------------------
 158
 159    procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is
 160       K_Dtype_Vt : constant Unsigned_Byte := 37;
 161       K_Class_Vs : constant Unsigned_Byte := 11;
 162    begin
 163       Desc.Mbo := 1;
 164       Desc.Dtype := K_Dtype_Vt;
 165       Desc.Class := K_Class_Vs;
 166       Desc.Mbmo := -1;
 167       Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length);
 168       Desc.Pointer := Var;
 169    end Setup_Descriptor64_Vs;
 170
 171    ------------------------
 172    -- Symbolic_Traceback --
 173    ------------------------
 174
 175    function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
 176       Status        : Cond_Value_Type;
 177       Filename_Name : Var_String;
 178       Filename_Dsc  : Descriptor64;
 179       Library_Name  : Var_String;
 180       Library_Dsc   : Descriptor64;
 181       Record_Number : Integer_64;
 182       Image_Name    : Var_String;
 183       Image_Dsc     : Descriptor64;
 184       Module_Name   : Var_String;
 185       Module_Dsc    : Descriptor64;
 186       Routine_Name  : Var_String;
 187       Routine_Dsc   : Descriptor64;
 188       Line_Number   : Integer_64;
 189       Relative_PC   : Integer_64;
 190       Res           : String (1 .. 256 * Traceback'Length);
 191       Len           : Integer;
 192
 193    begin
 194       if Traceback'Length = 0 then
 195          return "";
 196       end if;
 197
 198       Len := 0;
 199
 200       --  Since image computation is not thread-safe we need task lockout
 201
 202       System.Soft_Links.Lock_Task.all;
 203
 204       Setup_Descriptor64_Vs (Filename_Dsc, Filename_Name'Address);
 205       Setup_Descriptor64_Vs (Library_Dsc, Library_Name'Address);
 206       Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address);
 207       Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address);
 208       Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address);
 209
 210       for J in Traceback'Range loop
 211          Status := Symbolize
 212            (PC_For (Traceback (J)),
 213             Filename_Dsc'Address,
 214             Library_Dsc'Address,
 215             Record_Number'Address,
 216             Image_Dsc'Address,
 217             Module_Dsc'Address,
 218             Routine_Dsc'Address,
 219             Line_Number'Address,
 220             Relative_PC'Address);
 221
 222          declare
 223             First : Integer := Len + 1;
 224             Last  : Integer := First + 80 - 1;
 225             Pos   : Integer;
 226
 227             Routine_Name_D : String :=
 228                                Decode_Ada_Name
 229                                  (Routine_Name.Buf
 230                                     (1 .. Natural (Routine_Name.Curlen)));
 231
 232          begin
 233             Res (First .. Last) := (others => ' ');
 234
 235             Res (First .. First + Natural (Image_Name.Curlen) - 1) :=
 236               Image_Name.Buf (1 .. Natural (Image_Name.Curlen));
 237
 238             Res (First + 10 ..
 239                  First + 10 + Natural (Module_Name.Curlen) - 1) :=
 240               Module_Name.Buf (1 .. Natural (Module_Name.Curlen));
 241
 242             Res (First + 30 ..
 243                  First + 30 + Routine_Name_D'Length - 1) :=
 244               Routine_Name_D;
 245
 246             --  If routine name doesn't fit 20 characters, output
 247             --  the line number on next line at 50th position
 248
 249             if Routine_Name_D'Length > 20 then
 250                Pos := First + 30 + Routine_Name_D'Length;
 251                Res (Pos) := ASCII.LF;
 252                Last := Pos + 80;
 253                Res (Pos + 1 .. Last) := (others => ' ');
 254                Pos := Pos + 51;
 255             else
 256                Pos := First + 50;
 257             end if;
 258
 259             Res (Pos ..
 260                  Pos + Integer_64'Image (Line_Number)'Length - 1) :=
 261               Integer_64'Image (Line_Number);
 262
 263             Res (Last) := ASCII.LF;
 264             Len := Last;
 265          end;
 266       end loop;
 267
 268       System.Soft_Links.Unlock_Task.all;
 269       return Res (1 .. Len);
 270    end Symbolic_Traceback;
 271
 272    function Symbolic_Traceback (E : Exception_Occurrence) return String is
 273    begin
 274       return Symbolic_Traceback (Tracebacks (E));
 275    end Symbolic_Traceback;
 276
 277 end GNAT.Traceback.Symbolic;