?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gcc-interface/decl.c (gnat_to_gnu_field): Do not set the alignment
[official-gcc.git] / gcc / ada / libgnat / s-dwalin.adb
blobe8c14faa3158da86fedcb29f3825e7acf663ef38
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-2017, 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
32 pragma 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
36 with Ada.Characters.Handling;
37 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
38 with Ada.Unchecked_Deallocation;
39 with Ada.Containers.Generic_Array_Sort;
40
41 with Interfaces; use Interfaces;
42
43 with System; use System;
44 with System.Storage_Elements; use System.Storage_Elements;
45 with System.Address_Image;
46 with System.IO; use System.IO;
47 with System.Object_Reader; use System.Object_Reader;
48 with System.Traceback_Entries; use System.Traceback_Entries;
49 with System.Mmap; use System.Mmap;
50 with System.Bounded_Strings; use System.Bounded_Strings;
51
52 package 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;
1633 end System.Dwarf_Lines;
Mirror of the offical gcc git repository hosted at gcc.gnu.org