1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- ADA.EXCEPTIONS.EXCEPTION_DATA --
9 -- Copyright (C) 1992-2005 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 -- This unit implements the Exception_Information related services for
40 -- both the Ada standard requirements and the GNAT.Exception_Traces
43 -- There are common parts between the contents of Exception_Information
44 -- (the regular Ada interface) and Tailored_Exception_Information (what
45 -- the automatic backtracing output includes). The overall structure is
49 -- Exception_Information
53 -- Basic_Exc_Info & Basic_Exc_Tback
57 -- (B_E_I) | Exception_Name: <exception name> (as in Exception_Name)
58 -- | Message: <message> (or a null line if no message)
59 -- | PID=nnnn (if != 0)
61 -- (B_E_TB) | Call stack traceback locations:
62 -- | <0xyyyyyyyy 0xyyyyyyyy ...>
65 -- Tailored_Exception_Information
67 -- +----------+----------+
69 -- Basic_Exc_Info & Tailored_Exc_Tback
71 -- +-----------+------------+
73 -- Basic_Exc_Tback Or Tback_Decorator
74 -- if no decorator set otherwise
76 -- Functions returning String imply secondary stack use, which is a heavy
77 -- mechanism requiring run-time support. Besides, some of the routines we
78 -- provide here are to be used by the default Last_Chance_Handler, at the
79 -- critical point where the runtime is about to be finalized. Since most
80 -- of the items we have at hand are of bounded length, we also provide a
81 -- procedural interface able to incrementally append the necessary bits to
82 -- a preallocated buffer or output them straight to stderr.
84 -- The procedural interface is composed of two major sections: a neutral
85 -- section for basic types like Address, Character, Natural or String, and
86 -- an exception oriented section for the e.g. Basic_Exception_Information.
87 -- This is the Append_Info family of procedures below.
89 -- Output to stderr is commanded by passing an empty buffer to update, and
90 -- care is taken not to overflow otherwise.
92 --------------------------------------------
93 -- Procedural Interface - Neutral section --
94 --------------------------------------------
96 procedure Append_Info_Address
99 Ptr
: in out Natural);
101 procedure Append_Info_Character
103 Info
: in out String;
104 Ptr
: in out Natural);
106 procedure Append_Info_Nat
108 Info
: in out String;
109 Ptr
: in out Natural);
111 procedure Append_Info_NL
112 (Info
: in out String;
113 Ptr
: in out Natural);
114 pragma Inline
(Append_Info_NL
);
116 procedure Append_Info_String
118 Info
: in out String;
119 Ptr
: in out Natural);
121 -------------------------------------------------------
122 -- Procedural Interface - Exception oriented section --
123 -------------------------------------------------------
125 procedure Append_Info_Exception_Name
127 Info
: in out String;
128 Ptr
: in out Natural);
130 procedure Append_Info_Exception_Name
131 (X
: Exception_Occurrence
;
132 Info
: in out String;
133 Ptr
: in out Natural);
135 procedure Append_Info_Exception_Message
136 (X
: Exception_Occurrence
;
137 Info
: in out String;
138 Ptr
: in out Natural);
140 procedure Append_Info_Basic_Exception_Information
141 (X
: Exception_Occurrence
;
142 Info
: in out String;
143 Ptr
: in out Natural);
145 procedure Append_Info_Basic_Exception_Traceback
146 (X
: Exception_Occurrence
;
147 Info
: in out String;
148 Ptr
: in out Natural);
150 procedure Append_Info_Exception_Information
151 (X
: Exception_Occurrence
;
152 Info
: in out String;
153 Ptr
: in out Natural);
155 -- The "functional" interface to the exception information not involving
156 -- a traceback decorator uses preallocated intermediate buffers to avoid
157 -- the use of secondary stack. Preallocation requires preliminary length
158 -- computation, for which a series of functions are introduced:
160 ---------------------------------
161 -- Length evaluation utilities --
162 ---------------------------------
164 function Basic_Exception_Info_Maxlength
165 (X
: Exception_Occurrence
) return Natural;
167 function Basic_Exception_Tback_Maxlength
168 (X
: Exception_Occurrence
) return Natural;
170 function Exception_Info_Maxlength
171 (X
: Exception_Occurrence
) return Natural;
173 function Exception_Name_Length
174 (Id
: Exception_Id
) return Natural;
176 function Exception_Name_Length
177 (X
: Exception_Occurrence
) return Natural;
179 function Exception_Message_Length
180 (X
: Exception_Occurrence
) return Natural;
182 --------------------------
183 -- Functional Interface --
184 --------------------------
186 function Basic_Exception_Traceback
187 (X
: Exception_Occurrence
) return String;
188 -- Returns an image of the complete call chain associated with an
189 -- exception occurence in its most basic form, that is as a raw sequence
190 -- of hexadecimal binary addresses.
192 function Tailored_Exception_Traceback
193 (X
: Exception_Occurrence
) return String;
194 -- Returns an image of the complete call chain associated with an
195 -- exception occurrence, either in its basic form if no decorator is
196 -- in place, or as formatted by the decorator otherwise.
198 -----------------------------------------------------------------------
199 -- Services for the default Last_Chance_Handler and the task wrapper --
200 -----------------------------------------------------------------------
203 (Ada
, Append_Info_Exception_Message
, "__gnat_append_info_e_msg");
206 (Ada
, Append_Info_Exception_Information
, "__gnat_append_info_e_info");
209 (Ada
, Exception_Message_Length
, "__gnat_exception_msg_len");
211 -------------------------
212 -- Append_Info_Address --
213 -------------------------
215 procedure Append_Info_Address
217 Info
: in out String;
218 Ptr
: in out Natural)
220 S
: String (1 .. 18);
224 H
: constant array (Integer range 0 .. 15) of Character :=
230 S
(P
) := H
(Integer (N
mod 16));
239 Append_Info_String
(S
(P
- 1 .. S
'Last), Info
, Ptr
);
240 end Append_Info_Address
;
242 ---------------------------
243 -- Append_Info_Character --
244 ---------------------------
246 procedure Append_Info_Character
248 Info
: in out String;
249 Ptr
: in out Natural)
252 if Info
'Length = 0 then
254 elsif Ptr
< Info
'Last then
258 end Append_Info_Character
;
260 ---------------------
261 -- Append_Info_Nat --
262 ---------------------
264 procedure Append_Info_Nat
266 Info
: in out String;
267 Ptr
: in out Natural)
271 Append_Info_Nat
(N
/ 10, Info
, Ptr
);
274 Append_Info_Character
275 (Character'Val (Character'Pos ('0') + N
mod 10), Info
, Ptr
);
282 procedure Append_Info_NL
283 (Info
: in out String;
284 Ptr
: in out Natural)
287 Append_Info_Character
(ASCII
.LF
, Info
, Ptr
);
290 ------------------------
291 -- Append_Info_String --
292 ------------------------
294 procedure Append_Info_String
296 Info
: in out String;
297 Ptr
: in out Natural)
300 if Info
'Length = 0 then
304 Last
: constant Natural :=
305 Integer'Min (Ptr
+ S
'Length, Info
'Last);
307 Info
(Ptr
+ 1 .. Last
) := S
;
311 end Append_Info_String
;
313 ---------------------------------------------
314 -- Append_Info_Basic_Exception_Information --
315 ---------------------------------------------
317 -- To ease the maximum length computation, we define and pull out a couple
318 -- of string constants:
320 BEI_Name_Header
: constant String := "Exception name: ";
321 BEI_Msg_Header
: constant String := "Message: ";
322 BEI_PID_Header
: constant String := "PID: ";
324 procedure Append_Info_Basic_Exception_Information
325 (X
: Exception_Occurrence
;
326 Info
: in out String;
327 Ptr
: in out Natural)
329 Name
: String (1 .. Exception_Name_Length
(X
));
330 -- Bufer in which to fetch the exception name, in order to check
331 -- whether this is an internal _ABORT_SIGNAL or a regular occurrence.
333 Name_Ptr
: Natural := Name
'First - 1;
336 -- Output exception name and message except for _ABORT_SIGNAL, where
337 -- these two lines are omitted.
339 Append_Info_Exception_Name
(X
, Name
, Name_Ptr
);
341 if Name
(Name
'First) /= '_' then
342 Append_Info_String
(BEI_Name_Header
, Info
, Ptr
);
343 Append_Info_String
(Name
, Info
, Ptr
);
344 Append_Info_NL
(Info
, Ptr
);
346 if Exception_Message_Length
(X
) /= 0 then
347 Append_Info_String
(BEI_Msg_Header
, Info
, Ptr
);
348 Append_Info_Exception_Message
(X
, Info
, Ptr
);
349 Append_Info_NL
(Info
, Ptr
);
353 -- Output PID line if non-zero
356 Append_Info_String
(BEI_PID_Header
, Info
, Ptr
);
357 Append_Info_Nat
(X
.Pid
, Info
, Ptr
);
358 Append_Info_NL
(Info
, Ptr
);
360 end Append_Info_Basic_Exception_Information
;
362 -------------------------------------------
363 -- Basic_Exception_Information_Maxlength --
364 -------------------------------------------
366 function Basic_Exception_Info_Maxlength
367 (X
: Exception_Occurrence
) return Natural is
370 BEI_Name_Header
'Length + Exception_Name_Length
(X
) + 1
371 + BEI_Msg_Header
'Length + Exception_Message_Length
(X
) + 1
372 + BEI_PID_Header
'Length + 15;
373 end Basic_Exception_Info_Maxlength
;
375 -------------------------------------------
376 -- Append_Info_Basic_Exception_Traceback --
377 -------------------------------------------
379 -- As for Basic_Exception_Information:
381 BETB_Header
: constant String := "Call stack traceback locations:";
383 procedure Append_Info_Basic_Exception_Traceback
384 (X
: Exception_Occurrence
;
385 Info
: in out String;
386 Ptr
: in out Natural)
389 if X
.Num_Tracebacks
<= 0 then
393 Append_Info_String
(BETB_Header
, Info
, Ptr
);
394 Append_Info_NL
(Info
, Ptr
);
396 for J
in 1 .. X
.Num_Tracebacks
loop
397 Append_Info_Address
(TBE
.PC_For
(X
.Tracebacks
(J
)), Info
, Ptr
);
398 exit when J
= X
.Num_Tracebacks
;
399 Append_Info_Character
(' ', Info
, Ptr
);
402 Append_Info_NL
(Info
, Ptr
);
403 end Append_Info_Basic_Exception_Traceback
;
405 -----------------------------------------
406 -- Basic_Exception_Traceback_Maxlength --
407 -----------------------------------------
409 function Basic_Exception_Tback_Maxlength
410 (X
: Exception_Occurrence
) return Natural is
412 return BETB_Header
'Length + 1 + X
.Num_Tracebacks
* 19 + 1;
413 -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
414 end Basic_Exception_Tback_Maxlength
;
416 ---------------------------------------
417 -- Append_Info_Exception_Information --
418 ---------------------------------------
420 procedure Append_Info_Exception_Information
421 (X
: Exception_Occurrence
;
422 Info
: in out String;
423 Ptr
: in out Natural)
426 Append_Info_Basic_Exception_Information
(X
, Info
, Ptr
);
427 Append_Info_Basic_Exception_Traceback
(X
, Info
, Ptr
);
428 end Append_Info_Exception_Information
;
430 ------------------------------
431 -- Exception_Info_Maxlength --
432 ------------------------------
434 function Exception_Info_Maxlength
435 (X
: Exception_Occurrence
) return Natural is
438 Basic_Exception_Info_Maxlength
(X
)
439 + Basic_Exception_Tback_Maxlength
(X
);
440 end Exception_Info_Maxlength
;
442 -----------------------------------
443 -- Append_Info_Exception_Message --
444 -----------------------------------
446 procedure Append_Info_Exception_Message
447 (X
: Exception_Occurrence
;
448 Info
: in out String;
449 Ptr
: in out Natural) is
451 if X
.Id
= Null_Id
then
452 raise Constraint_Error
;
456 Len
: constant Natural := Exception_Message_Length
(X
);
457 Msg
: constant String (1 .. Len
) := X
.Msg
(1 .. Len
);
459 Append_Info_String
(Msg
, Info
, Ptr
);
461 end Append_Info_Exception_Message
;
463 --------------------------------
464 -- Append_Info_Exception_Name --
465 --------------------------------
467 procedure Append_Info_Exception_Name
469 Info
: in out String;
470 Ptr
: in out Natural)
474 raise Constraint_Error
;
478 Len
: constant Natural := Exception_Name_Length
(Id
);
479 Name
: constant String (1 .. Len
) := To_Ptr
(Id
.Full_Name
) (1 .. Len
);
481 Append_Info_String
(Name
, Info
, Ptr
);
483 end Append_Info_Exception_Name
;
485 procedure Append_Info_Exception_Name
486 (X
: Exception_Occurrence
;
487 Info
: in out String;
488 Ptr
: in out Natural)
491 Append_Info_Exception_Name
(X
.Id
, Info
, Ptr
);
492 end Append_Info_Exception_Name
;
494 ---------------------------
495 -- Exception_Name_Length --
496 ---------------------------
498 function Exception_Name_Length
499 (Id
: Exception_Id
) return Natural is
501 -- What is stored in the internal Name buffer includes a terminating
502 -- null character that we never care about.
504 return Id
.Name_Length
- 1;
505 end Exception_Name_Length
;
507 function Exception_Name_Length
508 (X
: Exception_Occurrence
) return Natural is
510 return Exception_Name_Length
(X
.Id
);
511 end Exception_Name_Length
;
513 ------------------------------
514 -- Exception_Message_Length --
515 ------------------------------
517 function Exception_Message_Length
518 (X
: Exception_Occurrence
) return Natural is
521 end Exception_Message_Length
;
523 -------------------------------
524 -- Basic_Exception_Traceback --
525 -------------------------------
527 function Basic_Exception_Traceback
528 (X
: Exception_Occurrence
) return String
530 Info
: aliased String (1 .. Basic_Exception_Tback_Maxlength
(X
));
531 Ptr
: Natural := Info
'First - 1;
534 Append_Info_Basic_Exception_Traceback
(X
, Info
, Ptr
);
535 return Info
(Info
'First .. Ptr
);
536 end Basic_Exception_Traceback
;
538 ---------------------------
539 -- Exception_Information --
540 ---------------------------
542 function Exception_Information
543 (X
: Exception_Occurrence
) return String
545 Info
: String (1 .. Exception_Info_Maxlength
(X
));
546 Ptr
: Natural := Info
'First - 1;
549 Append_Info_Exception_Information
(X
, Info
, Ptr
);
550 return Info
(Info
'First .. Ptr
);
551 end Exception_Information
;
553 -------------------------
554 -- Set_Exception_C_Msg --
555 -------------------------
557 procedure Set_Exception_C_Msg
559 Msg1
: System
.Address
;
561 Msg2
: System
.Address
:= System
.Null_Address
)
563 Excep
: constant EOA
:= Get_Current_Excep
.all;
564 Val
: Integer := Line
;
570 Exception_Propagation
.Setup_Exception
(Excep
, Excep
);
571 Excep
.Exception_Raised
:= False;
573 Excep
.Num_Tracebacks
:= 0;
574 Excep
.Pid
:= Local_Partition_ID
;
575 Excep
.Msg_Length
:= 0;
576 Excep
.Cleanup_Flag
:= False;
578 while To_Ptr
(Msg1
) (Excep
.Msg_Length
+ 1) /= ASCII
.NUL
579 and then Excep
.Msg_Length
< Exception_Msg_Max_Length
581 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
582 Excep
.Msg
(Excep
.Msg_Length
) := To_Ptr
(Msg1
) (Excep
.Msg_Length
);
585 -- Append line number if present
589 -- Compute the number of needed characters
596 -- If enough characters are available, put the line number
598 if Excep
.Msg_Length
<= Exception_Msg_Max_Length
- Size
then
599 Excep
.Msg
(Excep
.Msg_Length
+ 1) := ':';
600 Excep
.Msg_Length
:= Excep
.Msg_Length
+ Size
;
605 Remind
:= Val
rem 10;
607 Excep
.Msg
(Excep
.Msg_Length
- Size
) :=
608 Character'Val (Remind
+ Character'Pos ('0'));
614 -- Append second message if present
616 if Msg2
/= System
.Null_Address
617 and then Excep
.Msg_Length
+ 1 < Exception_Msg_Max_Length
619 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
620 Excep
.Msg
(Excep
.Msg_Length
) := ' ';
623 while To_Ptr
(Msg2
) (Ptr
) /= ASCII
.NUL
624 and then Excep
.Msg_Length
< Exception_Msg_Max_Length
626 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
627 Excep
.Msg
(Excep
.Msg_Length
) := To_Ptr
(Msg2
) (Ptr
);
631 end Set_Exception_C_Msg
;
633 -----------------------
634 -- Set_Exception_Msg --
635 -----------------------
637 procedure Set_Exception_Msg
641 Len
: constant Natural :=
642 Natural'Min (Message
'Length, Exception_Msg_Max_Length
);
643 First
: constant Integer := Message
'First;
644 Excep
: constant EOA
:= Get_Current_Excep
.all;
647 Exception_Propagation
.Setup_Exception
(Excep
, Excep
);
648 Excep
.Exception_Raised
:= False;
649 Excep
.Msg_Length
:= Len
;
650 Excep
.Msg
(1 .. Len
) := Message
(First
.. First
+ Len
- 1);
652 Excep
.Num_Tracebacks
:= 0;
653 Excep
.Pid
:= Local_Partition_ID
;
654 Excep
.Cleanup_Flag
:= False;
656 end Set_Exception_Msg
;
658 ----------------------------------
659 -- Tailored_Exception_Traceback --
660 ----------------------------------
662 function Tailored_Exception_Traceback
663 (X
: Exception_Occurrence
) return String
665 -- We reference the decorator *wrapper* here and not the decorator
666 -- itself. The purpose of the local variable Wrapper is to prevent a
667 -- potential race condition in the code below. The atomicity of this
668 -- assignment is enforced by pragma Atomic in System.Soft_Links.
670 -- The potential race condition here, if no local variable was used,
671 -- relates to the test upon the wrapper's value and the call, which
672 -- are not performed atomically. With the local variable, potential
673 -- changes of the wrapper's global value between the test and the
674 -- call become inoffensive.
676 Wrapper
: constant Traceback_Decorator_Wrapper_Call
:=
677 Traceback_Decorator_Wrapper
;
680 if Wrapper
= null then
681 return Basic_Exception_Traceback
(X
);
683 return Wrapper
.all (X
.Tracebacks
'Address, X
.Num_Tracebacks
);
685 end Tailored_Exception_Traceback
;
687 ------------------------------------
688 -- Tailored_Exception_Information --
689 ------------------------------------
691 function Tailored_Exception_Information
692 (X
: Exception_Occurrence
) return String
694 -- The tailored exception information is the basic information
695 -- associated with the tailored call chain backtrace.
697 Tback_Info
: constant String := Tailored_Exception_Traceback
(X
);
698 Tback_Len
: constant Natural := Tback_Info
'Length;
700 Info
: String (1 .. Basic_Exception_Info_Maxlength
(X
) + Tback_Len
);
701 Ptr
: Natural := Info
'First - 1;
704 Append_Info_Basic_Exception_Information
(X
, Info
, Ptr
);
705 Append_Info_String
(Tback_Info
, Info
, Ptr
);
706 return Info
(Info
'First .. Ptr
);
707 end Tailored_Exception_Information
;