gcc/ada/g-trasym-vms-alpha.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) 1999-2006, 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 Alpha/VMS
  35
  36 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
  37 with Interfaces.C;
  38 with System;
  39 with System.Aux_DEC;
  40 with System.Soft_Links;
  41 with System.Traceback_Entries;
  42
  43 package body GNAT.Traceback.Symbolic is
  44
  45    pragma Warnings (Off);
  46    pragma Linker_Options ("--for-linker=sys$library:trace.exe");
  47
  48    use Interfaces.C;
  49    use System;
  50    use System.Aux_DEC;
  51    use System.Traceback_Entries;
  52
  53    subtype User_Arg_Type is Unsigned_Longword;
  54    subtype Cond_Value_Type is Unsigned_Longword;
  55
  56    type ASCIC is record
  57       Count : unsigned_char;
  58       Data  : char_array (1 .. 255);
  59    end record;
  60    pragma Convention (C, ASCIC);
  61
  62    for ASCIC use record
  63       Count at 0 range 0 .. 7;
  64       Data  at 1 range 0 .. 8 * 255 - 1;
  65    end record;
  66    for ASCIC'Size use 8 * 256;
  67
  68    function Fetch_ASCIC is new Fetch_From_Address (ASCIC);
  69
  70    -----------------------
  71    -- Local Subprograms --
  72    -----------------------
  73
  74    function Dummy_User_Act_Proc
  75      (Msgvec : Address       := Null_Address;
  76       Actrtn : Address       := Null_Address;
  77       Facnam : Address       := Null_Address;
  78       Actprm : User_Arg_Type := 0) return Cond_Value_Type;
  79    --  Dummy routine with SYS$PUTMSG signature
  80
  81    procedure Symbolize
  82      (Status         : out Cond_Value_Type;
  83       Current_PC     : Address;
  84       Adjusted_PC    : Address;
  85       Current_FP     : Address;
  86       Current_R26    : Address;
  87       Image_Name     : out Address;
  88       Module_Name    : out Address;
  89       Routine_Name   : out Address;
  90       Line_Number    : out Integer;
  91       Relative_PC    : out Address;
  92       Absolute_PC    : out Address;
  93       PC_Is_Valid    : out Long_Integer;
  94       User_Act_Proc  : Address           := Dummy_User_Act_Proc'Address;
  95       User_Arg_Value : User_Arg_Type     := 0);
  96    --  Comment on above procedure required ???
  97
  98    pragma Interface (External, Symbolize);
  99
 100    pragma Import_Valued_Procedure
 101      (Symbolize, "TBK$SYMBOLIZE",
 102       (Cond_Value_Type, Address, Address, Address, Address,
 103        Address, Address, Address, Integer,
 104        Address, Address, Long_Integer,
 105        Address, User_Arg_Type),
 106       (Value, Value, Value, Value, Value,
 107        Reference, Reference, Reference, Reference,
 108        Reference, Reference, Reference,
 109        Value, Value));
 110
 111    function Decode_Ada_Name (Encoded_Name : String) return String;
 112    --  Decodes an Ada identifier name. Removes leading "_ada_" and trailing
 113    --  __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
 114
 115    ---------------------
 116    -- Decode_Ada_Name --
 117    ---------------------
 118
 119    function Decode_Ada_Name (Encoded_Name : String) return String is
 120       Decoded_Name : String (1 .. Encoded_Name'Length);
 121       Pos          : Integer := Encoded_Name'First;
 122       Last         : Integer := Encoded_Name'Last;
 123       DPos         : Integer := 1;
 124
 125    begin
 126       if Pos > Last then
 127          return "";
 128       end if;
 129
 130       --  Skip leading _ada_
 131
 132       if Encoded_Name'Length > 4
 133         and then Encoded_Name (Pos .. Pos + 4) = "_ada_"
 134       then
 135          Pos := Pos + 5;
 136       end if;
 137
 138       --  Skip trailing __{DIGIT}+ or ${DIGIT}+
 139
 140       if Encoded_Name (Last) in '0' .. '9' then
 141          for J in reverse Pos + 2 .. Last - 1 loop
 142             case Encoded_Name (J) is
 143                when '0' .. '9' =>
 144                   null;
 145                when '$' =>
 146                   Last := J - 1;
 147                   exit;
 148                when '_' =>
 149                   if Encoded_Name (J - 1) = '_' then
 150                      Last := J - 2;
 151                   end if;
 152                   exit;
 153                when others =>
 154                   exit;
 155             end case;
 156          end loop;
 157       end if;
 158
 159       --  Now just copy encoded name to decoded name, converting "__" to '.'
 160
 161       while Pos <= Last loop
 162          if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'
 163            and then Pos /= Encoded_Name'First
 164          then
 165             Decoded_Name (DPos) := '.';
 166             Pos := Pos + 2;
 167
 168          else
 169             Decoded_Name (DPos) := Encoded_Name (Pos);
 170             Pos := Pos + 1;
 171          end if;
 172
 173          DPos := DPos + 1;
 174       end loop;
 175
 176       return Decoded_Name (1 .. DPos - 1);
 177    end Decode_Ada_Name;
 178
 179    -------------------------
 180    -- Dummy_User_Act_Proc --
 181    -------------------------
 182
 183    function Dummy_User_Act_Proc
 184      (Msgvec : Address       := Null_Address;
 185       Actrtn : Address       := Null_Address;
 186       Facnam : Address       := Null_Address;
 187       Actprm : User_Arg_Type := 0) return Cond_Value_Type
 188    is
 189    begin
 190       return 0;
 191    end Dummy_User_Act_Proc;
 192
 193    ------------------------
 194    -- Symbolic_Traceback --
 195    ------------------------
 196
 197    function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
 198       Status            : Cond_Value_Type;
 199       Image_Name        : ASCIC;
 200       Image_Name_Addr   : Address;
 201       Module_Name       : ASCIC;
 202       Module_Name_Addr  : Address;
 203       Routine_Name      : ASCIC;
 204       Routine_Name_Addr : Address;
 205       Line_Number       : Integer;
 206       Relative_PC       : Address;
 207       Absolute_PC       : Address;
 208       PC_Is_Valid       : Long_Integer;
 209       Return_Address    : Address;
 210       Res               : String (1 .. 256 * Traceback'Length);
 211       Len               : Integer;
 212
 213    begin
 214       if Traceback'Length > 0 then
 215          Len := 0;
 216
 217          --  Since image computation is not thread-safe we need task lockout
 218
 219          System.Soft_Links.Lock_Task.all;
 220
 221          for J in Traceback'Range loop
 222             if J = Traceback'Last then
 223                Return_Address := Address_Zero;
 224             else
 225                Return_Address := PC_For (Traceback (J + 1));
 226             end if;
 227
 228             Symbolize
 229               (Status,
 230                PC_For (Traceback (J)),
 231                PC_For (Traceback (J)),
 232                PV_For (Traceback (J)),
 233                Return_Address,
 234                Image_Name_Addr,
 235                Module_Name_Addr,
 236                Routine_Name_Addr,
 237                Line_Number,
 238                Relative_PC,
 239                Absolute_PC,
 240                PC_Is_Valid);
 241
 242             Image_Name   := Fetch_ASCIC (Image_Name_Addr);
 243             Module_Name  := Fetch_ASCIC (Module_Name_Addr);
 244             Routine_Name := Fetch_ASCIC (Routine_Name_Addr);
 245
 246             declare
 247                First : Integer := Len + 1;
 248                Last  : Integer := First + 80 - 1;
 249                Pos   : Integer;
 250                Routine_Name_D : String := Decode_Ada_Name
 251                  (To_Ada
 252                     (Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
 253                      False));
 254
 255             begin
 256                Res (First .. Last) := (others => ' ');
 257
 258                Res (First .. First + Integer (Image_Name.Count) - 1) :=
 259                  To_Ada
 260                   (Image_Name.Data (1 .. size_t (Image_Name.Count)),
 261                    False);
 262
 263                Res (First + 10 ..
 264                     First + 10 + Integer (Module_Name.Count) - 1) :=
 265                  To_Ada
 266                   (Module_Name.Data (1 .. size_t (Module_Name.Count)),
 267                    False);
 268
 269                Res (First + 30 ..
 270                     First + 30 + Routine_Name_D'Length - 1) :=
 271                  Routine_Name_D;
 272
 273                --  If routine name doesn't fit 20 characters, output
 274                --  the line number on next line at 50th position
 275
 276                if Routine_Name_D'Length > 20 then
 277                   Pos := First + 30 + Routine_Name_D'Length;
 278                   Res (Pos) := ASCII.LF;
 279                   Last := Pos + 80;
 280                   Res (Pos + 1 .. Last) := (others => ' ');
 281                   Pos := Pos + 51;
 282                else
 283                   Pos := First + 50;
 284                end if;
 285
 286                Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) :=
 287                  Integer'Image (Line_Number);
 288
 289                Res (Last) := ASCII.LF;
 290                Len := Last;
 291             end;
 292          end loop;
 293
 294          System.Soft_Links.Unlock_Task.all;
 295          return Res (1 .. Len);
 296
 297       else
 298          return "";
 299       end if;
 300    end Symbolic_Traceback;
 301
 302    function Symbolic_Traceback (E : Exception_Occurrence) return String is
 303    begin
 304       return Symbolic_Traceback (Tracebacks (E));
 305    end Symbolic_Traceback;
 306
 307 end GNAT.Traceback.Symbolic;