1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- ADA.EXCEPTIONS.EXCEPTION_DATA -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, 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 ------------------------- 210 -- Append_Info_Address -- 211 ------------------------- 212 213 procedure Append_Info_Address 214 (A : Address; 215 Info : in out String; 216 Ptr : in out Natural) 217 is 218 S : String (1 .. 18); 219 P : Natural; 220 N : Integer_Address; 221 222 H : constant array (Integer range 0 .. 15) of Character := 223 "0123456789abcdef"; 224 begin 225 P := S'Last; 226 N := To_Integer (A); 227 loop 228 S (P) := H (Integer (N mod 16)); 229 P := P - 1; 230 N := N / 16; 231 exit when N = 0; 232 end loop; 233 234 S (P - 1) := '0'; 235 S (P) := 'x'; 236 237 Append_Info_String (S (P - 1 .. S'Last), Info, Ptr); 238 end Append_Info_Address; 239 240 --------------------------- 241 -- Append_Info_Character -- 242 --------------------------- 243 244 procedure Append_Info_Character 245 (C : Character; 246 Info : in out String; 247 Ptr : in out Natural) 248 is 249 begin 250 if Info'Length = 0 then 251 To_Stderr (C); 252 elsif Ptr < Info'Last then 253 Ptr := Ptr + 1; 254 Info (Ptr) := C; 255 end if; 256 end Append_Info_Character; 257 258 --------------------- 259 -- Append_Info_Nat -- 260 --------------------- 261 262 procedure Append_Info_Nat 263 (N : Natural; 264 Info : in out String; 265 Ptr : in out Natural) 266 is 267 begin 268 if N > 9 then 269 Append_Info_Nat (N / 10, Info, Ptr); 270 end if; 271 272 Append_Info_Character 273 (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr); 274 end Append_Info_Nat; 275 276 -------------------- 277 -- Append_Info_NL -- 278 -------------------- 279 280 procedure Append_Info_NL 281 (Info : in out String; 282 Ptr : in out Natural) 283 is 284 begin 285 Append_Info_Character (ASCII.LF, Info, Ptr); 286 end Append_Info_NL; 287 288 ------------------------ 289 -- Append_Info_String -- 290 ------------------------ 291 292 procedure Append_Info_String 293 (S : String; 294 Info : in out String; 295 Ptr : in out Natural) 296 is 297 begin 298 if Info'Length = 0 then 299 To_Stderr (S); 300 else 301 declare 302 Last : constant Natural := 303 Integer'Min (Ptr + S'Length, Info'Last); 304 begin 305 Info (Ptr + 1 .. Last) := S; 306 Ptr := Last; 307 end; 308 end if; 309 end Append_Info_String; 310 311 --------------------------------------------- 312 -- Append_Info_Basic_Exception_Information -- 313 --------------------------------------------- 314 315 -- To ease the maximum length computation, we define and pull out a couple 316 -- of string constants: 317 318 BEI_Name_Header : constant String := "Exception name: "; 319 BEI_Msg_Header : constant String := "Message: "; 320 BEI_PID_Header : constant String := "PID: "; 321 322 procedure Append_Info_Basic_Exception_Information 323 (X : Exception_Occurrence; 324 Info : in out String; 325 Ptr : in out Natural) 326 is 327 Name : String (1 .. Exception_Name_Length (X)); 328 -- Buffer in which to fetch the exception name, in order to check 329 -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. 330 331 Name_Ptr : Natural := Name'First - 1; 332 333 begin 334 -- Output exception name and message except for _ABORT_SIGNAL, where 335 -- these two lines are omitted. 336 337 Append_Info_Exception_Name (X, Name, Name_Ptr); 338 339 if Name (Name'First) /= '_' then 340 Append_Info_String (BEI_Name_Header, Info, Ptr); 341 Append_Info_String (Name, Info, Ptr); 342 Append_Info_NL (Info, Ptr); 343 344 if Exception_Message_Length (X) /= 0 then 345 Append_Info_String (BEI_Msg_Header, Info, Ptr); 346 Append_Info_Exception_Message (X, Info, Ptr); 347 Append_Info_NL (Info, Ptr); 348 end if; 349 end if; 350 351 -- Output PID line if non-zero 352 353 if X.Pid /= 0 then 354 Append_Info_String (BEI_PID_Header, Info, Ptr); 355 Append_Info_Nat (X.Pid, Info, Ptr); 356 Append_Info_NL (Info, Ptr); 357 end if; 358 end Append_Info_Basic_Exception_Information; 359 360 ------------------------------------------- 361 -- Basic_Exception_Information_Maxlength -- 362 ------------------------------------------- 363 364 function Basic_Exception_Info_Maxlength 365 (X : Exception_Occurrence) return Natural is 366 begin 367 return 368 BEI_Name_Header'Length + Exception_Name_Length (X) + 1 369 + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 370 + BEI_PID_Header'Length + 15; 371 end Basic_Exception_Info_Maxlength; 372 373 ------------------------------------------- 374 -- Append_Info_Basic_Exception_Traceback -- 375 ------------------------------------------- 376 377 -- As for Basic_Exception_Information: 378 379 BETB_Header : constant String := "Call stack traceback locations:"; 380 381 procedure Append_Info_Basic_Exception_Traceback 382 (X : Exception_Occurrence; 383 Info : in out String; 384 Ptr : in out Natural) 385 is 386 begin 387 if X.Num_Tracebacks = 0 then 388 return; 389 end if; 390 391 Append_Info_String (BETB_Header, Info, Ptr); 392 Append_Info_NL (Info, Ptr); 393 394 for J in 1 .. X.Num_Tracebacks loop 395 Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr); 396 exit when J = X.Num_Tracebacks; 397 Append_Info_Character (' ', Info, Ptr); 398 end loop; 399 400 Append_Info_NL (Info, Ptr); 401 end Append_Info_Basic_Exception_Traceback; 402 403 ----------------------------------------- 404 -- Basic_Exception_Traceback_Maxlength -- 405 ----------------------------------------- 406 407 function Basic_Exception_Tback_Maxlength 408 (X : Exception_Occurrence) return Natural 409 is 410 Space_Per_Traceback : constant := 2 + 16 + 1; 411 -- Space for "0x" + HHHHHHHHHHHHHHHH + " " 412 begin 413 return BETB_Header'Length + 1 + 414 X.Num_Tracebacks * Space_Per_Traceback + 1; 415 end Basic_Exception_Tback_Maxlength; 416 417 --------------------------------------- 418 -- Append_Info_Exception_Information -- 419 --------------------------------------- 420 421 procedure Append_Info_Exception_Information 422 (X : Exception_Occurrence; 423 Info : in out String; 424 Ptr : in out Natural) 425 is 426 begin 427 Append_Info_Basic_Exception_Information (X, Info, Ptr); 428 Append_Info_Basic_Exception_Traceback (X, Info, Ptr); 429 end Append_Info_Exception_Information; 430 431 ------------------------------ 432 -- Exception_Info_Maxlength -- 433 ------------------------------ 434 435 function Exception_Info_Maxlength 436 (X : Exception_Occurrence) return Natural 437 is 438 begin 439 return 440 Basic_Exception_Info_Maxlength (X) 441 + Basic_Exception_Tback_Maxlength (X); 442 end Exception_Info_Maxlength; 443 444 ----------------------------------- 445 -- Append_Info_Exception_Message -- 446 ----------------------------------- 447 448 procedure Append_Info_Exception_Message 449 (X : Exception_Occurrence; 450 Info : in out String; 451 Ptr : in out Natural) 452 is 453 begin 454 if X.Id = Null_Id then 455 raise Constraint_Error; 456 end if; 457 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; 465 466 -------------------------------- 467 -- Append_Info_Exception_Name -- 468 -------------------------------- 469 470 procedure Append_Info_Exception_Name 471 (Id : Exception_Id; 472 Info : in out String; 473 Ptr : in out Natural) 474 is 475 begin 476 if Id = Null_Id then 477 raise Constraint_Error; 478 end if; 479 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; 487 488 procedure Append_Info_Exception_Name 489 (X : Exception_Occurrence; 490 Info : in out String; 491 Ptr : in out Natural) 492 is 493 begin 494 Append_Info_Exception_Name (X.Id, Info, Ptr); 495 end Append_Info_Exception_Name; 496 497 --------------------------- 498 -- Exception_Name_Length -- 499 --------------------------- 500 501 function Exception_Name_Length 502 (Id : Exception_Id) return Natural 503 is 504 begin 505 -- What is stored in the internal Name buffer includes a terminating 506 -- null character that we never care about. 507 508 return Id.Name_Length - 1; 509 end Exception_Name_Length; 510 511 function Exception_Name_Length 512 (X : Exception_Occurrence) return Natural is 513 begin 514 return Exception_Name_Length (X.Id); 515 end Exception_Name_Length; 516 517 ------------------------------ 518 -- Exception_Message_Length -- 519 ------------------------------ 520 521 function Exception_Message_Length 522 (X : Exception_Occurrence) return Natural 523 is 524 begin 525 return X.Msg_Length; 526 end Exception_Message_Length; 527 528 ------------------------------- 529 -- Basic_Exception_Traceback -- 530 ------------------------------- 531 532 function Basic_Exception_Traceback 533 (X : Exception_Occurrence) return String 534 is 535 Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X)); 536 Ptr : Natural := Info'First - 1; 537 begin 538 Append_Info_Basic_Exception_Traceback (X, Info, Ptr); 539 return Info (Info'First .. Ptr); 540 end Basic_Exception_Traceback; 541 542 --------------------------- 543 -- Exception_Information -- 544 --------------------------- 545 546 function Exception_Information 547 (X : Exception_Occurrence) return String 548 is 549 Info : String (1 .. Exception_Info_Maxlength (X)); 550 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; 555 556 ------------------------- 557 -- Set_Exception_C_Msg -- 558 ------------------------- 559 560 procedure Set_Exception_C_Msg 561 (Excep : EOA; 562 Id : Exception_Id; 563 Msg1 : System.Address; 564 Line : Integer := 0; 565 Column : Integer := 0; 566 Msg2 : System.Address := System.Null_Address) 567 is 568 Remind : Integer; 569 Ptr : Natural; 570 571 procedure Append_Number (Number : Integer); 572 -- Append given number to Excep.Msg 573 574 ------------------- 575 -- Append_Number -- 576 ------------------- 577 578 procedure Append_Number (Number : Integer) is 579 Val : Integer; 580 Size : Integer; 581 582 begin 583 if Number <= 0 then 584 return; 585 end if; 586 587 -- Compute the number of needed characters 588 589 Size := 1; 590 Val := Number; 591 while Val > 0 loop 592 Val := Val / 10; 593 Size := Size + 1; 594 end loop; 595 596 -- If enough characters are available, put the line number 597 598 if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then 599 Excep.Msg (Excep.Msg_Length + 1) := ':'; 600 Excep.Msg_Length := Excep.Msg_Length + Size; 601 602 Val := Number; 603 Size := 0; 604 while Val > 0 loop 605 Remind := Val rem 10; 606 Val := Val / 10; 607 Excep.Msg (Excep.Msg_Length - Size) := 608 Character'Val (Remind + Character'Pos ('0')); 609 Size := Size + 1; 610 end loop; 611 end if; 612 end Append_Number; 613 614 -- Start of processing for Set_Exception_C_Msg 615 616 begin 617 Excep.Exception_Raised := False; 618 Excep.Id := Id; 619 Excep.Num_Tracebacks := 0; 620 Excep.Pid := Local_Partition_ID; 621 Excep.Msg_Length := 0; 622 623 while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL 624 and then Excep.Msg_Length < Exception_Msg_Max_Length 625 loop 626 Excep.Msg_Length := Excep.Msg_Length + 1; 627 Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length); 628 end loop; 629 630 Append_Number (Line); 631 Append_Number (Column); 632 633 -- Append second message if present 634 635 if Msg2 /= System.Null_Address 636 and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length 637 then 638 Excep.Msg_Length := Excep.Msg_Length + 1; 639 Excep.Msg (Excep.Msg_Length) := ' '; 640 641 Ptr := 1; 642 while To_Ptr (Msg2) (Ptr) /= ASCII.NUL 643 and then Excep.Msg_Length < Exception_Msg_Max_Length 644 loop 645 Excep.Msg_Length := Excep.Msg_Length + 1; 646 Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr); 647 Ptr := Ptr + 1; 648 end loop; 649 end if; 650 end Set_Exception_C_Msg; 651 652 ----------------------- 653 -- Set_Exception_Msg -- 654 ----------------------- 655 656 procedure Set_Exception_Msg 657 (Excep : EOA; 658 Id : Exception_Id; 659 Message : String) 660 is 661 Len : constant Natural := 662 Natural'Min (Message'Length, Exception_Msg_Max_Length); 663 First : constant Integer := Message'First; 664 begin 665 Excep.Exception_Raised := False; 666 Excep.Msg_Length := Len; 667 Excep.Msg (1 .. Len) := Message (First .. First + Len - 1); 668 Excep.Id := Id; 669 Excep.Num_Tracebacks := 0; 670 Excep.Pid := Local_Partition_ID; 671 end Set_Exception_Msg; 672 673 ---------------------------------- 674 -- Tailored_Exception_Traceback -- 675 ---------------------------------- 676 677 function Tailored_Exception_Traceback 678 (X : Exception_Occurrence) return String 679 is 680 -- We reference the decorator *wrapper* here and not the decorator 681 -- itself. The purpose of the local variable Wrapper is to prevent a 682 -- potential race condition in the code below. The atomicity of this 683 -- assignment is enforced by pragma Atomic in System.Soft_Links. 684 685 -- The potential race condition here, if no local variable was used, 686 -- relates to the test upon the wrapper's value and the call, which 687 -- are not performed atomically. With the local variable, potential 688 -- changes of the wrapper's global value between the test and the 689 -- call become inoffensive. 690 691 Wrapper : constant Traceback_Decorator_Wrapper_Call := 692 Traceback_Decorator_Wrapper; 693 694 begin 695 if Wrapper = null then 696 return Basic_Exception_Traceback (X); 697 else 698 return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); 699 end if; 700 end Tailored_Exception_Traceback; 701 702 ------------------------------------ 703 -- Tailored_Exception_Information -- 704 ------------------------------------ 705 706 function Tailored_Exception_Information 707 (X : Exception_Occurrence) return String 708 is 709 -- The tailored exception information is the basic information 710 -- associated with the tailored call chain backtrace. 711 712 Tback_Info : constant String := Tailored_Exception_Traceback (X); 713 Tback_Len : constant Natural := Tback_Info'Length; 714 715 Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len); 716 Ptr : Natural := Info'First - 1; 717 718 begin 719 Append_Info_Basic_Exception_Information (X, Info, Ptr); 720 Append_Info_String (Tback_Info, Info, Ptr); 721 return Info (Info'First .. Ptr); 722 end Tailored_Exception_Information; 723 724end Exception_Data; 725