1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- ADA.EXCEPTIONS.EXCEPTION_DATA --
9 -- Copyright (C) 1992-2003 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 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with System
.Storage_Elements
; use System
.Storage_Elements
;
36 separate (Ada
.Exceptions
)
37 package body Exception_Data
is
39 -----------------------
40 -- Local Subprograms --
41 -----------------------
43 function Address_Image
(A
: System
.Address
) return String;
44 -- Returns at string of the form 0xhhhhhhhhh for an address, with
45 -- leading zeros suppressed. Hex characters a-f are in lower case.
47 procedure Append_Info_Nat
50 Ptr
: in out Natural);
51 -- Append the image of N at the end of the provided information string
53 procedure Append_Info_NL
54 (Info
: in out String;
55 Ptr
: in out Natural);
56 -- Append a LF at the end of the provided information string
58 procedure Append_Info_String
61 Ptr
: in out Natural);
62 -- Append a string at the end of the provided information string
64 -- To build Exception_Information and Tailored_Exception_Information,
65 -- we then use three intermediate functions :
67 function Basic_Exception_Information
68 (X
: Exception_Occurrence
) return String;
69 -- Returns the basic exception information string associated with a
70 -- given exception occurrence. This is the common part shared by both
71 -- Exception_Information and Tailored_Exception_Infomation.
73 function Basic_Exception_Traceback
74 (X
: Exception_Occurrence
) return String;
75 -- Returns an image of the complete call chain associated with an
76 -- exception occurence in its most basic form, that is as a raw sequence
77 -- of hexadecimal binary addresses.
79 function Tailored_Exception_Traceback
80 (X
: Exception_Occurrence
) return String;
81 -- Returns an image of the complete call chain associated with an
82 -- exception occurrence, either in its basic form if no decorator is
83 -- in place, or as formatted by the decorator otherwise.
85 -- The overall organization of the exception information related code
86 -- is summarized below :
88 -- Exception_Information
92 -- Basic_Exc_Info & Basic_Exc_Tback
95 -- Tailored_Exception_Information
97 -- +----------+----------+
99 -- Basic_Exc_Info & Tailored_Exc_Tback
101 -- +-----------+------------+
103 -- Basic_Exc_Tback Or Tback_Decorator
104 -- if no decorator set otherwise
110 function Address_Image
(A
: Address
) return String is
111 S
: String (1 .. 18);
115 H
: constant array (Integer range 0 .. 15) of Character :=
121 S
(P
) := H
(Integer (N
mod 16));
129 return S
(P
- 1 .. S
'Last);
132 ---------------------
133 -- Append_Info_Nat --
134 ---------------------
136 procedure Append_Info_Nat
138 Info
: in out String;
139 Ptr
: in out Natural)
143 Append_Info_Nat
(N
/ 10, Info
, Ptr
);
147 Info
(Ptr
) := Character'Val (Character'Pos ('0') + N
mod 10);
154 procedure Append_Info_NL
155 (Info
: in out String;
156 Ptr
: in out Natural)
160 Info
(Ptr
) := ASCII
.LF
;
163 ------------------------
164 -- Append_Info_String --
165 ------------------------
167 procedure Append_Info_String
169 Info
: in out String;
170 Ptr
: in out Natural)
172 Last
: constant Natural := Integer'Min (Ptr
+ S
'Length, Info
'Last);
175 Info
(Ptr
+ 1 .. Last
) := S
;
177 end Append_Info_String
;
179 ---------------------------------
180 -- Basic_Exception_Information --
181 ---------------------------------
183 function Basic_Exception_Information
184 (X
: Exception_Occurrence
) return String
186 Name
: constant String := Exception_Name
(X
);
187 Msg
: constant String := Exception_Message
(X
);
188 -- Exception name and message that are going to be included in the
189 -- information to return, if not empty.
191 Name_Len
: constant Natural := Name
'Length;
192 Msg_Len
: constant Natural := Msg
'Length;
193 -- Length of these strings, useful to compute the size of the string
194 -- we have to allocate for the complete result as well as in the body
195 -- of this procedure.
197 Info_Maxlen
: constant Natural := 50 + Name_Len
+ Msg_Len
;
198 -- Maximum length of the information string we will build, with :
200 -- 50 = 16 + 2 for the text associated with the name
201 -- + 9 + 2 for the text associated with the message
202 -- + 5 + 2 for the text associated with the pid
203 -- + 14 for the text image of the pid itself and a margin.
205 -- This is indeed a maximum since some data may not appear at all if
206 -- not relevant. For example, nothing related to the exception message
207 -- will be there if this message is empty.
209 -- WARNING : Do not forget to update these numbers if anything
210 -- involved in the computation changes.
212 Info
: String (1 .. Info_Maxlen
);
213 -- Information string we are going to build, containing the common
214 -- part shared by Exc_Info and Tailored_Exc_Info.
219 -- Output exception name and message except for _ABORT_SIGNAL, where
220 -- these two lines are omitted (see discussion above).
222 if Name
(1) /= '_' then
223 Append_Info_String
("Exception name: ", Info
, Ptr
);
224 Append_Info_String
(Name
, Info
, Ptr
);
225 Append_Info_NL
(Info
, Ptr
);
228 Append_Info_String
("Message: ", Info
, Ptr
);
229 Append_Info_String
(Msg
, Info
, Ptr
);
230 Append_Info_NL
(Info
, Ptr
);
234 -- Output PID line if non-zero
237 Append_Info_String
("PID: ", Info
, Ptr
);
238 Append_Info_Nat
(X
.Pid
, Info
, Ptr
);
239 Append_Info_NL
(Info
, Ptr
);
242 return Info
(1 .. Ptr
);
243 end Basic_Exception_Information
;
245 -------------------------------
246 -- Basic_Exception_Traceback --
247 -------------------------------
249 function Basic_Exception_Traceback
250 (X
: Exception_Occurrence
) return String
252 Info_Maxlen
: constant Natural := 35 + X
.Num_Tracebacks
* 19;
253 -- Maximum length of the information string we are building, with :
254 -- 33 = 31 + 4 for the text before and after the traceback, and
255 -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
257 -- WARNING : Do not forget to update these numbers if anything
258 -- involved in the computation changes.
260 Info
: String (1 .. Info_Maxlen
);
261 -- Information string we are going to build, containing an image
262 -- of the call chain associated with the exception occurrence in its
263 -- most basic form, that is as a sequence of binary addresses.
268 if X
.Num_Tracebacks
> 0 then
269 Append_Info_String
("Call stack traceback locations:", Info
, Ptr
);
270 Append_Info_NL
(Info
, Ptr
);
272 for J
in 1 .. X
.Num_Tracebacks
loop
274 (Address_Image
(TBE
.PC_For
(X
.Tracebacks
(J
))), Info
, Ptr
);
275 exit when J
= X
.Num_Tracebacks
;
276 Append_Info_String
(" ", Info
, Ptr
);
279 Append_Info_NL
(Info
, Ptr
);
282 return Info
(1 .. Ptr
);
283 end Basic_Exception_Traceback
;
285 ---------------------------
286 -- Exception_Information --
287 ---------------------------
289 -- The format of the string is:
291 -- Exception_Name: nnnnn
294 -- Call stack traceback locations:
295 -- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh
299 -- nnnn is the fully qualified name of the exception in all upper
300 -- case letters. This line is always present.
302 -- mmmm is the message (this line present only if message is non-null)
304 -- ppp is the Process Id value as a decimal integer (this line is
305 -- present only if the Process Id is non-zero). Currently we are
306 -- not making use of this field.
308 -- The Call stack traceback locations line and the following values
309 -- are present only if at least one traceback location was recorded.
310 -- the values are given in C style format, with lower case letters
311 -- for a-f, and only as many digits present as are necessary.
313 -- The line terminator sequence at the end of each line, including the
314 -- last line is a CR-LF sequence (16#0D# followed by 16#0A#).
316 -- The Exception_Name and Message lines are omitted in the abort
317 -- signal case, since this is not really an exception, and the only
318 -- use of this routine is internal for printing termination output.
320 -- WARNING: if the format of the generated string is changed, please note
321 -- that an equivalent modification to the routine String_To_EO must be
322 -- made to preserve proper functioning of the stream attributes.
324 function Exception_Information
(X
: Exception_Occurrence
) return String is
326 -- This information is now built using the circuitry introduced in
327 -- association with the support of traceback decorators, as the
328 -- catenation of the exception basic information and the call chain
329 -- backtrace in its basic form.
331 Basic_Info
: constant String := Basic_Exception_Information
(X
);
332 Tback_Info
: constant String := Basic_Exception_Traceback
(X
);
334 Basic_Len
: constant Natural := Basic_Info
'Length;
335 Tback_Len
: constant Natural := Tback_Info
'Length;
337 Info
: String (1 .. Basic_Len
+ Tback_Len
);
341 Append_Info_String
(Basic_Info
, Info
, Ptr
);
342 Append_Info_String
(Tback_Info
, Info
, Ptr
);
345 end Exception_Information
;
348 -------------------------
349 -- Set_Exception_C_Msg --
350 -------------------------
352 procedure Set_Exception_C_Msg
354 Msg1
: Big_String_Ptr
;
356 Msg2
: Big_String_Ptr
:= null)
358 Excep
: constant EOA
:= Get_Current_Excep
.all;
359 Val
: Integer := Line
;
365 Exception_Propagation
.Setup_Exception
(Excep
, Excep
);
366 Excep
.Exception_Raised
:= False;
368 Excep
.Num_Tracebacks
:= 0;
369 Excep
.Pid
:= Local_Partition_ID
;
370 Excep
.Msg_Length
:= 0;
371 Excep
.Cleanup_Flag
:= False;
373 while Msg1
(Excep
.Msg_Length
+ 1) /= ASCII
.NUL
374 and then Excep
.Msg_Length
< Exception_Msg_Max_Length
376 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
377 Excep
.Msg
(Excep
.Msg_Length
) := Msg1
(Excep
.Msg_Length
);
380 -- Append line number if present
384 -- Compute the number of needed characters
391 -- If enough characters are available, put the line number
393 if Excep
.Msg_Length
<= Exception_Msg_Max_Length
- Size
then
394 Excep
.Msg
(Excep
.Msg_Length
+ 1) := ':';
395 Excep
.Msg_Length
:= Excep
.Msg_Length
+ Size
;
400 Remind
:= Val
rem 10;
402 Excep
.Msg
(Excep
.Msg_Length
- Size
) :=
403 Character'Val (Remind
+ Character'Pos ('0'));
409 -- Append second message if present
412 and then Excep
.Msg_Length
+ 1 < Exception_Msg_Max_Length
414 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
415 Excep
.Msg
(Excep
.Msg_Length
) := ' ';
418 while Msg2
(Ptr
) /= ASCII
.NUL
419 and then Excep
.Msg_Length
< Exception_Msg_Max_Length
421 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
422 Excep
.Msg
(Excep
.Msg_Length
) := Msg2
(Ptr
);
426 end Set_Exception_C_Msg
;
428 -----------------------
429 -- Set_Exception_Msg --
430 -----------------------
432 procedure Set_Exception_Msg
436 Len
: constant Natural :=
437 Natural'Min (Message
'Length, Exception_Msg_Max_Length
);
438 First
: constant Integer := Message
'First;
439 Excep
: constant EOA
:= Get_Current_Excep
.all;
442 Exception_Propagation
.Setup_Exception
(Excep
, Excep
);
443 Excep
.Exception_Raised
:= False;
444 Excep
.Msg_Length
:= Len
;
445 Excep
.Msg
(1 .. Len
) := Message
(First
.. First
+ Len
- 1);
447 Excep
.Num_Tracebacks
:= 0;
448 Excep
.Pid
:= Local_Partition_ID
;
449 Excep
.Cleanup_Flag
:= False;
451 end Set_Exception_Msg
;
453 ----------------------------------
454 -- Tailored_Exception_Traceback --
455 ----------------------------------
457 function Tailored_Exception_Traceback
458 (X
: Exception_Occurrence
) return String
460 -- We indeed reference the decorator *wrapper* from here and not the
461 -- decorator itself. The purpose of the local variable Wrapper is to
462 -- prevent a potential crash by race condition in the code below. The
463 -- atomicity of this assignment is enforced by pragma Atomic in
464 -- System.Soft_Links.
466 -- The potential race condition here, if no local variable was used,
467 -- relates to the test upon the wrapper's value and the call, which
468 -- are not performed atomically. With the local variable, potential
469 -- changes of the wrapper's global value between the test and the
470 -- call become inoffensive.
472 Wrapper
: constant Traceback_Decorator_Wrapper_Call
:=
473 Traceback_Decorator_Wrapper
;
476 if Wrapper
= null then
477 return Basic_Exception_Traceback
(X
);
479 return Wrapper
.all (X
.Tracebacks
'Address, X
.Num_Tracebacks
);
481 end Tailored_Exception_Traceback
;
483 ------------------------------------
484 -- Tailored_Exception_Information --
485 ------------------------------------
487 function Tailored_Exception_Information
488 (X
: Exception_Occurrence
) return String
490 -- The tailored exception information is simply the basic information
491 -- associated with the tailored call chain backtrace.
493 Basic_Info
: constant String := Basic_Exception_Information
(X
);
494 Tback_Info
: constant String := Tailored_Exception_Traceback
(X
);
496 Basic_Len
: constant Natural := Basic_Info
'Length;
497 Tback_Len
: constant Natural := Tback_Info
'Length;
499 Info
: String (1 .. Basic_Len
+ Tback_Len
);
503 Append_Info_String
(Basic_Info
, Info
, Ptr
);
504 Append_Info_String
(Tback_Info
, Info
, Ptr
);
507 end Tailored_Exception_Information
;
509 procedure Tailored_Exception_Information
510 (X
: Exception_Occurrence
;
511 Buff
: in out String;
512 Last
: in out Integer)
515 Append_Info_String
(Basic_Exception_Information
(X
), Buff
, Last
);
516 Append_Info_String
(Tailored_Exception_Traceback
(X
), Buff
, Last
);
517 end Tailored_Exception_Information
;