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 34with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; 35with Interfaces.C; 36with System; 37with System.Aux_DEC; 38with System.Soft_Links; 39with System.Traceback_Entries; 40 41package 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 303end GNAT.Traceback.Symbolic; 304