1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- G N A T . T R A C E B A C K . S Y M B O L I C --
9 -- Copyright (C) 2005-2009, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- Run-time symbolic traceback support for IA64/VMS
34 with Ada
.Exceptions
.Traceback
; use Ada
.Exceptions
.Traceback
;
37 with System
.Soft_Links
;
38 with System
.Traceback_Entries
;
40 package body GNAT
.Traceback
.Symbolic
is
42 pragma Warnings
(Off
); -- ??? needs comment
43 pragma Linker_Options
("--for-linker=sys$library:trace.exe");
47 use System
.Traceback_Entries
;
49 subtype Var_String_Buf
is String (1 .. 254);
51 type Var_String
is record
52 Curlen
: Unsigned_Word
:= 0;
55 pragma Convention
(C
, Var_String
);
56 for Var_String
'Size use 8 * 256;
58 type Descriptor64
is record
60 Dtype
: Unsigned_Byte
;
61 Class
: Unsigned_Byte
;
62 Mbmo
: Unsigned_Longword
;
63 Maxstrlen
: Integer_64
;
66 pragma Convention
(C
, Descriptor64
);
68 subtype Cond_Value_Type
is Unsigned_Longword
;
71 (Current_PC
: Address
;
72 Filename_Dsc
: Address
;
73 Library_Dsc
: Address
;
74 Record_Number
: 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");
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 '.'
86 procedure Setup_Descriptor64_Vs
(Desc
: out Descriptor64
; Var
: Address
);
87 -- Setup descriptor Desc for address Var
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;
104 -- Skip leading _ada_
106 if Encoded_Name
'Length > 4
107 and then Encoded_Name
(Pos
.. Pos
+ 4) = "_ada_"
112 -- Skip trailing __{DIGIT}+ or ${DIGIT}+
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
125 if Encoded_Name
(J
- 1) = '_' then
136 -- Now just copy encoded name to decoded name, converting "__" to '.'
138 while Pos
<= Last
loop
139 if Encoded_Name
(Pos
) = '_' and then Encoded_Name
(Pos
+ 1) = '_'
140 and then Pos
/= Encoded_Name
'First
142 Decoded_Name
(DPos
) := '.';
145 Decoded_Name
(DPos
) := Encoded_Name
(Pos
);
152 return Decoded_Name
(1 .. DPos
- 1);
155 ---------------------------
156 -- Setup_Descriptor64_Vs --
157 ---------------------------
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;
164 Desc
.Dtype
:= K_Dtype_Vt
;
165 Desc
.Class
:= K_Class_Vs
;
167 Desc
.Maxstrlen
:= Integer_64
(Var_String_Buf
'Length);
169 end Setup_Descriptor64_Vs
;
171 ------------------------
172 -- Symbolic_Traceback --
173 ------------------------
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);
194 if Traceback
'Length = 0 then
200 -- Since image computation is not thread-safe we need task lockout
202 System
.Soft_Links
.Lock_Task
.all;
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);
210 for J
in Traceback
'Range loop
212 (PC_For
(Traceback
(J
)),
213 Filename_Dsc
'Address,
215 Record_Number
'Address,
220 Relative_PC
'Address);
223 First
: Integer := Len
+ 1;
224 Last
: Integer := First
+ 80 - 1;
227 Routine_Name_D
: String :=
230 (1 .. Natural (Routine_Name
.Curlen
)));
233 Res
(First
.. Last
) := (others => ' ');
235 Res
(First
.. First
+ Natural (Image_Name
.Curlen
) - 1) :=
236 Image_Name
.Buf
(1 .. Natural (Image_Name
.Curlen
));
239 First
+ 10 + Natural (Module_Name
.Curlen
) - 1) :=
240 Module_Name
.Buf
(1 .. Natural (Module_Name
.Curlen
));
243 First
+ 30 + Routine_Name_D
'Length - 1) :=
246 -- If routine name doesn't fit 20 characters, output
247 -- the line number on next line at 50th position
249 if Routine_Name_D
'Length > 20 then
250 Pos
:= First
+ 30 + Routine_Name_D
'Length;
251 Res
(Pos
) := ASCII
.LF
;
253 Res
(Pos
+ 1 .. Last
) := (others => ' ');
260 Pos
+ Integer_64
'Image (Line_Number
)'Length - 1) :=
261 Integer_64
'Image (Line_Number
);
263 Res
(Last
) := ASCII
.LF
;
268 System
.Soft_Links
.Unlock_Task
.all;
269 return Res
(1 .. Len
);
270 end Symbolic_Traceback
;
272 function Symbolic_Traceback
(E
: Exception_Occurrence
) return String is
274 return Symbolic_Traceback
(Tracebacks
(E
));
275 end Symbolic_Traceback
;
277 end GNAT
.Traceback
.Symbolic
;