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;