Daily bump.
[official-gcc.git] / gcc / ada / a-exexda.adb
blob98d823dee6d61df2872e20a325ffc109ab8e73fc
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- ADA.EXCEPTIONS.EXCEPTION_DATA --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
10 -- --
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. --
21 -- --
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. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
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
41 -- facility.
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
46 -- sketched below:
49 -- Exception_Information
50 -- |
51 -- +-------+--------+
52 -- | |
53 -- Basic_Exc_Info & Basic_Exc_Tback
54 -- (B_E_I) (B_E_TB)
56 -- o--
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)
60 -- o--
61 -- (B_E_TB) | Call stack traceback locations:
62 -- | <0xyyyyyyyy 0xyyyyyyyy ...>
63 -- o--
65 -- Tailored_Exception_Information
66 -- |
67 -- +----------+----------+
68 -- | |
69 -- Basic_Exc_Info & Tailored_Exc_Tback
70 -- |
71 -- +-----------+------------+
72 -- | |
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
97 (A : Address;
98 Info : in out String;
99 Ptr : in out Natural);
101 procedure Append_Info_Character
102 (C : Character;
103 Info : in out String;
104 Ptr : in out Natural);
106 procedure Append_Info_Nat
107 (N : Natural;
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
117 (S : 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
126 (Id : Exception_Id;
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 -----------------------------------------------------------------------
202 pragma Export
203 (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
205 pragma Export
206 (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
208 pragma Export
209 (Ada, Exception_Message_Length, "__gnat_exception_msg_len");
211 -------------------------
212 -- Append_Info_Address --
213 -------------------------
215 procedure Append_Info_Address
216 (A : Address;
217 Info : in out String;
218 Ptr : in out Natural)
220 S : String (1 .. 18);
221 P : Natural;
222 N : Integer_Address;
224 H : constant array (Integer range 0 .. 15) of Character :=
225 "0123456789abcdef";
226 begin
227 P := S'Last;
228 N := To_Integer (A);
229 loop
230 S (P) := H (Integer (N mod 16));
231 P := P - 1;
232 N := N / 16;
233 exit when N = 0;
234 end loop;
236 S (P - 1) := '0';
237 S (P) := 'x';
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
247 (C : Character;
248 Info : in out String;
249 Ptr : in out Natural)
251 begin
252 if Info'Length = 0 then
253 To_Stderr (C);
254 elsif Ptr < Info'Last then
255 Ptr := Ptr + 1;
256 Info (Ptr) := C;
257 end if;
258 end Append_Info_Character;
260 ---------------------
261 -- Append_Info_Nat --
262 ---------------------
264 procedure Append_Info_Nat
265 (N : Natural;
266 Info : in out String;
267 Ptr : in out Natural)
269 begin
270 if N > 9 then
271 Append_Info_Nat (N / 10, Info, Ptr);
272 end if;
274 Append_Info_Character
275 (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr);
276 end Append_Info_Nat;
278 --------------------
279 -- Append_Info_NL --
280 --------------------
282 procedure Append_Info_NL
283 (Info : in out String;
284 Ptr : in out Natural)
286 begin
287 Append_Info_Character (ASCII.LF, Info, Ptr);
288 end Append_Info_NL;
290 ------------------------
291 -- Append_Info_String --
292 ------------------------
294 procedure Append_Info_String
295 (S : String;
296 Info : in out String;
297 Ptr : in out Natural)
299 begin
300 if Info'Length = 0 then
301 To_Stderr (S);
302 else
303 declare
304 Last : constant Natural :=
305 Integer'Min (Ptr + S'Length, Info'Last);
306 begin
307 Info (Ptr + 1 .. Last) := S;
308 Ptr := Last;
309 end;
310 end if;
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;
335 begin
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);
350 end if;
351 end if;
353 -- Output PID line if non-zero
355 if X.Pid /= 0 then
356 Append_Info_String (BEI_PID_Header, Info, Ptr);
357 Append_Info_Nat (X.Pid, Info, Ptr);
358 Append_Info_NL (Info, Ptr);
359 end if;
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
368 begin
369 return
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)
388 begin
389 if X.Num_Tracebacks = 0 then
390 return;
391 end if;
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);
400 end loop;
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
412 Space_Per_Traceback : constant := 2 + 16 + 1;
413 -- Space for "0x" + HHHHHHHHHHHHHHHH + " "
414 begin
415 return BETB_Header'Length + 1 +
416 X.Num_Tracebacks * Space_Per_Traceback + 1;
417 end Basic_Exception_Tback_Maxlength;
419 ---------------------------------------
420 -- Append_Info_Exception_Information --
421 ---------------------------------------
423 procedure Append_Info_Exception_Information
424 (X : Exception_Occurrence;
425 Info : in out String;
426 Ptr : in out Natural)
428 begin
429 Append_Info_Basic_Exception_Information (X, Info, Ptr);
430 Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
431 end Append_Info_Exception_Information;
433 ------------------------------
434 -- Exception_Info_Maxlength --
435 ------------------------------
437 function Exception_Info_Maxlength
438 (X : Exception_Occurrence) return Natural is
439 begin
440 return
441 Basic_Exception_Info_Maxlength (X)
442 + Basic_Exception_Tback_Maxlength (X);
443 end Exception_Info_Maxlength;
445 -----------------------------------
446 -- Append_Info_Exception_Message --
447 -----------------------------------
449 procedure Append_Info_Exception_Message
450 (X : Exception_Occurrence;
451 Info : in out String;
452 Ptr : in out Natural) is
453 begin
454 if X.Id = Null_Id then
455 raise Constraint_Error;
456 end if;
458 declare
459 Len : constant Natural := Exception_Message_Length (X);
460 Msg : constant String (1 .. Len) := X.Msg (1 .. Len);
461 begin
462 Append_Info_String (Msg, Info, Ptr);
463 end;
464 end Append_Info_Exception_Message;
466 --------------------------------
467 -- Append_Info_Exception_Name --
468 --------------------------------
470 procedure Append_Info_Exception_Name
471 (Id : Exception_Id;
472 Info : in out String;
473 Ptr : in out Natural)
475 begin
476 if Id = Null_Id then
477 raise Constraint_Error;
478 end if;
480 declare
481 Len : constant Natural := Exception_Name_Length (Id);
482 Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len);
483 begin
484 Append_Info_String (Name, Info, Ptr);
485 end;
486 end Append_Info_Exception_Name;
488 procedure Append_Info_Exception_Name
489 (X : Exception_Occurrence;
490 Info : in out String;
491 Ptr : in out Natural)
493 begin
494 Append_Info_Exception_Name (X.Id, Info, Ptr);
495 end Append_Info_Exception_Name;
497 ---------------------------
498 -- Exception_Name_Length --
499 ---------------------------
501 function Exception_Name_Length
502 (Id : Exception_Id) return Natural is
503 begin
504 -- What is stored in the internal Name buffer includes a terminating
505 -- null character that we never care about.
507 return Id.Name_Length - 1;
508 end Exception_Name_Length;
510 function Exception_Name_Length
511 (X : Exception_Occurrence) return Natural is
512 begin
513 return Exception_Name_Length (X.Id);
514 end Exception_Name_Length;
516 ------------------------------
517 -- Exception_Message_Length --
518 ------------------------------
520 function Exception_Message_Length
521 (X : Exception_Occurrence) return Natural is
522 begin
523 return X.Msg_Length;
524 end Exception_Message_Length;
526 -------------------------------
527 -- Basic_Exception_Traceback --
528 -------------------------------
530 function Basic_Exception_Traceback
531 (X : Exception_Occurrence) return String
533 Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X));
534 Ptr : Natural := Info'First - 1;
536 begin
537 Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
538 return Info (Info'First .. Ptr);
539 end Basic_Exception_Traceback;
541 ---------------------------
542 -- Exception_Information --
543 ---------------------------
545 function Exception_Information
546 (X : Exception_Occurrence) return String
548 Info : String (1 .. Exception_Info_Maxlength (X));
549 Ptr : Natural := Info'First - 1;
551 begin
552 Append_Info_Exception_Information (X, Info, Ptr);
553 return Info (Info'First .. Ptr);
554 end Exception_Information;
556 -------------------------
557 -- Set_Exception_C_Msg --
558 -------------------------
560 procedure Set_Exception_C_Msg
561 (Id : Exception_Id;
562 Msg1 : System.Address;
563 Line : Integer := 0;
564 Msg2 : System.Address := System.Null_Address)
566 Excep : constant EOA := Get_Current_Excep.all;
567 Val : Integer := Line;
568 Remind : Integer;
569 Size : Integer := 1;
570 Ptr : Natural;
572 begin
573 Exception_Propagation.Setup_Exception (Excep, Excep);
574 Excep.Exception_Raised := False;
575 Excep.Id := Id;
576 Excep.Num_Tracebacks := 0;
577 Excep.Pid := Local_Partition_ID;
578 Excep.Msg_Length := 0;
579 Excep.Cleanup_Flag := False;
581 while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL
582 and then Excep.Msg_Length < Exception_Msg_Max_Length
583 loop
584 Excep.Msg_Length := Excep.Msg_Length + 1;
585 Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length);
586 end loop;
588 -- Append line number if present
590 if Line > 0 then
592 -- Compute the number of needed characters
594 while Val > 0 loop
595 Val := Val / 10;
596 Size := Size + 1;
597 end loop;
599 -- If enough characters are available, put the line number
601 if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
602 Excep.Msg (Excep.Msg_Length + 1) := ':';
603 Excep.Msg_Length := Excep.Msg_Length + Size;
604 Val := Line;
605 Size := 0;
607 while Val > 0 loop
608 Remind := Val rem 10;
609 Val := Val / 10;
610 Excep.Msg (Excep.Msg_Length - Size) :=
611 Character'Val (Remind + Character'Pos ('0'));
612 Size := Size + 1;
613 end loop;
614 end if;
615 end if;
617 -- Append second message if present
619 if Msg2 /= System.Null_Address
620 and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
621 then
622 Excep.Msg_Length := Excep.Msg_Length + 1;
623 Excep.Msg (Excep.Msg_Length) := ' ';
625 Ptr := 1;
626 while To_Ptr (Msg2) (Ptr) /= ASCII.NUL
627 and then Excep.Msg_Length < Exception_Msg_Max_Length
628 loop
629 Excep.Msg_Length := Excep.Msg_Length + 1;
630 Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr);
631 Ptr := Ptr + 1;
632 end loop;
633 end if;
634 end Set_Exception_C_Msg;
636 -----------------------
637 -- Set_Exception_Msg --
638 -----------------------
640 procedure Set_Exception_Msg
641 (Id : Exception_Id;
642 Message : String)
644 Len : constant Natural :=
645 Natural'Min (Message'Length, Exception_Msg_Max_Length);
646 First : constant Integer := Message'First;
647 Excep : constant EOA := Get_Current_Excep.all;
649 begin
650 Exception_Propagation.Setup_Exception (Excep, Excep);
651 Excep.Exception_Raised := False;
652 Excep.Msg_Length := Len;
653 Excep.Msg (1 .. Len) := Message (First .. First + Len - 1);
654 Excep.Id := Id;
655 Excep.Num_Tracebacks := 0;
656 Excep.Pid := Local_Partition_ID;
657 Excep.Cleanup_Flag := False;
659 end Set_Exception_Msg;
661 ----------------------------------
662 -- Tailored_Exception_Traceback --
663 ----------------------------------
665 function Tailored_Exception_Traceback
666 (X : Exception_Occurrence) return String
668 -- We reference the decorator *wrapper* here and not the decorator
669 -- itself. The purpose of the local variable Wrapper is to prevent a
670 -- potential race condition in the code below. The atomicity of this
671 -- assignment is enforced by pragma Atomic in System.Soft_Links.
673 -- The potential race condition here, if no local variable was used,
674 -- relates to the test upon the wrapper's value and the call, which
675 -- are not performed atomically. With the local variable, potential
676 -- changes of the wrapper's global value between the test and the
677 -- call become inoffensive.
679 Wrapper : constant Traceback_Decorator_Wrapper_Call :=
680 Traceback_Decorator_Wrapper;
682 begin
683 if Wrapper = null then
684 return Basic_Exception_Traceback (X);
685 else
686 return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
687 end if;
688 end Tailored_Exception_Traceback;
690 ------------------------------------
691 -- Tailored_Exception_Information --
692 ------------------------------------
694 function Tailored_Exception_Information
695 (X : Exception_Occurrence) return String
697 -- The tailored exception information is the basic information
698 -- associated with the tailored call chain backtrace.
700 Tback_Info : constant String := Tailored_Exception_Traceback (X);
701 Tback_Len : constant Natural := Tback_Info'Length;
703 Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len);
704 Ptr : Natural := Info'First - 1;
706 begin
707 Append_Info_Basic_Exception_Information (X, Info, Ptr);
708 Append_Info_String (Tback_Info, Info, Ptr);
709 return Info (Info'First .. Ptr);
710 end Tailored_Exception_Information;
712 end Exception_Data;