1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . D W A R F _ L I N E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2009-2020, 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 Ada.Characters.Handling; 33with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; 34with Ada.Unchecked_Deallocation; 35with Ada.Containers.Generic_Array_Sort; 36 37with Interfaces; use Interfaces; 38 39with System; use System; 40with System.Storage_Elements; use System.Storage_Elements; 41with System.Address_Image; 42with System.IO; use System.IO; 43with System.Object_Reader; use System.Object_Reader; 44with System.Traceback_Entries; use System.Traceback_Entries; 45with System.Mmap; use System.Mmap; 46with System.Bounded_Strings; use System.Bounded_Strings; 47 48package body System.Dwarf_Lines is 49 50 SSU : constant := System.Storage_Unit; 51 52 function String_Length (Str : Str_Access) return Natural; 53 -- Return the length of the C string Str 54 55 --------------------------------- 56 -- DWARF Parser Implementation -- 57 --------------------------------- 58 59 procedure Read_Initial_Length 60 (S : in out Mapped_Stream; 61 Len : out Offset; 62 Is64 : out Boolean); 63 -- Read initial length as specified by Dwarf-4 7.2.2 64 65 procedure Read_Section_Offset 66 (S : in out Mapped_Stream; 67 Len : out Offset; 68 Is64 : Boolean); 69 -- Read a section offset, as specified by Dwarf-4 7.4 70 71 procedure Read_Aranges_Entry 72 (C : in out Dwarf_Context; 73 Start : out Storage_Offset; 74 Len : out Storage_Count); 75 -- Read a single .debug_aranges pair 76 77 procedure Read_Aranges_Header 78 (C : in out Dwarf_Context; 79 Info_Offset : out Offset; 80 Success : out Boolean); 81 -- Read .debug_aranges header 82 83 procedure Aranges_Lookup 84 (C : in out Dwarf_Context; 85 Addr : Storage_Offset; 86 Info_Offset : out Offset; 87 Success : out Boolean); 88 -- Search for Addr in .debug_aranges and return offset Info_Offset in 89 -- .debug_info. 90 91 procedure Skip_Form 92 (S : in out Mapped_Stream; 93 Form : uint32; 94 Is64 : Boolean; 95 Ptr_Sz : uint8); 96 -- Advance offset in S for Form. 97 98 procedure Seek_Abbrev 99 (C : in out Dwarf_Context; 100 Abbrev_Offset : Offset; 101 Abbrev_Num : uint32); 102 -- Seek to abbrev Abbrev_Num (starting from Abbrev_Offset) 103 104 procedure Debug_Info_Lookup 105 (C : in out Dwarf_Context; 106 Info_Offset : Offset; 107 Line_Offset : out Offset; 108 Success : out Boolean); 109 -- Search for stmt_list tag in Info_Offset and set Line_Offset to the 110 -- offset in .debug_lines. Only look at the first DIE, which should be 111 -- a compilation unit. 112 113 procedure Initialize_Pass (C : in out Dwarf_Context); 114 -- Seek to the first byte of the first prologue and prepare to make a pass 115 -- over the line number entries. 116 117 procedure Initialize_State_Machine (C : in out Dwarf_Context); 118 -- Set all state machine registers to their specified initial values 119 120 procedure Parse_Prologue (C : in out Dwarf_Context); 121 -- Decode a DWARF statement program prologue 122 123 procedure Read_And_Execute_Isn 124 (C : in out Dwarf_Context; 125 Done : out Boolean); 126 -- Read an execute a statement program instruction 127 128 function To_File_Name 129 (C : in out Dwarf_Context; 130 Code : uint32) return String; 131 -- Extract a file name from the prologue 132 133 type Callback is access procedure (C : in out Dwarf_Context); 134 procedure For_Each_Row (C : in out Dwarf_Context; F : Callback); 135 -- Traverse each .debug_line entry with a callback 136 137 procedure Dump_Row (C : in out Dwarf_Context); 138 -- Dump a single row 139 140 function "<" (Left, Right : Search_Entry) return Boolean; 141 -- For sorting Search_Entry 142 143 procedure Sort_Search_Array is new Ada.Containers.Generic_Array_Sort 144 (Index_Type => Natural, 145 Element_Type => Search_Entry, 146 Array_Type => Search_Array); 147 148 procedure Symbolic_Address 149 (C : in out Dwarf_Context; 150 Addr : Storage_Offset; 151 Dir_Name : out Str_Access; 152 File_Name : out Str_Access; 153 Subprg_Name : out String_Ptr_Len; 154 Line_Num : out Natural); 155 -- Symbolize one address 156 157 ----------------------- 158 -- DWARF constants -- 159 ----------------------- 160 161 -- 6.2.5.2 Standard Opcodes 162 163 DW_LNS_copy : constant := 1; 164 DW_LNS_advance_pc : constant := 2; 165 DW_LNS_advance_line : constant := 3; 166 DW_LNS_set_file : constant := 4; 167 DW_LNS_set_column : constant := 5; 168 DW_LNS_negate_stmt : constant := 6; 169 DW_LNS_set_basic_block : constant := 7; 170 DW_LNS_const_add_pc : constant := 8; 171 DW_LNS_fixed_advance_pc : constant := 9; 172 DW_LNS_set_prologue_end : constant := 10; 173 DW_LNS_set_epilogue_begin : constant := 11; 174 DW_LNS_set_isa : constant := 12; 175 176 -- 6.2.5.3 Extended Opcodes 177 178 DW_LNE_end_sequence : constant := 1; 179 DW_LNE_set_address : constant := 2; 180 DW_LNE_define_file : constant := 3; 181 182 -- From the DWARF version 4 public review draft 183 184 DW_LNE_set_discriminator : constant := 4; 185 186 -- Attribute encodings 187 188 DW_TAG_Compile_Unit : constant := 16#11#; 189 190 DW_AT_Stmt_List : constant := 16#10#; 191 192 DW_FORM_addr : constant := 16#01#; 193 DW_FORM_block2 : constant := 16#03#; 194 DW_FORM_block4 : constant := 16#04#; 195 DW_FORM_data2 : constant := 16#05#; 196 DW_FORM_data4 : constant := 16#06#; 197 DW_FORM_data8 : constant := 16#07#; 198 DW_FORM_string : constant := 16#08#; 199 DW_FORM_block : constant := 16#09#; 200 DW_FORM_block1 : constant := 16#0a#; 201 DW_FORM_data1 : constant := 16#0b#; 202 DW_FORM_flag : constant := 16#0c#; 203 DW_FORM_sdata : constant := 16#0d#; 204 DW_FORM_strp : constant := 16#0e#; 205 DW_FORM_udata : constant := 16#0f#; 206 DW_FORM_ref_addr : constant := 16#10#; 207 DW_FORM_ref1 : constant := 16#11#; 208 DW_FORM_ref2 : constant := 16#12#; 209 DW_FORM_ref4 : constant := 16#13#; 210 DW_FORM_ref8 : constant := 16#14#; 211 DW_FORM_ref_udata : constant := 16#15#; 212 DW_FORM_indirect : constant := 16#16#; 213 DW_FORM_sec_offset : constant := 16#17#; 214 DW_FORM_exprloc : constant := 16#18#; 215 DW_FORM_flag_present : constant := 16#19#; 216 DW_FORM_ref_sig8 : constant := 16#20#; 217 218 --------- 219 -- "<" -- 220 --------- 221 222 function "<" (Left, Right : Search_Entry) return Boolean is 223 begin 224 return Left.First < Right.First; 225 end "<"; 226 227 ----------- 228 -- Close -- 229 ----------- 230 231 procedure Close (C : in out Dwarf_Context) is 232 procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation 233 (Object_File, 234 Object_File_Access); 235 procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation 236 (Search_Array, 237 Search_Array_Access); 238 begin 239 if C.Has_Debug then 240 Close (C.Lines); 241 Close (C.Abbrev); 242 Close (C.Info); 243 Close (C.Aranges); 244 end if; 245 246 Close (C.Obj.all); 247 Unchecked_Deallocation (C.Obj); 248 249 Unchecked_Deallocation (C.Cache); 250 end Close; 251 252 ---------- 253 -- Dump -- 254 ---------- 255 256 procedure Dump (C : in out Dwarf_Context) is 257 begin 258 For_Each_Row (C, Dump_Row'Access); 259 end Dump; 260 261 -------------- 262 -- Dump_Row -- 263 -------------- 264 265 procedure Dump_Row (C : in out Dwarf_Context) is 266 PC : constant Integer_Address := Integer_Address (C.Registers.Address); 267 Off : Offset; 268 begin 269 Tell (C.Lines, Off); 270 271 Put (System.Address_Image (To_Address (PC))); 272 Put (" "); 273 Put (To_File_Name (C, C.Registers.File)); 274 Put (":"); 275 276 declare 277 Image : constant String := uint32'Image (C.Registers.Line); 278 begin 279 Put_Line (Image (2 .. Image'Last)); 280 end; 281 282 Seek (C.Lines, Off); 283 end Dump_Row; 284 285 procedure Dump_Cache (C : Dwarf_Context) is 286 Cache : constant Search_Array_Access := C.Cache; 287 S : Object_Symbol; 288 Name : String_Ptr_Len; 289 begin 290 if Cache = null then 291 Put_Line ("No cache"); 292 return; 293 end if; 294 for I in Cache'Range loop 295 declare 296 E : Search_Entry renames Cache (I); 297 Base_Address : constant System.Address := 298 To_Address (Integer_Address (C.Low + Storage_Count (E.First))); 299 begin 300 Put (System.Address_Image (Base_Address)); 301 Put (" - "); 302 Put (System.Address_Image (Base_Address + Storage_Count (E.Size))); 303 Put (" l@"); 304 Put (System.Address_Image (To_Address (Integer_Address (E.Line)))); 305 Put (": "); 306 S := Read_Symbol (C.Obj.all, Offset (E.Sym)); 307 Name := Object_Reader.Name (C.Obj.all, S); 308 Put (String (Name.Ptr (1 .. Name.Len))); 309 New_Line; 310 end; 311 end loop; 312 end Dump_Cache; 313 314 ------------------ 315 -- For_Each_Row -- 316 ------------------ 317 318 procedure For_Each_Row (C : in out Dwarf_Context; F : Callback) is 319 Done : Boolean; 320 321 begin 322 Initialize_Pass (C); 323 324 loop 325 Read_And_Execute_Isn (C, Done); 326 327 if C.Registers.Is_Row then 328 F.all (C); 329 end if; 330 331 exit when Done; 332 end loop; 333 end For_Each_Row; 334 335 --------------------- 336 -- Initialize_Pass -- 337 --------------------- 338 339 procedure Initialize_Pass (C : in out Dwarf_Context) is 340 begin 341 Seek (C.Lines, 0); 342 C.Next_Prologue := 0; 343 344 Initialize_State_Machine (C); 345 end Initialize_Pass; 346 347 ------------------------------ 348 -- Initialize_State_Machine -- 349 ------------------------------ 350 351 procedure Initialize_State_Machine (C : in out Dwarf_Context) is 352 begin 353 C.Registers := 354 (Address => 0, 355 File => 1, 356 Line => 1, 357 Column => 0, 358 Is_Stmt => C.Prologue.Default_Is_Stmt = 0, 359 Basic_Block => False, 360 End_Sequence => False, 361 Prologue_End => False, 362 Epilogue_Begin => False, 363 ISA => 0, 364 Is_Row => False); 365 end Initialize_State_Machine; 366 367 --------------- 368 -- Is_Inside -- 369 --------------- 370 371 function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is 372 begin 373 return (Addr >= C.Low + C.Load_Address 374 and then Addr <= C.High + C.Load_Address); 375 end Is_Inside; 376 377 ----------------- 378 -- Low_Address -- 379 ----------------- 380 381 function Low_Address (C : Dwarf_Context) 382 return System.Address is 383 begin 384 return C.Load_Address + C.Low; 385 end Low_Address; 386 387 ---------- 388 -- Open -- 389 ---------- 390 391 procedure Open 392 (File_Name : String; 393 C : out Dwarf_Context; 394 Success : out Boolean) 395 is 396 Line_Sec, Info_Sec, Abbrev_Sec, Aranges_Sec : Object_Section; 397 Hi, Lo : uint64; 398 begin 399 -- Not a success by default 400 401 Success := False; 402 403 -- Open file 404 405 C.Obj := Open (File_Name, C.In_Exception); 406 407 if C.Obj = null then 408 return; 409 end if; 410 411 Success := True; 412 413 -- Get memory bounds for executable code. Note that such code 414 -- might come from multiple sections. 415 416 Get_Xcode_Bounds (C.Obj.all, Lo, Hi); 417 C.Low := Storage_Offset (Lo); 418 C.High := Storage_Offset (Hi); 419 420 -- Create a stream for debug sections 421 422 if Format (C.Obj.all) = XCOFF32 then 423 Line_Sec := Get_Section (C.Obj.all, ".dwline"); 424 Abbrev_Sec := Get_Section (C.Obj.all, ".dwabrev"); 425 Info_Sec := Get_Section (C.Obj.all, ".dwinfo"); 426 Aranges_Sec := Get_Section (C.Obj.all, ".dwarnge"); 427 else 428 Line_Sec := Get_Section (C.Obj.all, ".debug_line"); 429 Abbrev_Sec := Get_Section (C.Obj.all, ".debug_abbrev"); 430 Info_Sec := Get_Section (C.Obj.all, ".debug_info"); 431 Aranges_Sec := Get_Section (C.Obj.all, ".debug_aranges"); 432 end if; 433 434 if Line_Sec = Null_Section 435 or else Abbrev_Sec = Null_Section 436 or else Info_Sec = Null_Section 437 or else Aranges_Sec = Null_Section 438 then 439 pragma Annotate 440 (CodePeer, False_Positive, 441 "test always true", "codepeer got confused"); 442 443 C.Has_Debug := False; 444 return; 445 end if; 446 447 C.Lines := Create_Stream (C.Obj.all, Line_Sec); 448 C.Abbrev := Create_Stream (C.Obj.all, Abbrev_Sec); 449 C.Info := Create_Stream (C.Obj.all, Info_Sec); 450 C.Aranges := Create_Stream (C.Obj.all, Aranges_Sec); 451 452 -- All operations are successful, context is valid 453 454 C.Has_Debug := True; 455 end Open; 456 457 -------------------- 458 -- Parse_Prologue -- 459 -------------------- 460 461 procedure Parse_Prologue (C : in out Dwarf_Context) is 462 Char : uint8; 463 Prev : uint8; 464 -- The most recently read character and the one preceding it 465 466 Dummy : uint32; 467 -- Destination for reads we don't care about 468 469 Buf : Buffer; 470 Off : Offset; 471 472 First_Byte_Of_Prologue : Offset; 473 Last_Byte_Of_Prologue : Offset; 474 475 Max_Op_Per_Insn : uint8; 476 pragma Unreferenced (Max_Op_Per_Insn); 477 478 Prologue : Line_Info_Prologue renames C.Prologue; 479 480 begin 481 Tell (C.Lines, First_Byte_Of_Prologue); 482 Prologue.Unit_Length := Read (C.Lines); 483 Tell (C.Lines, Off); 484 C.Next_Prologue := Off + Offset (Prologue.Unit_Length); 485 486 Prologue.Version := Read (C.Lines); 487 Prologue.Prologue_Length := Read (C.Lines); 488 Tell (C.Lines, Last_Byte_Of_Prologue); 489 Last_Byte_Of_Prologue := 490 Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1; 491 492 Prologue.Min_Isn_Length := Read (C.Lines); 493 494 if Prologue.Version >= 4 then 495 Max_Op_Per_Insn := Read (C.Lines); 496 end if; 497 498 Prologue.Default_Is_Stmt := Read (C.Lines); 499 Prologue.Line_Base := Read (C.Lines); 500 Prologue.Line_Range := Read (C.Lines); 501 Prologue.Opcode_Base := Read (C.Lines); 502 503 -- Opcode_Lengths is an array of Opcode_Base bytes specifying the number 504 -- of LEB128 operands for each of the standard opcodes. 505 506 for J in 1 .. uint32 (Prologue.Opcode_Base - 1) loop 507 Prologue.Opcode_Lengths (J) := Read (C.Lines); 508 end loop; 509 510 -- The include directories table follows. This is a list of null 511 -- terminated strings terminated by a double null. We only store 512 -- its offset for later decoding. 513 514 Tell (C.Lines, Prologue.Includes_Offset); 515 Char := Read (C.Lines); 516 517 if Char /= 0 then 518 loop 519 Prev := Char; 520 Char := Read (C.Lines); 521 exit when Char = 0 and Prev = 0; 522 end loop; 523 end if; 524 525 -- The file_names table is next. Each record is a null terminated string 526 -- for the file name, an unsigned LEB128 directory index, an unsigned 527 -- LEB128 modification time, and an LEB128 file length. The table is 528 -- terminated by a null byte. 529 530 Tell (C.Lines, Prologue.File_Names_Offset); 531 532 loop 533 -- Read the filename 534 535 Read_C_String (C.Lines, Buf); 536 exit when Buf (0) = 0; 537 Dummy := Read_LEB128 (C.Lines); -- Skip the directory index. 538 Dummy := Read_LEB128 (C.Lines); -- Skip the modification time. 539 Dummy := Read_LEB128 (C.Lines); -- Skip the file length. 540 end loop; 541 542 -- Check we're where we think we are. This sanity check ensures we think 543 -- the prologue ends where the prologue says it does. It we aren't then 544 -- we've probably gotten out of sync somewhere. 545 546 Tell (C.Lines, Off); 547 548 if Prologue.Unit_Length /= 0 549 and then Off /= Last_Byte_Of_Prologue + 1 550 then 551 raise Dwarf_Error with "Parse error reading DWARF information"; 552 end if; 553 end Parse_Prologue; 554 555 -------------------------- 556 -- Read_And_Execute_Isn -- 557 -------------------------- 558 559 procedure Read_And_Execute_Isn 560 (C : in out Dwarf_Context; 561 Done : out Boolean) 562 is 563 Opcode : uint8; 564 Extended_Opcode : uint8; 565 uint32_Operand : uint32; 566 int32_Operand : int32; 567 uint16_Operand : uint16; 568 Off : Offset; 569 570 Extended_Length : uint32; 571 pragma Unreferenced (Extended_Length); 572 573 Obj : Object_File renames C.Obj.all; 574 Registers : Line_Info_Registers renames C.Registers; 575 Prologue : Line_Info_Prologue renames C.Prologue; 576 577 begin 578 Done := False; 579 Registers.Is_Row := False; 580 581 if Registers.End_Sequence then 582 Initialize_State_Machine (C); 583 end if; 584 585 -- If we have reached the next prologue, read it. Beware of possibly 586 -- empty blocks. 587 588 -- When testing for the end of section, beware of possible zero padding 589 -- at the end. Bail out as soon as there's not even room for at least a 590 -- DW_LNE_end_sequence, 3 bytes from Off to Off+2. This resolves to 591 -- Off+2 > Last_Offset_Within_Section, that is Off+2 > Section_Length-1, 592 -- or Off+3 > Section_Length. 593 594 Tell (C.Lines, Off); 595 while Off = C.Next_Prologue loop 596 Initialize_State_Machine (C); 597 Parse_Prologue (C); 598 Tell (C.Lines, Off); 599 exit when Off + 3 > Length (C.Lines); 600 end loop; 601 602 -- Test whether we're done 603 604 Tell (C.Lines, Off); 605 606 -- We are finished when we either reach the end of the section, or we 607 -- have reached zero padding at the end of the section. 608 609 if Prologue.Unit_Length = 0 or else Off + 3 > Length (C.Lines) then 610 Done := True; 611 return; 612 end if; 613 614 -- Read and interpret an instruction 615 616 Opcode := Read (C.Lines); 617 618 -- Extended opcodes 619 620 if Opcode = 0 then 621 Extended_Length := Read_LEB128 (C.Lines); 622 Extended_Opcode := Read (C.Lines); 623 624 case Extended_Opcode is 625 when DW_LNE_end_sequence => 626 627 -- Mark the end of a sequence of source locations 628 629 Registers.End_Sequence := True; 630 Registers.Is_Row := True; 631 632 when DW_LNE_set_address => 633 634 -- Set the program counter to a word 635 636 Registers.Address := Read_Address (Obj, C.Lines); 637 638 when DW_LNE_define_file => 639 640 -- Not implemented 641 642 raise Dwarf_Error with "DWARF operator not implemented"; 643 644 when DW_LNE_set_discriminator => 645 646 -- Ignored 647 648 int32_Operand := Read_LEB128 (C.Lines); 649 650 when others => 651 652 -- Fail on an unrecognized opcode 653 654 raise Dwarf_Error with "DWARF operator not implemented"; 655 end case; 656 657 -- Standard opcodes 658 659 elsif Opcode < Prologue.Opcode_Base then 660 case Opcode is 661 662 -- Append a row to the line info matrix 663 664 when DW_LNS_copy => 665 Registers.Basic_Block := False; 666 Registers.Is_Row := True; 667 668 -- Add an unsigned word to the program counter 669 670 when DW_LNS_advance_pc => 671 uint32_Operand := Read_LEB128 (C.Lines); 672 Registers.Address := 673 Registers.Address + 674 uint64 (uint32_Operand * uint32 (Prologue.Min_Isn_Length)); 675 676 -- Add a signed word to the current source line 677 678 when DW_LNS_advance_line => 679 int32_Operand := Read_LEB128 (C.Lines); 680 Registers.Line := 681 uint32 (int32 (Registers.Line) + int32_Operand); 682 683 -- Set the current source file 684 685 when DW_LNS_set_file => 686 uint32_Operand := Read_LEB128 (C.Lines); 687 Registers.File := uint32_Operand; 688 689 -- Set the current source column 690 691 when DW_LNS_set_column => 692 uint32_Operand := Read_LEB128 (C.Lines); 693 Registers.Column := uint32_Operand; 694 695 -- Toggle the "is statement" flag. GCC doesn't seem to set this??? 696 697 when DW_LNS_negate_stmt => 698 Registers.Is_Stmt := not Registers.Is_Stmt; 699 700 -- Mark the beginning of a basic block 701 702 when DW_LNS_set_basic_block => 703 Registers.Basic_Block := True; 704 705 -- Advance the program counter as by the special opcode 255 706 707 when DW_LNS_const_add_pc => 708 Registers.Address := 709 Registers.Address + 710 uint64 711 (((255 - Prologue.Opcode_Base) / Prologue.Line_Range) * 712 Prologue.Min_Isn_Length); 713 714 -- Advance the program counter by a constant 715 716 when DW_LNS_fixed_advance_pc => 717 uint16_Operand := Read (C.Lines); 718 Registers.Address := 719 Registers.Address + uint64 (uint16_Operand); 720 721 -- The following are not implemented and ignored 722 723 when DW_LNS_set_prologue_end => 724 null; 725 726 when DW_LNS_set_epilogue_begin => 727 null; 728 729 when DW_LNS_set_isa => 730 null; 731 732 -- Anything else is an error 733 734 when others => 735 raise Dwarf_Error with "DWARF operator not implemented"; 736 end case; 737 738 -- Decode a special opcode. This is a line and address increment encoded 739 -- in a single byte 'special opcode' as described in 6.2.5.1. 740 741 else 742 declare 743 Address_Increment : int32; 744 Line_Increment : int32; 745 746 begin 747 Opcode := Opcode - Prologue.Opcode_Base; 748 749 -- The adjusted opcode is a uint8 encoding an address increment 750 -- and a signed line increment. The upperbound is allowed to be 751 -- greater than int8'last so we decode using int32 directly to 752 -- prevent overflows. 753 754 Address_Increment := 755 int32 (Opcode / Prologue.Line_Range) * 756 int32 (Prologue.Min_Isn_Length); 757 Line_Increment := 758 int32 (Prologue.Line_Base) + 759 int32 (Opcode mod Prologue.Line_Range); 760 761 Registers.Address := 762 Registers.Address + uint64 (Address_Increment); 763 Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment); 764 Registers.Basic_Block := False; 765 Registers.Prologue_End := False; 766 Registers.Epilogue_Begin := False; 767 Registers.Is_Row := True; 768 end; 769 end if; 770 771 exception 772 when Dwarf_Error => 773 774 -- In case of errors during parse, just stop reading 775 776 Registers.Is_Row := False; 777 Done := True; 778 end Read_And_Execute_Isn; 779 780 ---------------------- 781 -- Set_Load_Address -- 782 ---------------------- 783 784 procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is 785 begin 786 C.Load_Address := Addr; 787 end Set_Load_Address; 788 789 ------------------ 790 -- To_File_Name -- 791 ------------------ 792 793 function To_File_Name 794 (C : in out Dwarf_Context; 795 Code : uint32) return String 796 is 797 Buf : Buffer; 798 J : uint32; 799 800 Dir_Idx : uint32; 801 pragma Unreferenced (Dir_Idx); 802 803 Mod_Time : uint32; 804 pragma Unreferenced (Mod_Time); 805 806 Length : uint32; 807 pragma Unreferenced (Length); 808 809 begin 810 Seek (C.Lines, C.Prologue.File_Names_Offset); 811 812 -- Find the entry 813 814 J := 0; 815 loop 816 J := J + 1; 817 Read_C_String (C.Lines, Buf); 818 819 if Buf (Buf'First) = 0 then 820 return "???"; 821 end if; 822 823 Dir_Idx := Read_LEB128 (C.Lines); 824 Mod_Time := Read_LEB128 (C.Lines); 825 Length := Read_LEB128 (C.Lines); 826 exit when J = Code; 827 end loop; 828 829 return To_String (Buf); 830 end To_File_Name; 831 832 ------------------------- 833 -- Read_Initial_Length -- 834 ------------------------- 835 836 procedure Read_Initial_Length 837 (S : in out Mapped_Stream; 838 Len : out Offset; 839 Is64 : out Boolean) 840 is 841 Len32 : uint32; 842 Len64 : uint64; 843 begin 844 Len32 := Read (S); 845 if Len32 < 16#ffff_fff0# then 846 Is64 := False; 847 Len := Offset (Len32); 848 elsif Len32 < 16#ffff_ffff# then 849 -- Invalid length 850 raise Constraint_Error; 851 else 852 Is64 := True; 853 Len64 := Read (S); 854 Len := Offset (Len64); 855 end if; 856 end Read_Initial_Length; 857 858 ------------------------- 859 -- Read_Section_Offset -- 860 ------------------------- 861 862 procedure Read_Section_Offset 863 (S : in out Mapped_Stream; 864 Len : out Offset; 865 Is64 : Boolean) 866 is 867 begin 868 if Is64 then 869 Len := Offset (uint64'(Read (S))); 870 else 871 Len := Offset (uint32'(Read (S))); 872 end if; 873 end Read_Section_Offset; 874 875 -------------------- 876 -- Aranges_Lookup -- 877 -------------------- 878 879 procedure Aranges_Lookup 880 (C : in out Dwarf_Context; 881 Addr : Storage_Offset; 882 Info_Offset : out Offset; 883 Success : out Boolean) 884 is 885 begin 886 Info_Offset := 0; 887 Seek (C.Aranges, 0); 888 889 while Tell (C.Aranges) < Length (C.Aranges) loop 890 Read_Aranges_Header (C, Info_Offset, Success); 891 exit when not Success; 892 893 loop 894 declare 895 Start : Storage_Offset; 896 Len : Storage_Count; 897 begin 898 Read_Aranges_Entry (C, Start, Len); 899 exit when Start = 0 and Len = 0; 900 if Addr >= Start 901 and then Addr < Start + Len 902 then 903 Success := True; 904 return; 905 end if; 906 end; 907 end loop; 908 end loop; 909 910 Success := False; 911 end Aranges_Lookup; 912 913 --------------- 914 -- Skip_Form -- 915 --------------- 916 917 procedure Skip_Form 918 (S : in out Mapped_Stream; 919 Form : uint32; 920 Is64 : Boolean; 921 Ptr_Sz : uint8) 922 is 923 Skip : Offset; 924 begin 925 case Form is 926 when DW_FORM_addr => 927 Skip := Offset (Ptr_Sz); 928 when DW_FORM_block2 => 929 Skip := Offset (uint16'(Read (S))); 930 when DW_FORM_block4 => 931 Skip := Offset (uint32'(Read (S))); 932 when DW_FORM_data2 | DW_FORM_ref2 => 933 Skip := 2; 934 when DW_FORM_data4 | DW_FORM_ref4 => 935 Skip := 4; 936 when DW_FORM_data8 | DW_FORM_ref8 | DW_FORM_ref_sig8 => 937 Skip := 8; 938 when DW_FORM_string => 939 while uint8'(Read (S)) /= 0 loop 940 null; 941 end loop; 942 return; 943 when DW_FORM_block | DW_FORM_exprloc => 944 Skip := Offset (uint32'(Read_LEB128 (S))); 945 when DW_FORM_block1 | DW_FORM_ref1 => 946 Skip := Offset (uint8'(Read (S))); 947 when DW_FORM_data1 | DW_FORM_flag => 948 Skip := 1; 949 when DW_FORM_sdata => 950 declare 951 Val : constant int32 := Read_LEB128 (S); 952 pragma Unreferenced (Val); 953 begin 954 return; 955 end; 956 when DW_FORM_strp | DW_FORM_ref_addr | DW_FORM_sec_offset => 957 Skip := (if Is64 then 8 else 4); 958 when DW_FORM_udata | DW_FORM_ref_udata => 959 declare 960 Val : constant uint32 := Read_LEB128 (S); 961 pragma Unreferenced (Val); 962 begin 963 return; 964 end; 965 when DW_FORM_flag_present => 966 return; 967 when DW_FORM_indirect => 968 raise Constraint_Error; 969 when others => 970 raise Constraint_Error; 971 end case; 972 Seek (S, Tell (S) + Skip); 973 end Skip_Form; 974 975 ----------------- 976 -- Seek_Abbrev -- 977 ----------------- 978 979 procedure Seek_Abbrev 980 (C : in out Dwarf_Context; 981 Abbrev_Offset : Offset; 982 Abbrev_Num : uint32) 983 is 984 Num : uint32; 985 Abbrev : uint32; 986 Tag : uint32; 987 Has_Child : uint8; 988 pragma Unreferenced (Abbrev, Tag, Has_Child); 989 begin 990 Seek (C.Abbrev, Abbrev_Offset); 991 992 Num := 1; 993 994 loop 995 exit when Num = Abbrev_Num; 996 997 Abbrev := Read_LEB128 (C.Abbrev); 998 Tag := Read_LEB128 (C.Abbrev); 999 Has_Child := Read (C.Abbrev); 1000 1001 loop 1002 declare 1003 Name : constant uint32 := Read_LEB128 (C.Abbrev); 1004 Form : constant uint32 := Read_LEB128 (C.Abbrev); 1005 begin 1006 exit when Name = 0 and Form = 0; 1007 end; 1008 end loop; 1009 1010 Num := Num + 1; 1011 end loop; 1012 end Seek_Abbrev; 1013 1014 ----------------------- 1015 -- Debug_Info_Lookup -- 1016 ----------------------- 1017 1018 procedure Debug_Info_Lookup 1019 (C : in out Dwarf_Context; 1020 Info_Offset : Offset; 1021 Line_Offset : out Offset; 1022 Success : out Boolean) 1023 is 1024 Unit_Length : Offset; 1025 Is64 : Boolean; 1026 Version : uint16; 1027 Abbrev_Offset : Offset; 1028 Addr_Sz : uint8; 1029 Abbrev : uint32; 1030 Has_Child : uint8; 1031 pragma Unreferenced (Has_Child); 1032 begin 1033 Line_Offset := 0; 1034 Success := False; 1035 1036 Seek (C.Info, Info_Offset); 1037 1038 Read_Initial_Length (C.Info, Unit_Length, Is64); 1039 1040 Version := Read (C.Info); 1041 if Version not in 2 .. 4 then 1042 return; 1043 end if; 1044 1045 Read_Section_Offset (C.Info, Abbrev_Offset, Is64); 1046 1047 Addr_Sz := Read (C.Info); 1048 if Addr_Sz /= (Address'Size / SSU) then 1049 return; 1050 end if; 1051 1052 -- Read DIEs 1053 1054 loop 1055 Abbrev := Read_LEB128 (C.Info); 1056 exit when Abbrev /= 0; 1057 end loop; 1058 1059 -- Read abbrev table 1060 1061 Seek_Abbrev (C, Abbrev_Offset, Abbrev); 1062 1063 -- First ULEB128 is the abbrev code 1064 1065 if Read_LEB128 (C.Abbrev) /= Abbrev then 1066 -- Ill formed abbrev table 1067 return; 1068 end if; 1069 1070 -- Then the tag 1071 1072 if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then 1073 -- Expect compile unit 1074 return; 1075 end if; 1076 1077 -- Then the has child flag 1078 1079 Has_Child := Read (C.Abbrev); 1080 1081 loop 1082 declare 1083 Name : constant uint32 := Read_LEB128 (C.Abbrev); 1084 Form : constant uint32 := Read_LEB128 (C.Abbrev); 1085 begin 1086 exit when Name = 0 and Form = 0; 1087 if Name = DW_AT_Stmt_List then 1088 case Form is 1089 when DW_FORM_sec_offset => 1090 Read_Section_Offset (C.Info, Line_Offset, Is64); 1091 when DW_FORM_data4 => 1092 Line_Offset := Offset (uint32'(Read (C.Info))); 1093 when DW_FORM_data8 => 1094 Line_Offset := Offset (uint64'(Read (C.Info))); 1095 when others => 1096 -- Unhandled form 1097 return; 1098 end case; 1099 1100 Success := True; 1101 return; 1102 else 1103 Skip_Form (C.Info, Form, Is64, Addr_Sz); 1104 end if; 1105 end; 1106 end loop; 1107 1108 return; 1109 end Debug_Info_Lookup; 1110 1111 ------------------------- 1112 -- Read_Aranges_Header -- 1113 ------------------------- 1114 1115 procedure Read_Aranges_Header 1116 (C : in out Dwarf_Context; 1117 Info_Offset : out Offset; 1118 Success : out Boolean) 1119 is 1120 Unit_Length : Offset; 1121 Is64 : Boolean; 1122 Version : uint16; 1123 Sz : uint8; 1124 begin 1125 Success := False; 1126 Info_Offset := 0; 1127 1128 Read_Initial_Length (C.Aranges, Unit_Length, Is64); 1129 1130 Version := Read (C.Aranges); 1131 if Version /= 2 then 1132 return; 1133 end if; 1134 1135 Read_Section_Offset (C.Aranges, Info_Offset, Is64); 1136 1137 -- Read address_size (ubyte) 1138 1139 Sz := Read (C.Aranges); 1140 if Sz /= (Address'Size / SSU) then 1141 return; 1142 end if; 1143 1144 -- Read segment_size (ubyte) 1145 1146 Sz := Read (C.Aranges); 1147 if Sz /= 0 then 1148 return; 1149 end if; 1150 1151 -- Handle alignment on twice the address size 1152 declare 1153 Cur_Off : constant Offset := Tell (C.Aranges); 1154 Align : constant Offset := 2 * Address'Size / SSU; 1155 Space : constant Offset := Cur_Off mod Align; 1156 begin 1157 if Space /= 0 then 1158 Seek (C.Aranges, Cur_Off + Align - Space); 1159 end if; 1160 end; 1161 1162 Success := True; 1163 end Read_Aranges_Header; 1164 1165 ------------------------ 1166 -- Read_Aranges_Entry -- 1167 ------------------------ 1168 1169 procedure Read_Aranges_Entry 1170 (C : in out Dwarf_Context; 1171 Start : out Storage_Offset; 1172 Len : out Storage_Count) 1173 is 1174 begin 1175 -- Read table 1176 if Address'Size = 32 then 1177 declare 1178 S, L : uint32; 1179 begin 1180 S := Read (C.Aranges); 1181 L := Read (C.Aranges); 1182 Start := Storage_Offset (S); 1183 Len := Storage_Count (L); 1184 end; 1185 elsif Address'Size = 64 then 1186 declare 1187 S, L : uint64; 1188 begin 1189 S := Read (C.Aranges); 1190 L := Read (C.Aranges); 1191 Start := Storage_Offset (S); 1192 Len := Storage_Count (L); 1193 end; 1194 else 1195 raise Constraint_Error; 1196 end if; 1197 end Read_Aranges_Entry; 1198 1199 ------------------ 1200 -- Enable_Cache -- 1201 ------------------ 1202 1203 procedure Enable_Cache (C : in out Dwarf_Context) is 1204 Cache : Search_Array_Access; 1205 begin 1206 -- Phase 1: count number of symbols. Phase 2: fill the cache. 1207 declare 1208 S : Object_Symbol; 1209 Val : uint64; 1210 Xcode_Low : constant uint64 := uint64 (C.Low); 1211 Xcode_High : constant uint64 := uint64 (C.High); 1212 Sz : uint32; 1213 Addr, Prev_Addr : uint32; 1214 Nbr_Symbols : Natural; 1215 begin 1216 for Phase in 1 .. 2 loop 1217 Nbr_Symbols := 0; 1218 S := First_Symbol (C.Obj.all); 1219 Prev_Addr := uint32'Last; 1220 while S /= Null_Symbol loop 1221 -- Discard symbols of length 0 or located outside of the 1222 -- execution code section outer boundaries. 1223 Sz := uint32 (Size (S)); 1224 Val := Value (S); 1225 1226 if Sz > 0 1227 and then Val >= Xcode_Low 1228 and then Val <= Xcode_High 1229 then 1230 1231 Addr := uint32 (Val - Xcode_Low); 1232 1233 -- Try to filter symbols at the same address. This is a best 1234 -- effort as they might not be consecutive. 1235 if Addr /= Prev_Addr then 1236 Nbr_Symbols := Nbr_Symbols + 1; 1237 Prev_Addr := Addr; 1238 1239 if Phase = 2 then 1240 C.Cache (Nbr_Symbols) := 1241 (First => Addr, 1242 Size => Sz, 1243 Sym => uint32 (Off (S)), 1244 Line => 0); 1245 end if; 1246 end if; 1247 end if; 1248 1249 S := Next_Symbol (C.Obj.all, S); 1250 end loop; 1251 1252 if Phase = 1 then 1253 -- Allocate the cache 1254 Cache := new Search_Array (1 .. Nbr_Symbols); 1255 C.Cache := Cache; 1256 end if; 1257 end loop; 1258 pragma Assert (Nbr_Symbols = C.Cache'Last); 1259 end; 1260 1261 -- Sort the cache. 1262 Sort_Search_Array (C.Cache.all); 1263 1264 -- Set line offsets 1265 if not C.Has_Debug then 1266 return; 1267 end if; 1268 declare 1269 Info_Offset : Offset; 1270 Line_Offset : Offset; 1271 Success : Boolean; 1272 Ar_Start : Storage_Offset; 1273 Ar_Len : Storage_Count; 1274 Start, Len : uint32; 1275 First, Last : Natural; 1276 Mid : Natural; 1277 begin 1278 Seek (C.Aranges, 0); 1279 1280 while Tell (C.Aranges) < Length (C.Aranges) loop 1281 Read_Aranges_Header (C, Info_Offset, Success); 1282 exit when not Success; 1283 1284 Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); 1285 exit when not Success; 1286 1287 -- Read table 1288 loop 1289 Read_Aranges_Entry (C, Ar_Start, Ar_Len); 1290 exit when Ar_Start = 0 and Ar_Len = 0; 1291 1292 Len := uint32 (Ar_Len); 1293 Start := uint32 (Ar_Start - C.Low); 1294 1295 -- Search START in the array 1296 First := Cache'First; 1297 Last := Cache'Last; 1298 Mid := First; -- In case of array with one element 1299 while First < Last loop 1300 Mid := First + (Last - First) / 2; 1301 if Start < Cache (Mid).First then 1302 Last := Mid - 1; 1303 elsif Start >= Cache (Mid).First + Cache (Mid).Size then 1304 First := Mid + 1; 1305 else 1306 exit; 1307 end if; 1308 end loop; 1309 1310 -- Fill info. 1311 1312 -- There can be overlapping symbols 1313 while Mid > Cache'First 1314 and then Cache (Mid - 1).First <= Start 1315 and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start 1316 loop 1317 Mid := Mid - 1; 1318 end loop; 1319 while Mid <= Cache'Last loop 1320 if Start < Cache (Mid).First + Cache (Mid).Size 1321 and then Start + Len > Cache (Mid).First 1322 then 1323 -- MID is within the bounds 1324 Cache (Mid).Line := uint32 (Line_Offset); 1325 elsif Start + Len <= Cache (Mid).First then 1326 -- Over 1327 exit; 1328 end if; 1329 Mid := Mid + 1; 1330 end loop; 1331 end loop; 1332 end loop; 1333 end; 1334 end Enable_Cache; 1335 1336 ---------------------- 1337 -- Symbolic_Address -- 1338 ---------------------- 1339 1340 procedure Symbolic_Address 1341 (C : in out Dwarf_Context; 1342 Addr : Storage_Offset; 1343 Dir_Name : out Str_Access; 1344 File_Name : out Str_Access; 1345 Subprg_Name : out String_Ptr_Len; 1346 Line_Num : out Natural) 1347 is 1348 procedure Set_Result (Match : Line_Info_Registers); 1349 -- Set results using match 1350 1351 procedure Set_Result (Match : Line_Info_Registers) is 1352 Dir_Idx : uint32; 1353 J : uint32; 1354 1355 Mod_Time : uint32; 1356 pragma Unreferenced (Mod_Time); 1357 1358 Length : uint32; 1359 pragma Unreferenced (Length); 1360 1361 begin 1362 Seek (C.Lines, C.Prologue.File_Names_Offset); 1363 1364 -- Find the entry 1365 1366 J := 0; 1367 loop 1368 J := J + 1; 1369 File_Name := Read_C_String (C.Lines); 1370 1371 if File_Name (File_Name'First) = ASCII.NUL then 1372 -- End of file list, so incorrect entry 1373 return; 1374 end if; 1375 1376 Dir_Idx := Read_LEB128 (C.Lines); 1377 Mod_Time := Read_LEB128 (C.Lines); 1378 Length := Read_LEB128 (C.Lines); 1379 exit when J = Match.File; 1380 end loop; 1381 1382 if Dir_Idx = 0 then 1383 -- No directory 1384 Dir_Name := null; 1385 1386 else 1387 Seek (C.Lines, C.Prologue.Includes_Offset); 1388 1389 J := 0; 1390 loop 1391 J := J + 1; 1392 Dir_Name := Read_C_String (C.Lines); 1393 1394 if Dir_Name (Dir_Name'First) = ASCII.NUL then 1395 -- End of directory list, so ill-formed table 1396 return; 1397 end if; 1398 1399 exit when J = Dir_Idx; 1400 1401 end loop; 1402 end if; 1403 1404 Line_Num := Natural (Match.Line); 1405 end Set_Result; 1406 1407 Addr_Int : constant uint64 := uint64 (Addr); 1408 Previous_Row : Line_Info_Registers; 1409 Info_Offset : Offset; 1410 Line_Offset : Offset; 1411 Success : Boolean; 1412 Done : Boolean; 1413 S : Object_Symbol; 1414 1415 begin 1416 -- Initialize result 1417 Dir_Name := null; 1418 File_Name := null; 1419 Subprg_Name := (null, 0); 1420 Line_Num := 0; 1421 1422 if C.Cache /= null then 1423 -- Look in the cache 1424 declare 1425 Addr_Off : constant uint32 := uint32 (Addr - C.Low); 1426 First, Last, Mid : Natural; 1427 begin 1428 First := C.Cache'First; 1429 Last := C.Cache'Last; 1430 Mid := First; 1431 1432 while First <= Last loop 1433 Mid := First + (Last - First) / 2; 1434 if Addr_Off < C.Cache (Mid).First then 1435 Last := Mid - 1; 1436 elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then 1437 First := Mid + 1; 1438 else 1439 exit; 1440 end if; 1441 end loop; 1442 1443 if Addr_Off >= C.Cache (Mid).First 1444 and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size 1445 then 1446 Line_Offset := Offset (C.Cache (Mid).Line); 1447 S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym)); 1448 Subprg_Name := Object_Reader.Name (C.Obj.all, S); 1449 else 1450 -- Not found 1451 return; 1452 end if; 1453 end; 1454 else 1455 -- Search symbol 1456 S := First_Symbol (C.Obj.all); 1457 while S /= Null_Symbol loop 1458 if Spans (S, Addr_Int) then 1459 Subprg_Name := Object_Reader.Name (C.Obj.all, S); 1460 exit; 1461 end if; 1462 1463 S := Next_Symbol (C.Obj.all, S); 1464 end loop; 1465 1466 -- Search address in aranges table 1467 1468 Aranges_Lookup (C, Addr, Info_Offset, Success); 1469 if not Success then 1470 return; 1471 end if; 1472 1473 -- Search stmt_list in info table 1474 1475 Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); 1476 if not Success then 1477 return; 1478 end if; 1479 end if; 1480 1481 Seek (C.Lines, Line_Offset); 1482 C.Next_Prologue := 0; 1483 Initialize_State_Machine (C); 1484 Parse_Prologue (C); 1485 Previous_Row.Line := 0; 1486 1487 -- Advance to the first entry 1488 1489 loop 1490 Read_And_Execute_Isn (C, Done); 1491 1492 if C.Registers.Is_Row then 1493 Previous_Row := C.Registers; 1494 exit; 1495 end if; 1496 1497 exit when Done; 1498 end loop; 1499 1500 -- Read the rest of the entries 1501 1502 while Tell (C.Lines) < C.Next_Prologue loop 1503 Read_And_Execute_Isn (C, Done); 1504 1505 if C.Registers.Is_Row then 1506 if not Previous_Row.End_Sequence 1507 and then Addr_Int >= Previous_Row.Address 1508 and then Addr_Int < C.Registers.Address 1509 then 1510 Set_Result (Previous_Row); 1511 return; 1512 1513 elsif Addr_Int = C.Registers.Address then 1514 Set_Result (C.Registers); 1515 return; 1516 end if; 1517 1518 Previous_Row := C.Registers; 1519 end if; 1520 1521 exit when Done; 1522 end loop; 1523 end Symbolic_Address; 1524 1525 ------------------- 1526 -- String_Length -- 1527 ------------------- 1528 1529 function String_Length (Str : Str_Access) return Natural is 1530 begin 1531 for I in Str'Range loop 1532 if Str (I) = ASCII.NUL then 1533 return I - Str'First; 1534 end if; 1535 end loop; 1536 return Str'Last; 1537 end String_Length; 1538 1539 ------------------------ 1540 -- Symbolic_Traceback -- 1541 ------------------------ 1542 1543 procedure Symbolic_Traceback 1544 (Cin : Dwarf_Context; 1545 Traceback : AET.Tracebacks_Array; 1546 Suppress_Hex : Boolean; 1547 Symbol_Found : out Boolean; 1548 Res : in out System.Bounded_Strings.Bounded_String) 1549 is 1550 use Ada.Characters.Handling; 1551 C : Dwarf_Context := Cin; 1552 1553 Addr_In_Traceback : Address; 1554 Offset_To_Lookup : Storage_Offset; 1555 1556 Dir_Name : Str_Access; 1557 File_Name : Str_Access; 1558 Subprg_Name : String_Ptr_Len; 1559 Line_Num : Natural; 1560 Off : Natural; 1561 begin 1562 if not C.Has_Debug then 1563 Symbol_Found := False; 1564 return; 1565 else 1566 Symbol_Found := True; 1567 end if; 1568 1569 for J in Traceback'Range loop 1570 -- If the buffer is full, no need to do any useless work 1571 exit when Is_Full (Res); 1572 1573 Addr_In_Traceback := PC_For (Traceback (J)); 1574 1575 Offset_To_Lookup := Addr_In_Traceback - C.Load_Address; 1576 1577 Symbolic_Address 1578 (C, 1579 Offset_To_Lookup, 1580 Dir_Name, 1581 File_Name, 1582 Subprg_Name, 1583 Line_Num); 1584 1585 -- If we're not requested to suppress hex addresses, emit it now. 1586 1587 if not Suppress_Hex then 1588 Append_Address (Res, Addr_In_Traceback); 1589 Append (Res, ' '); 1590 end if; 1591 1592 if File_Name /= null then 1593 declare 1594 Last : constant Natural := String_Length (File_Name); 1595 Is_Ada : constant Boolean := 1596 Last > 3 1597 and then 1598 To_Upper (String (File_Name (Last - 3 .. Last - 1))) = 1599 ".AD"; 1600 -- True if this is an Ada file. This doesn't take into account 1601 -- nonstandard file-naming conventions, but that's OK; this is 1602 -- purely cosmetic. It covers at least .ads, .adb, and .ada. 1603 1604 Line_Image : constant String := Natural'Image (Line_Num); 1605 begin 1606 if Subprg_Name.Len /= 0 then 1607 -- For Ada code, Symbol_Image is in all lower case; we don't 1608 -- have the case from the original source code. But the best 1609 -- guess is Mixed_Case, so convert to that. 1610 1611 if Is_Ada then 1612 declare 1613 Symbol_Image : String := 1614 Object_Reader.Decoded_Ada_Name 1615 (C.Obj.all, 1616 Subprg_Name); 1617 begin 1618 for K in Symbol_Image'Range loop 1619 if K = Symbol_Image'First 1620 or else not 1621 (Is_Letter (Symbol_Image (K - 1)) 1622 or else Is_Digit (Symbol_Image (K - 1))) 1623 then 1624 Symbol_Image (K) := To_Upper (Symbol_Image (K)); 1625 end if; 1626 end loop; 1627 Append (Res, Symbol_Image); 1628 end; 1629 else 1630 Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); 1631 1632 Append 1633 (Res, 1634 String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); 1635 end if; 1636 else 1637 Append (Res, "???"); 1638 end if; 1639 1640 Append (Res, " at "); 1641 Append (Res, String (File_Name (1 .. Last))); 1642 Append (Res, ':'); 1643 Append (Res, Line_Image (2 .. Line_Image'Last)); 1644 end; 1645 else 1646 if Subprg_Name.Len > 0 then 1647 Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); 1648 1649 Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); 1650 else 1651 Append (Res, "???"); 1652 end if; 1653 1654 Append (Res, " at ???"); 1655 end if; 1656 1657 Append (Res, ASCII.LF); 1658 end loop; 1659 end Symbolic_Traceback; 1660end System.Dwarf_Lines; 1661