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