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