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-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 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 32with System.Storage_Elements; use System.Storage_Elements; 33 34separate (Ada.Exceptions) 35package 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 744end Exception_Data; 745