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