1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- ADA.EXCEPTIONS.EXCEPTION_DATA --
9 -- Copyright (C) 1992-2004 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 -- 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);
156 -- The "functional" interface to the exception information not involving
157 -- a traceback decorator uses preallocated intermediate buffers to avoid
158 -- the use of secondary stack. Preallocation requires preliminary length
159 -- computation, for which a series of functions are introduced:
161 ---------------------------------
162 -- Length evaluation utilities --
163 ---------------------------------
165 function Basic_Exception_Info_Maxlength
166 (X
: Exception_Occurrence
) return Natural;
168 function Basic_Exception_Tback_Maxlength
169 (X
: Exception_Occurrence
) return Natural;
171 function Exception_Info_Maxlength
172 (X
: Exception_Occurrence
) return Natural;
174 function Exception_Name_Length
175 (Id
: Exception_Id
) return Natural;
177 function Exception_Name_Length
178 (X
: Exception_Occurrence
) return Natural;
180 function Exception_Message_Length
181 (X
: Exception_Occurrence
) return Natural;
183 --------------------------
184 -- Functional Interface --
185 --------------------------
187 function Basic_Exception_Traceback
188 (X
: Exception_Occurrence
) return String;
189 -- Returns an image of the complete call chain associated with an
190 -- exception occurence in its most basic form, that is as a raw sequence
191 -- of hexadecimal binary addresses.
193 function Tailored_Exception_Traceback
194 (X
: Exception_Occurrence
) return String;
195 -- Returns an image of the complete call chain associated with an
196 -- exception occurrence, either in its basic form if no decorator is
197 -- in place, or as formatted by the decorator otherwise.
199 -----------------------------------------------------------------------
200 -- Services for the default Last_Chance_Handler and the task wrapper --
201 -----------------------------------------------------------------------
204 (Ada
, Append_Info_Exception_Message
, "__gnat_append_info_e_msg");
207 (Ada
, Append_Info_Exception_Information
, "__gnat_append_info_e_info");
210 (Ada
, Exception_Message_Length
, "__gnat_exception_msg_len");
212 -------------------------
213 -- Append_Info_Address --
214 -------------------------
216 procedure Append_Info_Address
218 Info
: in out String;
219 Ptr
: in out Natural)
221 S
: String (1 .. 18);
225 H
: constant array (Integer range 0 .. 15) of Character :=
231 S
(P
) := H
(Integer (N
mod 16));
240 Append_Info_String
(S
(P
- 1 .. S
'Last), Info
, Ptr
);
241 end Append_Info_Address
;
243 ---------------------------
244 -- Append_Info_Character --
245 ---------------------------
247 procedure Append_Info_Character
249 Info
: in out String;
250 Ptr
: in out Natural)
253 if Info
'Length = 0 then
255 elsif Ptr
< Info
'Last then
259 end Append_Info_Character
;
261 ---------------------
262 -- Append_Info_Nat --
263 ---------------------
265 procedure Append_Info_Nat
267 Info
: in out String;
268 Ptr
: in out Natural)
272 Append_Info_Nat
(N
/ 10, Info
, Ptr
);
275 Append_Info_Character
276 (Character'Val (Character'Pos ('0') + N
mod 10), Info
, Ptr
);
283 procedure Append_Info_NL
284 (Info
: in out String;
285 Ptr
: in out Natural)
288 Append_Info_Character
(ASCII
.LF
, Info
, Ptr
);
291 ------------------------
292 -- Append_Info_String --
293 ------------------------
295 procedure Append_Info_String
297 Info
: in out String;
298 Ptr
: in out Natural)
301 if Info
'Length = 0 then
305 Last
: constant Natural :=
306 Integer'Min (Ptr
+ S
'Length, Info
'Last);
308 Info
(Ptr
+ 1 .. Last
) := S
;
312 end Append_Info_String
;
314 ---------------------------------------------
315 -- Append_Info_Basic_Exception_Information --
316 ---------------------------------------------
318 -- To ease the maximum length computation, we define and pull out a couple
319 -- of string constants:
321 BEI_Name_Header
: constant String := "Exception name: ";
322 BEI_Msg_Header
: constant String := "Message: ";
323 BEI_PID_Header
: constant String := "PID: ";
325 procedure Append_Info_Basic_Exception_Information
326 (X
: Exception_Occurrence
;
327 Info
: in out String;
328 Ptr
: in out Natural)
330 Name
: String (1 .. Exception_Name_Length
(X
));
331 -- Bufer in which to fetch the exception name, in order to check
332 -- whether this is an internal _ABORT_SIGNAL or a regular occurrence.
334 Name_Ptr
: Natural := Name
'First - 1;
337 -- Output exception name and message except for _ABORT_SIGNAL, where
338 -- these two lines are omitted.
340 Append_Info_Exception_Name
(X
, Name
, Name_Ptr
);
342 if Name
(Name
'First) /= '_' then
343 Append_Info_String
(BEI_Name_Header
, Info
, Ptr
);
344 Append_Info_String
(Name
, Info
, Ptr
);
345 Append_Info_NL
(Info
, Ptr
);
347 if Exception_Message_Length
(X
) /= 0 then
348 Append_Info_String
(BEI_Msg_Header
, Info
, Ptr
);
349 Append_Info_Exception_Message
(X
, Info
, Ptr
);
350 Append_Info_NL
(Info
, Ptr
);
354 -- Output PID line if non-zero
357 Append_Info_String
(BEI_PID_Header
, Info
, Ptr
);
358 Append_Info_Nat
(X
.Pid
, Info
, Ptr
);
359 Append_Info_NL
(Info
, Ptr
);
361 end Append_Info_Basic_Exception_Information
;
363 -------------------------------------------
364 -- Basic_Exception_Information_Maxlength --
365 -------------------------------------------
367 function Basic_Exception_Info_Maxlength
368 (X
: Exception_Occurrence
) return Natural is
371 BEI_Name_Header
'Length + Exception_Name_Length
(X
) + 1
372 + BEI_Msg_Header
'Length + Exception_Message_Length
(X
) + 1
373 + BEI_PID_Header
'Length + 15;
374 end Basic_Exception_Info_Maxlength
;
376 -------------------------------------------
377 -- Append_Info_Basic_Exception_Traceback --
378 -------------------------------------------
380 -- As for Basic_Exception_Information:
382 BETB_Header
: constant String := "Call stack traceback locations:";
384 procedure Append_Info_Basic_Exception_Traceback
385 (X
: Exception_Occurrence
;
386 Info
: in out String;
387 Ptr
: in out Natural)
390 if X
.Num_Tracebacks
<= 0 then
394 Append_Info_String
(BETB_Header
, Info
, Ptr
);
395 Append_Info_NL
(Info
, Ptr
);
397 for J
in 1 .. X
.Num_Tracebacks
loop
398 Append_Info_Address
(TBE
.PC_For
(X
.Tracebacks
(J
)), Info
, Ptr
);
399 exit when J
= X
.Num_Tracebacks
;
400 Append_Info_Character
(' ', Info
, Ptr
);
403 Append_Info_NL
(Info
, Ptr
);
404 end Append_Info_Basic_Exception_Traceback
;
406 -----------------------------------------
407 -- Basic_Exception_Traceback_Maxlength --
408 -----------------------------------------
410 function Basic_Exception_Tback_Maxlength
411 (X
: Exception_Occurrence
) return Natural is
413 return BETB_Header
'Length + 1 + X
.Num_Tracebacks
* 19 + 1;
414 -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
415 end Basic_Exception_Tback_Maxlength
;
417 ---------------------------------------
418 -- Append_Info_Exception_Information --
419 ---------------------------------------
421 procedure Append_Info_Exception_Information
422 (X
: Exception_Occurrence
;
423 Info
: in out String;
424 Ptr
: in out Natural)
427 Append_Info_Basic_Exception_Information
(X
, Info
, Ptr
);
428 Append_Info_Basic_Exception_Traceback
(X
, Info
, Ptr
);
429 end Append_Info_Exception_Information
;
431 ------------------------------
432 -- Exception_Info_Maxlength --
433 ------------------------------
435 function Exception_Info_Maxlength
436 (X
: Exception_Occurrence
) return Natural is
439 Basic_Exception_Info_Maxlength
(X
)
440 + Basic_Exception_Tback_Maxlength
(X
);
441 end Exception_Info_Maxlength
;
443 -----------------------------------
444 -- Append_Info_Exception_Message --
445 -----------------------------------
447 procedure Append_Info_Exception_Message
448 (X
: Exception_Occurrence
;
449 Info
: in out String;
450 Ptr
: in out Natural) is
452 if X
.Id
= Null_Id
then
453 raise Constraint_Error
;
457 Len
: constant Natural := Exception_Message_Length
(X
);
458 Msg
: constant String (1 .. Len
) := X
.Msg
(1 .. Len
);
460 Append_Info_String
(Msg
, Info
, Ptr
);
462 end Append_Info_Exception_Message
;
464 --------------------------------
465 -- Append_Info_Exception_Name --
466 --------------------------------
468 procedure Append_Info_Exception_Name
470 Info
: in out String;
471 Ptr
: in out Natural)
475 raise Constraint_Error
;
479 Len
: constant Natural := Exception_Name_Length
(Id
);
480 Name
: constant String (1 .. Len
) := Id
.Full_Name
(1 .. Len
);
482 Append_Info_String
(Name
, Info
, Ptr
);
484 end Append_Info_Exception_Name
;
486 procedure Append_Info_Exception_Name
487 (X
: Exception_Occurrence
;
488 Info
: in out String;
489 Ptr
: in out Natural)
492 Append_Info_Exception_Name
(X
.Id
, Info
, Ptr
);
493 end Append_Info_Exception_Name
;
495 ---------------------------
496 -- Exception_Name_Length --
497 ---------------------------
499 function Exception_Name_Length
500 (Id
: Exception_Id
) return Natural is
502 -- What is stored in the internal Name buffer includes a terminating
503 -- null character that we never care about.
505 return Id
.Name_Length
- 1;
506 end Exception_Name_Length
;
508 function Exception_Name_Length
509 (X
: Exception_Occurrence
) return Natural is
511 return Exception_Name_Length
(X
.Id
);
512 end Exception_Name_Length
;
514 ------------------------------
515 -- Exception_Message_Length --
516 ------------------------------
518 function Exception_Message_Length
519 (X
: Exception_Occurrence
) return Natural is
522 end Exception_Message_Length
;
524 -------------------------------
525 -- Basic_Exception_Traceback --
526 -------------------------------
528 function Basic_Exception_Traceback
529 (X
: Exception_Occurrence
) return String
531 Info
: aliased String (1 .. Basic_Exception_Tback_Maxlength
(X
));
532 Ptr
: Natural := Info
'First - 1;
535 Append_Info_Basic_Exception_Traceback
(X
, Info
, Ptr
);
536 return Info
(Info
'First .. Ptr
);
537 end Basic_Exception_Traceback
;
539 ---------------------------
540 -- Exception_Information --
541 ---------------------------
543 function Exception_Information
544 (X
: Exception_Occurrence
) return String
546 Info
: String (1 .. Exception_Info_Maxlength
(X
));
547 Ptr
: Natural := Info
'First - 1;
550 Append_Info_Exception_Information
(X
, Info
, Ptr
);
551 return Info
(Info
'First .. Ptr
);
552 end Exception_Information
;
554 -------------------------
555 -- Set_Exception_C_Msg --
556 -------------------------
558 procedure Set_Exception_C_Msg
560 Msg1
: Big_String_Ptr
;
562 Msg2
: Big_String_Ptr
:= null)
564 Excep
: constant EOA
:= Get_Current_Excep
.all;
565 Val
: Integer := Line
;
571 Exception_Propagation
.Setup_Exception
(Excep
, Excep
);
572 Excep
.Exception_Raised
:= False;
574 Excep
.Num_Tracebacks
:= 0;
575 Excep
.Pid
:= Local_Partition_ID
;
576 Excep
.Msg_Length
:= 0;
577 Excep
.Cleanup_Flag
:= False;
579 while Msg1
(Excep
.Msg_Length
+ 1) /= ASCII
.NUL
580 and then Excep
.Msg_Length
< Exception_Msg_Max_Length
582 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
583 Excep
.Msg
(Excep
.Msg_Length
) := Msg1
(Excep
.Msg_Length
);
586 -- Append line number if present
590 -- Compute the number of needed characters
597 -- If enough characters are available, put the line number
599 if Excep
.Msg_Length
<= Exception_Msg_Max_Length
- Size
then
600 Excep
.Msg
(Excep
.Msg_Length
+ 1) := ':';
601 Excep
.Msg_Length
:= Excep
.Msg_Length
+ Size
;
606 Remind
:= Val
rem 10;
608 Excep
.Msg
(Excep
.Msg_Length
- Size
) :=
609 Character'Val (Remind
+ Character'Pos ('0'));
615 -- Append second message if present
618 and then Excep
.Msg_Length
+ 1 < Exception_Msg_Max_Length
620 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
621 Excep
.Msg
(Excep
.Msg_Length
) := ' ';
624 while Msg2
(Ptr
) /= ASCII
.NUL
625 and then Excep
.Msg_Length
< Exception_Msg_Max_Length
627 Excep
.Msg_Length
:= Excep
.Msg_Length
+ 1;
628 Excep
.Msg
(Excep
.Msg_Length
) := Msg2
(Ptr
);
632 end Set_Exception_C_Msg
;
634 -----------------------
635 -- Set_Exception_Msg --
636 -----------------------
638 procedure Set_Exception_Msg
642 Len
: constant Natural :=
643 Natural'Min (Message
'Length, Exception_Msg_Max_Length
);
644 First
: constant Integer := Message
'First;
645 Excep
: constant EOA
:= Get_Current_Excep
.all;
648 Exception_Propagation
.Setup_Exception
(Excep
, Excep
);
649 Excep
.Exception_Raised
:= False;
650 Excep
.Msg_Length
:= Len
;
651 Excep
.Msg
(1 .. Len
) := Message
(First
.. First
+ Len
- 1);
653 Excep
.Num_Tracebacks
:= 0;
654 Excep
.Pid
:= Local_Partition_ID
;
655 Excep
.Cleanup_Flag
:= False;
657 end Set_Exception_Msg
;
659 ----------------------------------
660 -- Tailored_Exception_Traceback --
661 ----------------------------------
663 function Tailored_Exception_Traceback
664 (X
: Exception_Occurrence
) return String
666 -- We reference the decorator *wrapper* here and not the decorator
667 -- itself. The purpose of the local variable Wrapper is to prevent a
668 -- potential race condition in the code below. The atomicity of this
669 -- assignment is enforced by pragma Atomic in System.Soft_Links.
671 -- The potential race condition here, if no local variable was used,
672 -- relates to the test upon the wrapper's value and the call, which
673 -- are not performed atomically. With the local variable, potential
674 -- changes of the wrapper's global value between the test and the
675 -- call become inoffensive.
677 Wrapper
: constant Traceback_Decorator_Wrapper_Call
:=
678 Traceback_Decorator_Wrapper
;
681 if Wrapper
= null then
682 return Basic_Exception_Traceback
(X
);
684 return Wrapper
.all (X
.Tracebacks
'Address, X
.Num_Tracebacks
);
686 end Tailored_Exception_Traceback
;
688 ------------------------------------
689 -- Tailored_Exception_Information --
690 ------------------------------------
692 function Tailored_Exception_Information
693 (X
: Exception_Occurrence
) return String
695 -- The tailored exception information is the basic information
696 -- associated with the tailored call chain backtrace.
698 Tback_Info
: constant String := Tailored_Exception_Traceback
(X
);
699 Tback_Len
: constant Natural := Tback_Info
'Length;
701 Info
: String (1 .. Basic_Exception_Info_Maxlength
(X
) + Tback_Len
);
702 Ptr
: Natural := Info
'First - 1;
705 Append_Info_Basic_Exception_Information
(X
, Info
, Ptr
);
706 Append_Info_String
(Tback_Info
, Info
, Ptr
);
707 return Info
(Info
'First .. Ptr
);
708 end Tailored_Exception_Information
;