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 32-bit addresses
45 -- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are
48 procedure Append_Info_Nat
51 Ptr : in out Natural);
52 -- Append the image of N at the end of the provided information string
54 procedure Append_Info_NL
55 (Info : in out String;
56 Ptr : in out Natural);
57 -- Append a LF at the end of the provided information string
59 procedure Append_Info_String
62 Ptr : in out Natural);
63 -- Append a string at the end of the provided information string
65 -- To build Exception_Information and Tailored_Exception_Information,
66 -- we then use three intermediate functions :
68 function Basic_Exception_Information
69 (X : Exception_Occurrence)
71 -- Returns the basic exception information string associated with a
72 -- given exception occurrence. This is the common part shared by both
73 -- Exception_Information and Tailored_Exception_Infomation.
75 function Basic_Exception_Traceback
76 (X : Exception_Occurrence)
78 -- Returns an image of the complete call chain associated with an
79 -- exception occurence in its most basic form, that is as a raw sequence
80 -- of hexadecimal binary addresses.
82 function Tailored_Exception_Traceback
83 (X : Exception_Occurrence)
85 -- Returns an image of the complete call chain associated with an
86 -- exception occurrence, either in its basic form if no decorator is
87 -- in place, or as formatted by the decorator otherwise.
89 -- The overall organization of the exception information related code
90 -- is summarized below :
92 -- Exception_Information
96 -- Basic_Exc_Info & Basic_Exc_Tback
99 -- Tailored_Exception_Information
101 -- +----------+----------+
103 -- Basic_Exc_Info & Tailored_Exc_Tback
105 -- +-----------+------------+
107 -- Basic_Exc_Tback Or Tback_Decorator
108 -- if no decorator set otherwise
114 function Address_Image (A : Address) return String is
115 S : String (1 .. 18);
119 H : constant array (Integer range 0 .. 15) of Character :=
125 S (P) := H (Integer (N mod 16));
132 return S (P - 1 .. S'Last);
135 ---------------------
136 -- Append_Info_Nat --
137 ---------------------
139 procedure Append_Info_Nat
141 Info : in out String;
142 Ptr : in out Natural)
146 Append_Info_Nat (N / 10, Info, Ptr);
150 Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10);
157 procedure Append_Info_NL
158 (Info : in out String;
159 Ptr : in out Natural)
163 Info (Ptr) := ASCII.LF;
166 ------------------------
167 -- Append_Info_String --
168 ------------------------
170 procedure Append_Info_String
172 Info : in out String;
173 Ptr : in out Natural)
175 Last : constant Natural := Integer'Min (Ptr + S'Length, Info'Last);
178 Info (Ptr + 1 .. Last) := S;
180 end Append_Info_String;
182 ---------------------------------
183 -- Basic_Exception_Information --
184 ---------------------------------
186 function Basic_Exception_Information
187 (X : Exception_Occurrence)
190 Name : constant String := Exception_Name (X);
191 Msg : constant String := Exception_Message (X);
192 -- Exception name and message that are going to be included in the
193 -- information to return, if not empty.
195 Name_Len : constant Natural := Name'Length;
196 Msg_Len : constant Natural := Msg'Length;
197 -- Length of these strings, useful to compute the size of the string
198 -- we have to allocate for the complete result as well as in the body
199 -- of this procedure.
201 Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len;
202 -- Maximum length of the information string we will build, with :
204 -- 50 = 16 + 2 for the text associated with the name
205 -- + 9 + 2 for the text associated with the message
206 -- + 5 + 2 for the text associated with the pid
207 -- + 14 for the text image of the pid itself and a margin.
209 -- This is indeed a maximum since some data may not appear at all if
210 -- not relevant. For example, nothing related to the exception message
211 -- will be there if this message is empty.
213 -- WARNING : Do not forget to update these numbers if anything
214 -- involved in the computation changes.
216 Info : String (1 .. Info_Maxlen);
217 -- Information string we are going to build, containing the common
218 -- part shared by Exc_Info and Tailored_Exc_Info.
223 -- Output exception name and message except for _ABORT_SIGNAL, where
224 -- these two lines are omitted (see discussion above).
226 if Name (1) /= '_' then
227 Append_Info_String ("Exception name: ", Info, Ptr);
228 Append_Info_String (Name, Info, Ptr);
229 Append_Info_NL (Info, Ptr);
232 Append_Info_String ("Message: ", Info, Ptr);
233 Append_Info_String (Msg, Info, Ptr);
234 Append_Info_NL (Info, Ptr);
238 -- Output PID line if non-zero
241 Append_Info_String ("PID: ", Info, Ptr);
242 Append_Info_Nat (X.Pid, Info, Ptr);
243 Append_Info_NL (Info, Ptr);
246 return Info (1 .. Ptr);
247 end Basic_Exception_Information;
249 -------------------------------
250 -- Basic_Exception_Traceback --
251 -------------------------------
253 function Basic_Exception_Traceback
254 (X : Exception_Occurrence)
257 Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
258 -- Maximum length of the information string we are building, with :
259 -- 33 = 31 + 4 for the text before and after the traceback, and
260 -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
262 -- WARNING : Do not forget to update these numbers if anything
263 -- involved in the computation changes.
265 Info : String (1 .. Info_Maxlen);
266 -- Information string we are going to build, containing an image
267 -- of the call chain associated with the exception occurrence in its
268 -- most basic form, that is as a sequence of binary addresses.
273 if X.Num_Tracebacks > 0 then
274 Append_Info_String ("Call stack traceback locations:", Info, Ptr);
275 Append_Info_NL (Info, Ptr);
277 for J in 1 .. X.Num_Tracebacks loop
279 (Address_Image (TBE.PC_For (X.Tracebacks (J))), Info, Ptr);
280 exit when J = X.Num_Tracebacks;
281 Append_Info_String (" ", Info, Ptr);
284 Append_Info_NL (Info, Ptr);
287 return Info (1 .. Ptr);
288 end Basic_Exception_Traceback;
290 ---------------------------
291 -- Exception_Information --
292 ---------------------------
294 -- The format of the string is:
296 -- Exception_Name: nnnnn
299 -- Call stack traceback locations:
300 -- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh
304 -- nnnn is the fully qualified name of the exception in all upper
305 -- case letters. This line is always present.
307 -- mmmm is the message (this line present only if message is non-null)
309 -- ppp is the Process Id value as a decimal integer (this line is
310 -- present only if the Process Id is non-zero). Currently we are
311 -- not making use of this field.
313 -- The Call stack traceback locations line and the following values
314 -- are present only if at least one traceback location was recorded.
315 -- the values are given in C style format, with lower case letters
316 -- for a-f, and only as many digits present as are necessary.
318 -- The line terminator sequence at the end of each line, including the
319 -- last line is a CR-LF sequence (16#0D# followed by 16#0A#).
321 -- The Exception_Name and Message lines are omitted in the abort
322 -- signal case, since this is not really an exception, and the only
323 -- use of this routine is internal for printing termination output.
325 -- WARNING: if the format of the generated string is changed, please note
326 -- that an equivalent modification to the routine String_To_EO must be
327 -- made to preserve proper functioning of the stream attributes.
329 function Exception_Information (X : Exception_Occurrence) return String is
331 -- This information is now built using the circuitry introduced in
332 -- association with the support of traceback decorators, as the
333 -- catenation of the exception basic information and the call chain
334 -- backtrace in its basic form.
336 Basic_Info : constant String := Basic_Exception_Information (X);
337 Tback_Info : constant String := Basic_Exception_Traceback (X);
339 Basic_Len : constant Natural := Basic_Info'Length;
340 Tback_Len : constant Natural := Tback_Info'Length;
342 Info : String (1 .. Basic_Len + Tback_Len);
346 Append_Info_String (Basic_Info, Info, Ptr);
347 Append_Info_String (Tback_Info, Info, Ptr);
350 end Exception_Information;
353 -------------------------
354 -- Set_Exception_C_Msg --
355 -------------------------
357 procedure Set_Exception_C_Msg
359 Msg1 : Big_String_Ptr;
361 Msg2 : Big_String_Ptr := null)
363 Excep : constant EOA := Get_Current_Excep.all;
364 Val : Integer := Line;
370 Exception_Propagation.Setup_Exception (Excep, Excep);
371 Excep.Exception_Raised := False;
373 Excep.Num_Tracebacks := 0;
374 Excep.Pid := Local_Partition_ID;
375 Excep.Msg_Length := 0;
376 Excep.Cleanup_Flag := False;
378 while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL
379 and then Excep.Msg_Length < Exception_Msg_Max_Length
381 Excep.Msg_Length := Excep.Msg_Length + 1;
382 Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length);
385 -- Append line number if present
389 -- Compute the number of needed characters
396 -- If enough characters are available, put the line number
398 if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
399 Excep.Msg (Excep.Msg_Length + 1) := ':';
400 Excep.Msg_Length := Excep.Msg_Length + Size;
405 Remind := Val rem 10;
407 Excep.Msg (Excep.Msg_Length - Size) :=
408 Character'Val (Remind + Character'Pos ('0'));
414 -- Append second message if present
417 and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
419 Excep.Msg_Length := Excep.Msg_Length + 1;
420 Excep.Msg (Excep.Msg_Length) := ' ';
423 while Msg2 (Ptr) /= ASCII.NUL
424 and then Excep.Msg_Length < Exception_Msg_Max_Length
426 Excep.Msg_Length := Excep.Msg_Length + 1;
427 Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr);
431 end Set_Exception_C_Msg;
433 -----------------------
434 -- Set_Exception_Msg --
435 -----------------------
437 procedure Set_Exception_Msg
441 Len : constant Natural :=
442 Natural'Min (Message'Length, Exception_Msg_Max_Length);
443 First : constant Integer := Message'First;
444 Excep : constant EOA := Get_Current_Excep.all;
447 Exception_Propagation.Setup_Exception (Excep, Excep);
448 Excep.Exception_Raised := False;
449 Excep.Msg_Length := Len;
450 Excep.Msg (1 .. Len) := Message (First .. First + Len - 1);
452 Excep.Num_Tracebacks := 0;
453 Excep.Pid := Local_Partition_ID;
454 Excep.Cleanup_Flag := False;
456 end Set_Exception_Msg;
458 ----------------------------------
459 -- Tailored_Exception_Traceback --
460 ----------------------------------
462 function Tailored_Exception_Traceback
463 (X : Exception_Occurrence)
466 -- We indeed reference the decorator *wrapper* from here and not the
467 -- decorator itself. The purpose of the local variable Wrapper is to
468 -- prevent a potential crash by race condition in the code below. The
469 -- atomicity of this assignment is enforced by pragma Atomic in
470 -- System.Soft_Links.
472 -- The potential race condition here, if no local variable was used,
473 -- relates to the test upon the wrapper's value and the call, which
474 -- are not performed atomically. With the local variable, potential
475 -- changes of the wrapper's global value between the test and the
476 -- call become inoffensive.
478 Wrapper : constant Traceback_Decorator_Wrapper_Call :=
479 Traceback_Decorator_Wrapper;
482 if Wrapper = null then
483 return Basic_Exception_Traceback (X);
485 return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
487 end Tailored_Exception_Traceback;
489 ------------------------------------
490 -- Tailored_Exception_Information --
491 ------------------------------------
493 function Tailored_Exception_Information
494 (X : Exception_Occurrence)
497 -- The tailored exception information is simply the basic information
498 -- associated with the tailored call chain backtrace.
500 Basic_Info : constant String := Basic_Exception_Information (X);
501 Tback_Info : constant String := Tailored_Exception_Traceback (X);
503 Basic_Len : constant Natural := Basic_Info'Length;
504 Tback_Len : constant Natural := Tback_Info'Length;
506 Info : String (1 .. Basic_Len + Tback_Len);
510 Append_Info_String (Basic_Info, Info, Ptr);
511 Append_Info_String (Tback_Info, Info, Ptr);
514 end Tailored_Exception_Information;
516 procedure Tailored_Exception_Information
517 (X : Exception_Occurrence;
518 Buff : in out String;
519 Last : in out Integer)
522 Append_Info_String (Basic_Exception_Information (X), Buff, Last);
523 Append_Info_String (Tailored_Exception_Traceback (X), Buff, Last);
524 end Tailored_Exception_Information;