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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  Run-time symbolic traceback support for IA64/VMS
  35
  36 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
  37 with System;
  38 with System.Aux_DEC;
  39 with System.Soft_Links;
  40 with System.Traceback_Entries;
  41
  42 package body GNAT.Traceback.Symbolic is
  43
  44    pragma Warnings (Off);
  45    pragma Linker_Options ("--for-linker=sys$library:trace.exe");
  46
  47    use System;
  48    use System.Aux_DEC;
  49    use System.Traceback_Entries;
  50
  51    subtype Var_String_Buf is String (1 .. 254);
  52
  53    type Var_String is record
  54       Curlen : Unsigned_Word := 0;
  55       Buf    : Var_String_Buf;
  56    end record;
  57    pragma Convention (C, Var_String);
  58    for Var_String'Size use 8 * 256;
  59
  60    type Descriptor64 is record
  61       Mbo       : Unsigned_Word;
  62       Dtype     : Unsigned_Byte;
  63       Class     : Unsigned_Byte;
  64       Mbmo      : Unsigned_Longword;
  65       Maxstrlen : Integer_64;
  66       Pointer   : Address;
  67    end record;
  68    pragma Convention (C, Descriptor64);
  69
  70    subtype Cond_Value_Type is Unsigned_Longword;
  71
  72    function Symbolize
  73      (Current_PC    : Address;
  74       Filename_Dsc  : Address;
  75       Library_Dsc   : Address;
  76       Record_Number : Address;
  77       Image_Dsc     : Address;
  78       Module_Dsc    : Address;
  79       Routine_Dsc   : Address;
  80       Line_Number   : Address;
  81       Relative_PC   : Address) return Cond_Value_Type;
  82    pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE");
  83
  84    function Decode_Ada_Name (Encoded_Name : String) return String;
  85    --  Decodes an Ada identifier name. Removes leading "_ada_" and trailing
  86    --  __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
  87
  88    procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address);
  89    --  Setup descriptor Desc for address Var
  90
  91    ---------------------
  92    -- Decode_Ada_Name --
  93    ---------------------
  94
  95    function Decode_Ada_Name (Encoded_Name : String) return String is
  96       Decoded_Name : String (1 .. Encoded_Name'Length);
  97       Pos          : Integer := Encoded_Name'First;
  98       Last         : Integer := Encoded_Name'Last;
  99       DPos         : Integer := 1;
 100
 101    begin
 102       if Pos > Last then
 103          return "";
 104       end if;
 105
 106       --  Skip leading _ada_
 107
 108       if Encoded_Name'Length > 4
 109         and then Encoded_Name (Pos .. Pos + 4) = "_ada_"
 110       then
 111          Pos := Pos + 5;
 112       end if;
 113
 114       --  Skip trailing __{DIGIT}+ or ${DIGIT}+
 115
 116       if Encoded_Name (Last) in '0' .. '9' then
 117          for J in reverse Pos + 2 .. Last - 1 loop
 118             case Encoded_Name (J) is
 119                when '0' .. '9' =>
 120                   null;
 121
 122                when '$' =>
 123                   Last := J - 1;
 124                   exit;
 125
 126                when '_' =>
 127                   if Encoded_Name (J - 1) = '_' then
 128                      Last := J - 2;
 129                   end if;
 130                   exit;
 131
 132                when others =>
 133                   exit;
 134             end case;
 135          end loop;
 136       end if;
 137
 138       --  Now just copy encoded name to decoded name, converting "__" to '.'
 139
 140       while Pos <= Last loop
 141          if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'
 142            and then Pos /= Encoded_Name'First
 143          then
 144             Decoded_Name (DPos) := '.';
 145             Pos := Pos + 2;
 146          else
 147             Decoded_Name (DPos) := Encoded_Name (Pos);
 148             Pos := Pos + 1;
 149          end if;
 150
 151          DPos := DPos + 1;
 152       end loop;
 153
 154       return Decoded_Name (1 .. DPos - 1);
 155    end Decode_Ada_Name;
 156
 157    ---------------------------
 158    -- Setup_Descriptor64_Vs --
 159    ---------------------------
 160
 161    procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is
 162       K_Dtype_Vt : constant Unsigned_Byte := 37;
 163       K_Class_Vs : constant Unsigned_Byte := 11;
 164    begin
 165       Desc.Mbo := 1;
 166       Desc.Dtype := K_Dtype_Vt;
 167       Desc.Class := K_Class_Vs;
 168       Desc.Mbmo := -1;
 169       Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length);
 170       Desc.Pointer := Var;
 171    end Setup_Descriptor64_Vs;
 172
 173    ------------------------
 174    -- Symbolic_Traceback --
 175    ------------------------
 176
 177    function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
 178       Status        : Cond_Value_Type;
 179       Filename_Name : Var_String;
 180       Filename_Dsc  : Descriptor64;
 181       Library_Name  : Var_String;
 182       Library_Dsc   : Descriptor64;
 183       Record_Number : Integer_64;
 184       Image_Name    : Var_String;
 185       Image_Dsc     : Descriptor64;
 186       Module_Name   : Var_String;
 187       Module_Dsc    : Descriptor64;
 188       Routine_Name  : Var_String;
 189       Routine_Dsc   : Descriptor64;
 190       Line_Number   : Integer_64;
 191       Relative_PC   : Integer_64;
 192       Res           : String (1 .. 256 * Traceback'Length);
 193       Len           : Integer;
 194
 195    begin
 196       if Traceback'Length = 0 then
 197          return "";
 198       end if;
 199
 200       Len := 0;
 201
 202       --  Since image computation is not thread-safe we need task lockout
 203
 204       System.Soft_Links.Lock_Task.all;
 205
 206       Setup_Descriptor64_Vs (Filename_Dsc, Filename_Name'Address);
 207       Setup_Descriptor64_Vs (Library_Dsc, Library_Name'Address);
 208       Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address);
 209       Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address);
 210       Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address);
 211
 212       for J in Traceback'Range loop
 213          Status := Symbolize
 214            (PC_For (Traceback (J)),
 215             Filename_Dsc'Address,
 216             Library_Dsc'Address,
 217             Record_Number'Address,
 218             Image_Dsc'Address,
 219             Module_Dsc'Address,
 220             Routine_Dsc'Address,
 221             Line_Number'Address,
 222             Relative_PC'Address);
 223
 224          declare
 225             First : Integer := Len + 1;
 226             Last  : Integer := First + 80 - 1;
 227             Pos   : Integer;
 228
 229             Routine_Name_D : String :=
 230                                Decode_Ada_Name
 231                                  (Routine_Name.Buf
 232                                     (1 .. Natural (Routine_Name.Curlen)));
 233
 234          begin
 235             Res (First .. Last) := (others => ' ');
 236
 237             Res (First .. First + Natural (Image_Name.Curlen) - 1) :=
 238               Image_Name.Buf (1 .. Natural (Image_Name.Curlen));
 239
 240             Res (First + 10 ..
 241                  First + 10 + Natural (Module_Name.Curlen) - 1) :=
 242               Module_Name.Buf (1 .. Natural (Module_Name.Curlen));
 243
 244             Res (First + 30 ..
 245                  First + 30 + Routine_Name_D'Length - 1) :=
 246               Routine_Name_D;
 247
 248             --  If routine name doesn't fit 20 characters, output
 249             --  the line number on next line at 50th position
 250
 251             if Routine_Name_D'Length > 20 then
 252                Pos := First + 30 + Routine_Name_D'Length;
 253                Res (Pos) := ASCII.LF;
 254                Last := Pos + 80;
 255                Res (Pos + 1 .. Last) := (others => ' ');
 256                Pos := Pos + 51;
 257             else
 258                Pos := First + 50;
 259             end if;
 260
 261             Res (Pos ..
 262                  Pos + Integer_64'Image (Line_Number)'Length - 1) :=
 263               Integer_64'Image (Line_Number);
 264
 265             Res (Last) := ASCII.LF;
 266             Len := Last;
 267          end;
 268       end loop;
 269
 270       System.Soft_Links.Unlock_Task.all;
 271       return Res (1 .. Len);
 272    end Symbolic_Traceback;
 273
 274    function Symbolic_Traceback (E : Exception_Occurrence) return String is
 275    begin
 276       return Symbolic_Traceback (Tracebacks (E));
 277    end Symbolic_Traceback;
 278
 279 end GNAT.Traceback.Symbolic;