File : a-exexda.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- ADA.EXCEPTIONS.EXCEPTION_DATA --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, 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 3, 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with System.Storage_Elements; use System.Storage_Elements;
33
34 separate (Ada.Exceptions)
35 package body Exception_Data is
36
37 -- This unit implements the Exception_Information related services for
38 -- both the Ada standard requirements and the GNAT.Exception_Traces
39 -- facility. This is also used by the implementation of the stream
40 -- attributes of types Exception_Id and Exception_Occurrence.
41
42 -- There are common parts between the contents of Exception_Information
43 -- (the regular Ada interface) and Untailored_Exception_Information (used
44 -- for streaming, and when there is no symbolic traceback available) The
45 -- overall structure is sketched below:
46
47 --
48 -- Untailored_Exception_Information
49 -- |
50 -- +-------+--------+
51 -- | |
52 -- Basic_Exc_Info & Untailored_Exc_Tback
53 -- (B_E_I) (U_E_TB)
54
55 -- o--
56 -- (B_E_I) | Exception_Name: <exception name> (as in Exception_Name)
57 -- | Message: <message> (or a null line if no message)
58 -- | PID=nnnn (if nonzero)
59 -- o--
60 -- (U_E_TB) | Call stack traceback locations:
61 -- | <0xyyyyyyyy 0xyyyyyyyy ...>
62 -- o--
63
64 -- Exception_Information
65 -- |
66 -- +----------+----------+
67 -- | |
68 -- Basic_Exc_Info & traceback
69 -- |
70 -- +-----------+------------+
71 -- | |
72 -- Untailored_Exc_Tback Or Tback_Decorator
73 -- if no decorator set otherwise
74
75 -- Functions returning String imply secondary stack use, which is a heavy
76 -- mechanism requiring run-time support. Besides, some of the routines we
77 -- provide here are to be used by the default Last_Chance_Handler, at the
78 -- critical point where the runtime is about to be finalized. Since most
79 -- of the items we have at hand are of bounded length, we also provide a
80 -- procedural interface able to incrementally append the necessary bits to
81 -- a preallocated buffer or output them straight to stderr.
82
83 -- The procedural interface is composed of two major sections: a neutral
84 -- section for basic types like Address, Character, Natural or String, and
85 -- an exception oriented section for the exception names, messages, and
86 -- information. This is the Append_Info family of procedures below.
87
88 -- Output to stderr is commanded by passing an empty buffer to update, and
89 -- care is taken not to overflow otherwise.
90
91 --------------------------------------------
92 -- Procedural Interface - Neutral section --
93 --------------------------------------------
94
95 procedure Append_Info_Address
96 (A : Address;
97 Info : in out String;
98 Ptr : in out Natural);
99
100 procedure Append_Info_Character
101 (C : Character;
102 Info : in out String;
103 Ptr : in out Natural);
104
105 procedure Append_Info_Nat
106 (N : Natural;
107 Info : in out String;
108 Ptr : in out Natural);
109
110 procedure Append_Info_NL
111 (Info : in out String;
112 Ptr : in out Natural);
113 pragma Inline (Append_Info_NL);
114
115 procedure Append_Info_String
116 (S : String;
117 Info : in out String;
118 Ptr : in out Natural);
119
120 -------------------------------------------------------
121 -- Procedural Interface - Exception oriented section --
122 -------------------------------------------------------
123
124 procedure Append_Info_Exception_Name
125 (Id : Exception_Id;
126 Info : in out String;
127 Ptr : in out Natural);
128
129 procedure Append_Info_Exception_Name
130 (X : Exception_Occurrence;
131 Info : in out String;
132 Ptr : in out Natural);
133
134 procedure Append_Info_Exception_Message
135 (X : Exception_Occurrence;
136 Info : in out String;
137 Ptr : in out Natural);
138
139 procedure Append_Info_Basic_Exception_Information
140 (X : Exception_Occurrence;
141 Info : in out String;
142 Ptr : in out Natural);
143
144 procedure Append_Info_Untailored_Exception_Traceback
145 (X : Exception_Occurrence;
146 Info : in out String;
147 Ptr : in out Natural);
148
149 procedure Append_Info_Untailored_Exception_Information
150 (X : Exception_Occurrence;
151 Info : in out String;
152 Ptr : in out Natural);
153
154 -- The "functional" interface to the exception information not involving
155 -- a traceback decorator uses preallocated intermediate buffers to avoid
156 -- the use of secondary stack. Preallocation requires preliminary length
157 -- computation, for which a series of functions are introduced:
158
159 ---------------------------------
160 -- Length evaluation utilities --
161 ---------------------------------
162
163 function Basic_Exception_Info_Maxlength
164 (X : Exception_Occurrence) return Natural;
165
166 function Untailored_Exception_Traceback_Maxlength
167 (X : Exception_Occurrence) return Natural;
168
169 function Exception_Info_Maxlength
170 (X : Exception_Occurrence) return Natural;
171
172 function Exception_Name_Length
173 (Id : Exception_Id) return Natural;
174
175 function Exception_Name_Length
176 (X : Exception_Occurrence) return Natural;
177
178 function Exception_Message_Length
179 (X : Exception_Occurrence) return Natural;
180
181 --------------------------
182 -- Functional Interface --
183 --------------------------
184
185 function Untailored_Exception_Traceback
186 (X : Exception_Occurrence) return String;
187 -- Returns an image of the complete call chain associated with an
188 -- exception occurrence in its most basic form, that is as a raw sequence
189 -- of hexadecimal addresses.
190
191 function Tailored_Exception_Traceback
192 (X : Exception_Occurrence) return String;
193 -- Returns an image of the complete call chain associated with an
194 -- exception occurrence, either in its basic form if no decorator is
195 -- in place, or as formatted by the decorator otherwise.
196
197 -----------------------------------------------------------------------
198 -- Services for the default Last_Chance_Handler and the task wrapper --
199 -----------------------------------------------------------------------
200
201 pragma Export
202 (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
203
204 pragma Export
205 (Ada, Append_Info_Untailored_Exception_Information,
206 "__gnat_append_info_u_e_info");
207
208 pragma Export
209 (Ada, Exception_Message_Length, "__gnat_exception_msg_len");
210
211 function Get_Executable_Load_Address return System.Address;
212 pragma Import (C, Get_Executable_Load_Address,
213 "__gnat_get_executable_load_address");
214 -- Get the load address of the executable, or Null_Address if not known
215
216 -------------------------
217 -- Append_Info_Address --
218 -------------------------
219
220 procedure Append_Info_Address
221 (A : Address;
222 Info : in out String;
223 Ptr : in out Natural)
224 is
225 S : String (1 .. 18);
226 P : Natural;
227 N : Integer_Address;
228
229 H : constant array (Integer range 0 .. 15) of Character :=
230 "0123456789abcdef";
231 begin
232 P := S'Last;
233 N := To_Integer (A);
234 loop
235 S (P) := H (Integer (N mod 16));
236 P := P - 1;
237 N := N / 16;
238 exit when N = 0;
239 end loop;
240
241 S (P - 1) := '0';
242 S (P) := 'x';
243
244 Append_Info_String (S (P - 1 .. S'Last), Info, Ptr);
245 end Append_Info_Address;
246
247 ---------------------------------------------
248 -- Append_Info_Basic_Exception_Information --
249 ---------------------------------------------
250
251 -- To ease the maximum length computation, we define and pull out some
252 -- string constants:
253
254 BEI_Name_Header : constant String := "raised ";
255 BEI_Msg_Header : constant String := " : ";
256 BEI_PID_Header : constant String := "PID: ";
257
258 procedure Append_Info_Basic_Exception_Information
259 (X : Exception_Occurrence;
260 Info : in out String;
261 Ptr : in out Natural)
262 is
263 Name : String (1 .. Exception_Name_Length (X));
264 -- Buffer in which to fetch the exception name, in order to check
265 -- whether this is an internal _ABORT_SIGNAL or a regular occurrence.
266
267 Name_Ptr : Natural := Name'First - 1;
268
269 begin
270 -- Output exception name and message except for _ABORT_SIGNAL, where
271 -- these two lines are omitted.
272
273 Append_Info_Exception_Name (X, Name, Name_Ptr);
274
275 if Name (Name'First) /= '_' then
276 Append_Info_String (BEI_Name_Header, Info, Ptr);
277 Append_Info_String (Name, Info, Ptr);
278
279 if Exception_Message_Length (X) /= 0 then
280 Append_Info_String (BEI_Msg_Header, Info, Ptr);
281 Append_Info_Exception_Message (X, Info, Ptr);
282 end if;
283
284 Append_Info_NL (Info, Ptr);
285 end if;
286
287 -- Output PID line if nonzero
288
289 if X.Pid /= 0 then
290 Append_Info_String (BEI_PID_Header, Info, Ptr);
291 Append_Info_Nat (X.Pid, Info, Ptr);
292 Append_Info_NL (Info, Ptr);
293 end if;
294 end Append_Info_Basic_Exception_Information;
295
296 ---------------------------
297 -- Append_Info_Character --
298 ---------------------------
299
300 procedure Append_Info_Character
301 (C : Character;
302 Info : in out String;
303 Ptr : in out Natural)
304 is
305 begin
306 if Info'Length = 0 then
307 To_Stderr (C);
308 elsif Ptr < Info'Last then
309 Ptr := Ptr + 1;
310 Info (Ptr) := C;
311 end if;
312 end Append_Info_Character;
313
314 -----------------------------------
315 -- Append_Info_Exception_Message --
316 -----------------------------------
317
318 procedure Append_Info_Exception_Message
319 (X : Exception_Occurrence;
320 Info : in out String;
321 Ptr : in out Natural)
322 is
323 begin
324 if X.Id = Null_Id then
325 raise Constraint_Error;
326 end if;
327
328 declare
329 Len : constant Natural := Exception_Message_Length (X);
330 Msg : constant String (1 .. Len) := X.Msg (1 .. Len);
331 begin
332 Append_Info_String (Msg, Info, Ptr);
333 end;
334 end Append_Info_Exception_Message;
335
336 --------------------------------
337 -- Append_Info_Exception_Name --
338 --------------------------------
339
340 procedure Append_Info_Exception_Name
341 (Id : Exception_Id;
342 Info : in out String;
343 Ptr : in out Natural)
344 is
345 begin
346 if Id = Null_Id then
347 raise Constraint_Error;
348 end if;
349
350 declare
351 Len : constant Natural := Exception_Name_Length (Id);
352 Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len);
353 begin
354 Append_Info_String (Name, Info, Ptr);
355 end;
356 end Append_Info_Exception_Name;
357
358 procedure Append_Info_Exception_Name
359 (X : Exception_Occurrence;
360 Info : in out String;
361 Ptr : in out Natural)
362 is
363 begin
364 Append_Info_Exception_Name (X.Id, Info, Ptr);
365 end Append_Info_Exception_Name;
366
367 ------------------------------
368 -- Exception_Info_Maxlength --
369 ------------------------------
370
371 function Exception_Info_Maxlength
372 (X : Exception_Occurrence) return Natural
373 is
374 begin
375 return
376 Basic_Exception_Info_Maxlength (X)
377 + Untailored_Exception_Traceback_Maxlength (X);
378 end Exception_Info_Maxlength;
379
380 ---------------------
381 -- Append_Info_Nat --
382 ---------------------
383
384 procedure Append_Info_Nat
385 (N : Natural;
386 Info : in out String;
387 Ptr : in out Natural)
388 is
389 begin
390 if N > 9 then
391 Append_Info_Nat (N / 10, Info, Ptr);
392 end if;
393
394 Append_Info_Character
395 (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr);
396 end Append_Info_Nat;
397
398 --------------------
399 -- Append_Info_NL --
400 --------------------
401
402 procedure Append_Info_NL
403 (Info : in out String;
404 Ptr : in out Natural)
405 is
406 begin
407 Append_Info_Character (ASCII.LF, Info, Ptr);
408 end Append_Info_NL;
409
410 ------------------------
411 -- Append_Info_String --
412 ------------------------
413
414 procedure Append_Info_String
415 (S : String;
416 Info : in out String;
417 Ptr : in out Natural)
418 is
419 begin
420 if Info'Length = 0 then
421 To_Stderr (S);
422 else
423 declare
424 Last : constant Natural :=
425 Integer'Min (Ptr + S'Length, Info'Last);
426 begin
427 Info (Ptr + 1 .. Last) := S;
428 Ptr := Last;
429 end;
430 end if;
431 end Append_Info_String;
432
433 --------------------------------------------------
434 -- Append_Info_Untailored_Exception_Information --
435 --------------------------------------------------
436
437 procedure Append_Info_Untailored_Exception_Information
438 (X : Exception_Occurrence;
439 Info : in out String;
440 Ptr : in out Natural)
441 is
442 begin
443 Append_Info_Basic_Exception_Information (X, Info, Ptr);
444 Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
445 end Append_Info_Untailored_Exception_Information;
446
447 ------------------------------------------------
448 -- Append_Info_Untailored_Exception_Traceback --
449 ------------------------------------------------
450
451 -- As for Basic_Exception_Information:
452
453 BETB_Header : constant String := "Call stack traceback locations:";
454 LDAD_Header : constant String := "Load address: ";
455
456 procedure Append_Info_Untailored_Exception_Traceback
457 (X : Exception_Occurrence;
458 Info : in out String;
459 Ptr : in out Natural)
460 is
461 Load_Address : Address;
462
463 begin
464 if X.Num_Tracebacks = 0 then
465 return;
466 end if;
467
468 -- The executable load address line
469
470 Load_Address := Get_Executable_Load_Address;
471
472 if Load_Address /= Null_Address then
473 Append_Info_String (LDAD_Header, Info, Ptr);
474 Append_Info_Address (Load_Address, Info, Ptr);
475 Append_Info_NL (Info, Ptr);
476 end if;
477
478 -- The traceback lines
479
480 Append_Info_String (BETB_Header, Info, Ptr);
481 Append_Info_NL (Info, Ptr);
482
483 for J in 1 .. X.Num_Tracebacks loop
484 Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr);
485 exit when J = X.Num_Tracebacks;
486 Append_Info_Character (' ', Info, Ptr);
487 end loop;
488
489 Append_Info_NL (Info, Ptr);
490 end Append_Info_Untailored_Exception_Traceback;
491
492 -------------------------------------------
493 -- Basic_Exception_Information_Maxlength --
494 -------------------------------------------
495
496 function Basic_Exception_Info_Maxlength
497 (X : Exception_Occurrence) return Natural
498 is
499 begin
500 return
501 BEI_Name_Header'Length + Exception_Name_Length (X)
502 + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1
503 + BEI_PID_Header'Length + 15;
504 end Basic_Exception_Info_Maxlength;
505
506 ---------------------------
507 -- Exception_Information --
508 ---------------------------
509
510 function Exception_Information (X : Exception_Occurrence) return String is
511 -- The tailored exception information is the basic information
512 -- associated with the tailored call chain backtrace.
513
514 Tback_Info : constant String := Tailored_Exception_Traceback (X);
515 Tback_Len : constant Natural := Tback_Info'Length;
516
517 Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len);
518 Ptr : Natural := Info'First - 1;
519
520 begin
521 Append_Info_Basic_Exception_Information (X, Info, Ptr);
522 Append_Info_String (Tback_Info, Info, Ptr);
523 return Info (Info'First .. Ptr);
524 end Exception_Information;
525
526 ------------------------------
527 -- Exception_Message_Length --
528 ------------------------------
529
530 function Exception_Message_Length
531 (X : Exception_Occurrence) return Natural
532 is
533 begin
534 return X.Msg_Length;
535 end Exception_Message_Length;
536
537 ---------------------------
538 -- Exception_Name_Length --
539 ---------------------------
540
541 function Exception_Name_Length (Id : Exception_Id) return Natural is
542 begin
543 -- What is stored in the internal Name buffer includes a terminating
544 -- null character that we never care about.
545
546 return Id.Name_Length - 1;
547 end Exception_Name_Length;
548
549 function Exception_Name_Length (X : Exception_Occurrence) return Natural is
550 begin
551 return Exception_Name_Length (X.Id);
552 end Exception_Name_Length;
553
554 -------------------------------
555 -- Untailored_Exception_Traceback --
556 -------------------------------
557
558 function Untailored_Exception_Traceback
559 (X : Exception_Occurrence) return String
560 is
561 Info : aliased String
562 (1 .. Untailored_Exception_Traceback_Maxlength (X));
563 Ptr : Natural := Info'First - 1;
564 begin
565 Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
566 return Info (Info'First .. Ptr);
567 end Untailored_Exception_Traceback;
568
569 --------------------------------------
570 -- Untailored_Exception_Information --
571 --------------------------------------
572
573 function Untailored_Exception_Information
574 (X : Exception_Occurrence) return String
575 is
576 Info : String (1 .. Exception_Info_Maxlength (X));
577 Ptr : Natural := Info'First - 1;
578 begin
579 Append_Info_Untailored_Exception_Information (X, Info, Ptr);
580 return Info (Info'First .. Ptr);
581 end Untailored_Exception_Information;
582
583 -------------------------
584 -- Set_Exception_C_Msg --
585 -------------------------
586
587 procedure Set_Exception_C_Msg
588 (Excep : EOA;
589 Id : Exception_Id;
590 Msg1 : System.Address;
591 Line : Integer := 0;
592 Column : Integer := 0;
593 Msg2 : System.Address := System.Null_Address)
594 is
595 Remind : Integer;
596 Ptr : Natural;
597
598 procedure Append_Number (Number : Integer);
599 -- Append given number to Excep.Msg
600
601 -------------------
602 -- Append_Number --
603 -------------------
604
605 procedure Append_Number (Number : Integer) is
606 Val : Integer;
607 Size : Integer;
608
609 begin
610 if Number <= 0 then
611 return;
612 end if;
613
614 -- Compute the number of needed characters
615
616 Size := 1;
617 Val := Number;
618 while Val > 0 loop
619 Val := Val / 10;
620 Size := Size + 1;
621 end loop;
622
623 -- If enough characters are available, put the line number
624
625 if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
626 Excep.Msg (Excep.Msg_Length + 1) := ':';
627 Excep.Msg_Length := Excep.Msg_Length + Size;
628
629 Val := Number;
630 Size := 0;
631 while Val > 0 loop
632 Remind := Val rem 10;
633 Val := Val / 10;
634 Excep.Msg (Excep.Msg_Length - Size) :=
635 Character'Val (Remind + Character'Pos ('0'));
636 Size := Size + 1;
637 end loop;
638 end if;
639 end Append_Number;
640
641 -- Start of processing for Set_Exception_C_Msg
642
643 begin
644 Excep.Exception_Raised := False;
645 Excep.Id := Id;
646 Excep.Num_Tracebacks := 0;
647 Excep.Pid := Local_Partition_ID;
648 Excep.Msg_Length := 0;
649
650 while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL
651 and then Excep.Msg_Length < Exception_Msg_Max_Length
652 loop
653 Excep.Msg_Length := Excep.Msg_Length + 1;
654 Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length);
655 end loop;
656
657 Append_Number (Line);
658 Append_Number (Column);
659
660 -- Append second message if present
661
662 if Msg2 /= System.Null_Address
663 and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
664 then
665 Excep.Msg_Length := Excep.Msg_Length + 1;
666 Excep.Msg (Excep.Msg_Length) := ' ';
667
668 Ptr := 1;
669 while To_Ptr (Msg2) (Ptr) /= ASCII.NUL
670 and then Excep.Msg_Length < Exception_Msg_Max_Length
671 loop
672 Excep.Msg_Length := Excep.Msg_Length + 1;
673 Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr);
674 Ptr := Ptr + 1;
675 end loop;
676 end if;
677 end Set_Exception_C_Msg;
678
679 -----------------------
680 -- Set_Exception_Msg --
681 -----------------------
682
683 procedure Set_Exception_Msg
684 (Excep : EOA;
685 Id : Exception_Id;
686 Message : String)
687 is
688 Len : constant Natural :=
689 Natural'Min (Message'Length, Exception_Msg_Max_Length);
690 First : constant Integer := Message'First;
691 begin
692 Excep.Exception_Raised := False;
693 Excep.Msg_Length := Len;
694 Excep.Msg (1 .. Len) := Message (First .. First + Len - 1);
695 Excep.Id := Id;
696 Excep.Num_Tracebacks := 0;
697 Excep.Pid := Local_Partition_ID;
698 end Set_Exception_Msg;
699
700 ----------------------------------
701 -- Tailored_Exception_Traceback --
702 ----------------------------------
703
704 function Tailored_Exception_Traceback
705 (X : Exception_Occurrence) return String
706 is
707 -- We reference the decorator *wrapper* here and not the decorator
708 -- itself. The purpose of the local variable Wrapper is to prevent a
709 -- potential race condition in the code below. The atomicity of this
710 -- assignment is enforced by pragma Atomic in System.Soft_Links.
711
712 -- The potential race condition here, if no local variable was used,
713 -- relates to the test upon the wrapper's value and the call, which
714 -- are not performed atomically. With the local variable, potential
715 -- changes of the wrapper's global value between the test and the
716 -- call become inoffensive.
717
718 Wrapper : constant Traceback_Decorator_Wrapper_Call :=
719 Traceback_Decorator_Wrapper;
720
721 begin
722 if Wrapper = null then
723 return Untailored_Exception_Traceback (X);
724 else
725 return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
726 end if;
727 end Tailored_Exception_Traceback;
728
729 ----------------------------------------------
730 -- Untailored_Exception_Traceback_Maxlength --
731 ----------------------------------------------
732
733 function Untailored_Exception_Traceback_Maxlength
734 (X : Exception_Occurrence) return Natural
735 is
736 Space_Per_Address : constant := 2 + 16 + 1;
737 -- Space for "0x" + HHHHHHHHHHHHHHHH + " "
738 begin
739 return
740 LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 +
741 X.Num_Tracebacks * Space_Per_Address + 1;
742 end Untailored_Exception_Traceback_Maxlength;
743
744 end Exception_Data;