------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                   S Y S T E M . D W A R F _ L I N E S                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2009-2021, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling;
with Ada.Containers.Generic_Array_Sort;
with Ada.Unchecked_Deallocation;

with Interfaces; use Interfaces;

with System;                   use System;
with System.Address_Image;
with System.Bounded_Strings;   use System.Bounded_Strings;
with System.IO;                use System.IO;
with System.Mmap;              use System.Mmap;
with System.Object_Reader;     use System.Object_Reader;
with System.Storage_Elements;  use System.Storage_Elements;

package body System.Dwarf_Lines is

   SSU : constant := System.Storage_Unit;

   function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset;
   --  Return the displacement between the load address present in the binary
   --  and the run-time address at which it is loaded (i.e. non-zero for PIE).

   function String_Length (Str : Str_Access) return Natural;
   --  Return the length of the C string Str

   ---------------------------------
   -- DWARF Parser Implementation --
   ---------------------------------

   procedure Read_Initial_Length
     (S    : in out Mapped_Stream;
      Len  :    out Offset;
      Is64 :    out Boolean);
   --  Read initial length as specified by 7.2.2

   procedure Read_Section_Offset
     (S    : in out Mapped_Stream;
      Len  :    out Offset;
      Is64 :        Boolean);
   --  Read a section offset, as specified by 7.4

   procedure Read_Entry_Format_Array
     (S    : in out Mapped_Stream;
      A    :    out Entry_Format_Array;
      Len  :        uint8);
   --  Read an entry format array, as specified by 6.2.4.1

   procedure Read_Aranges_Entry
     (C     : in out Dwarf_Context;
      Start :    out Address;
      Len   :    out Storage_Count);
   --  Read a single .debug_aranges pair

   procedure Read_Aranges_Header
     (C           : in out Dwarf_Context;
      Info_Offset :    out Offset;
      Success     :    out Boolean);
   --  Read .debug_aranges header

   procedure Aranges_Lookup
     (C           : in out Dwarf_Context;
      Addr        :        Address;
      Info_Offset :    out Offset;
      Success     :    out Boolean);
   --  Search for Addr in .debug_aranges and return offset Info_Offset in
   --  .debug_info.

   procedure Skip_Form
     (S      : in out Mapped_Stream;
      Form   :        uint32;
      Is64   :        Boolean;
      Ptr_Sz :        uint8);
   --  Advance offset in S for Form.

   procedure Seek_Abbrev
     (C             : in out Dwarf_Context;
      Abbrev_Offset :        Offset;
      Abbrev_Num    :        uint32);
   --  Seek to abbrev Abbrev_Num (starting from Abbrev_Offset)

   procedure Debug_Info_Lookup
     (C           : in out Dwarf_Context;
      Info_Offset :        Offset;
      Line_Offset :    out Offset;
      Success     :    out Boolean);
   --  Search for stmt_list tag in Info_Offset and set Line_Offset to the
   --  offset in .debug_lines. Only look at the first DIE, which should be
   --  a compilation unit.

   procedure Initialize_Pass (C : in out Dwarf_Context);
   --  Seek to the first byte of the first header and prepare to make a pass
   --  over the line number entries.

   procedure Initialize_State_Machine (C : in out Dwarf_Context);
   --  Set all state machine registers to their specified initial values

   procedure Parse_Header (C : in out Dwarf_Context);
   --  Decode a DWARF statement program header

   procedure Read_And_Execute_Insn
     (C    : in out Dwarf_Context;
      Done :    out Boolean);
   --  Read an execute a statement program instruction

   function To_File_Name
     (C    : in out Dwarf_Context;
      File :        uint32) return String;
   --  Extract a file name from the header

   type Callback is not null access procedure (C : in out Dwarf_Context);
   procedure For_Each_Row (C : in out Dwarf_Context; F : Callback);
   --  Traverse each .debug_line entry with a callback

   procedure Dump_Row (C : in out Dwarf_Context);
   --  Dump a single row

   function "<" (Left, Right : Search_Entry) return Boolean;
   --  For sorting Search_Entry

   procedure Sort_Search_Array is new Ada.Containers.Generic_Array_Sort
     (Index_Type   => Natural,
      Element_Type => Search_Entry,
      Array_Type   => Search_Array);

   procedure Symbolic_Address
     (C           : in out Dwarf_Context;
      Addr        :        Address;
      Dir_Name    :    out Str_Access;
      File_Name   :    out Str_Access;
      Subprg_Name :    out String_Ptr_Len;
      Line_Num    :    out Natural);
   --  Symbolize one address

   -----------------------
   --  DWARF constants  --
   -----------------------

   --  3.1.1 Full and Partial Compilation Unit Entries

   DW_TAG_Compile_Unit : constant := 16#11#;

   DW_AT_Stmt_List : constant := 16#10#;

   --  6.2.4.1 Standard Content Descriptions (DWARF 5)

   DW_LNCT_path            : constant := 1;
   DW_LNCT_directory_index : constant := 2;
   --  DW_LNCT_timestamp   : constant := 3;
   --  DW_LNCT_size        : constant := 4;
   DW_LNCT_MD5             : constant := 5;
   DW_LNCT_lo_user         : constant := 16#2000#;
   DW_LNCT_hi_user         : constant := 16#3fff#;

   --  6.2.5.2 Standard Opcodes

   DW_LNS_extended_op        : constant := 0;
   DW_LNS_copy               : constant := 1;
   DW_LNS_advance_pc         : constant := 2;
   DW_LNS_advance_line       : constant := 3;
   DW_LNS_set_file           : constant := 4;
   DW_LNS_set_column         : constant := 5;
   DW_LNS_negate_stmt        : constant := 6;
   DW_LNS_set_basic_block    : constant := 7;
   DW_LNS_const_add_pc       : constant := 8;
   DW_LNS_fixed_advance_pc   : constant := 9;
   DW_LNS_set_prologue_end   : constant := 10;
   DW_LNS_set_epilogue_begin : constant := 11;
   DW_LNS_set_isa            : constant := 12;

   --  6.2.5.3 Extended Opcodes

   DW_LNE_end_sequence      : constant := 1;
   DW_LNE_set_address       : constant := 2;
   DW_LNE_define_file       : constant := 3;
   DW_LNE_set_discriminator : constant := 4;

   --  7.5.5 Classes and Forms

   DW_FORM_addr           : constant := 16#01#;
   DW_FORM_block2         : constant := 16#03#;
   DW_FORM_block4         : constant := 16#04#;
   DW_FORM_data2          : constant := 16#05#;
   DW_FORM_data4          : constant := 16#06#;
   DW_FORM_data8          : constant := 16#07#;
   DW_FORM_string         : constant := 16#08#;
   DW_FORM_block          : constant := 16#09#;
   DW_FORM_block1         : constant := 16#0a#;
   DW_FORM_data1          : constant := 16#0b#;
   DW_FORM_flag           : constant := 16#0c#;
   DW_FORM_sdata          : constant := 16#0d#;
   DW_FORM_strp           : constant := 16#0e#;
   DW_FORM_udata          : constant := 16#0f#;
   DW_FORM_ref_addr       : constant := 16#10#;
   DW_FORM_ref1           : constant := 16#11#;
   DW_FORM_ref2           : constant := 16#12#;
   DW_FORM_ref4           : constant := 16#13#;
   DW_FORM_ref8           : constant := 16#14#;
   DW_FORM_ref_udata      : constant := 16#15#;
   DW_FORM_indirect       : constant := 16#16#;
   DW_FORM_sec_offset     : constant := 16#17#;
   DW_FORM_exprloc        : constant := 16#18#;
   DW_FORM_flag_present   : constant := 16#19#;
   DW_FORM_strx           : constant := 16#1a#;
   DW_FORM_addrx          : constant := 16#1b#;
   DW_FORM_ref_sup4       : constant := 16#1c#;
   DW_FORM_strp_sup       : constant := 16#1d#;
   DW_FORM_data16         : constant := 16#1e#;
   DW_FORM_line_strp      : constant := 16#1f#;
   DW_FORM_ref_sig8       : constant := 16#20#;
   DW_FORM_implicit_const : constant := 16#21#;
   DW_FORM_loclistx       : constant := 16#22#;
   DW_FORM_rnglistx       : constant := 16#23#;
   DW_FORM_ref_sup8       : constant := 16#24#;
   DW_FORM_strx1          : constant := 16#25#;
   DW_FORM_strx2          : constant := 16#26#;
   DW_FORM_strx3          : constant := 16#27#;
   DW_FORM_strx4          : constant := 16#28#;
   DW_FORM_addrx1         : constant := 16#29#;
   DW_FORM_addrx2         : constant := 16#2a#;
   DW_FORM_addrx3         : constant := 16#2b#;
   DW_FORM_addrx4         : constant := 16#2c#;

   ---------
   -- "<" --
   ---------

   function "<" (Left, Right : Search_Entry) return Boolean is
   begin
      return Left.First < Right.First;
   end "<";

   -----------
   -- Close --
   -----------

   procedure Close (C : in out Dwarf_Context) is
      procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
        (Object_File,
         Object_File_Access);
      procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
        (Search_Array,
         Search_Array_Access);

   begin
      if C.Has_Debug then
         Close (C.Lines);
         Close (C.Abbrev);
         Close (C.Info);
         Close (C.Aranges);
      end if;

      Close (C.Obj.all);
      Unchecked_Deallocation (C.Obj);

      Unchecked_Deallocation (C.Cache);
   end Close;

   ----------
   -- Dump --
   ----------

   procedure Dump (C : in out Dwarf_Context) is
   begin
      For_Each_Row (C, Dump_Row'Access);
   end Dump;

   --------------
   -- Dump_Row --
   --------------

   procedure Dump_Row (C : in out Dwarf_Context) is
      PC  : constant Integer_Address := Integer_Address (C.Registers.Address);
      Off : Offset;

   begin
      Tell (C.Lines, Off);

      Put (System.Address_Image (To_Address (PC)));
      Put (" ");
      Put (To_File_Name (C, C.Registers.File));
      Put (":");

      declare
         Image : constant String := uint32'Image (C.Registers.Line);
      begin
         Put_Line (Image (2 .. Image'Last));
      end;

      Seek (C.Lines, Off);
   end Dump_Row;

   procedure Dump_Cache (C : Dwarf_Context) is
      Cache : constant Search_Array_Access := C.Cache;
      S     : Object_Symbol;
      Name  : String_Ptr_Len;

   begin
      if Cache = null then
         Put_Line ("No cache");
         return;
      end if;

      for I in Cache'Range loop
         declare
            E : Search_Entry renames Cache (I);
            Base_Address : constant System.Address :=
              To_Address (Integer_Address (C.Low + Storage_Count (E.First)));
         begin
            Put (System.Address_Image (Base_Address));
            Put (" - ");
            Put (System.Address_Image (Base_Address + Storage_Count (E.Size)));
            Put (" l@");
            Put (System.Address_Image (To_Address (Integer_Address (E.Line))));
            Put (": ");
            S    := Read_Symbol (C.Obj.all, Offset (E.Sym));
            Name := Object_Reader.Name (C.Obj.all, S);
            Put (String (Name.Ptr (1 .. Name.Len)));
            New_Line;
         end;
      end loop;
   end Dump_Cache;

   ------------------
   -- For_Each_Row --
   ------------------

   procedure For_Each_Row (C : in out Dwarf_Context; F : Callback) is
      Done : Boolean;

   begin
      Initialize_Pass (C);

      loop
         Read_And_Execute_Insn (C, Done);

         if C.Registers.Is_Row then
            F.all (C);
         end if;

         exit when Done;
      end loop;
   end For_Each_Row;

   ---------------------------
   -- Get_Load_Displacement --
   ---------------------------

   function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset is
   begin
      if C.Load_Address /= Null_Address then
         return C.Load_Address - Address (Get_Load_Address (C.Obj.all));
      else
         return 0;
      end if;
   end Get_Load_Displacement;

   ---------------------
   -- Initialize_Pass --
   ---------------------

   procedure Initialize_Pass (C : in out Dwarf_Context) is
   begin
      Seek (C.Lines, 0);
      C.Next_Header := 0;
      Initialize_State_Machine (C);
   end Initialize_Pass;

   ------------------------------
   -- Initialize_State_Machine --
   ------------------------------

   procedure Initialize_State_Machine (C : in out Dwarf_Context) is
   begin
      --  Table 6.4: Line number program initial state

      C.Registers :=
        (Address        => 0,
         File           => 1,
         Line           => 1,
         Column         => 0,
         Is_Stmt        => C.Header.Default_Is_Stmt /= 0,
         Basic_Block    => False,
         End_Sequence   => False,
         Is_Row         => False);
   end Initialize_State_Machine;

   ---------------
   -- Is_Inside --
   ---------------

   function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is
      Disp : constant Storage_Offset := Get_Load_Displacement (C);

   begin
      return Addr >= C.Low + Disp and then Addr <= C.High + Disp;
   end Is_Inside;

   -----------------
   -- Low_Address --
   -----------------

   function Low_Address (C : Dwarf_Context) return Address is
   begin
      return C.Low + Get_Load_Displacement (C);
   end Low_Address;

   ----------
   -- Open --
   ----------

   procedure Open
     (File_Name :     String;
      C         : out Dwarf_Context;
      Success   : out Boolean)
   is
      Abbrev, Aranges, Lines, Info, Line_Str : Object_Section;
      Hi, Lo                                 : uint64;

   begin
      --  Not a success by default

      Success := False;

      --  Open file with In_Exception set so we can control the failure mode

      C.Obj := Open (File_Name, In_Exception => True);

      if C.Obj = null then
         if C.In_Exception then
            return;
         else
            raise Dwarf_Error with "could not open file";
         end if;
      end if;

      Success := True;

      --  Get address bounds for executable code. Note that such code
      --  might come from multiple sections.

      Get_Xcode_Bounds (C.Obj.all, Lo, Hi);
      C.Low  := Address (Lo);
      C.High := Address (Hi);

      --  Create a stream for debug sections

      if Format (C.Obj.all) = XCOFF32 then
         Abbrev   := Get_Section (C.Obj.all, ".dwabrev");
         Aranges  := Get_Section (C.Obj.all, ".dwarnge");
         Info     := Get_Section (C.Obj.all, ".dwinfo");
         Lines    := Get_Section (C.Obj.all, ".dwline");
         Line_Str := Get_Section (C.Obj.all, ".dwlistr");
      else
         Abbrev   := Get_Section (C.Obj.all, ".debug_abbrev");
         Aranges  := Get_Section (C.Obj.all, ".debug_aranges");
         Info     := Get_Section (C.Obj.all, ".debug_info");
         Lines    := Get_Section (C.Obj.all, ".debug_line");
         Line_Str := Get_Section (C.Obj.all, ".debug_line_str");
      end if;

      if Abbrev = Null_Section
        or else Aranges = Null_Section
        or else Info = Null_Section
        or else Lines = Null_Section
      then
         pragma Annotate
           (CodePeer, False_Positive,
            "test always true", "codepeer got confused");

         C.Has_Debug := False;
         return;
      end if;

      C.Abbrev  := Create_Stream (C.Obj.all, Abbrev);
      C.Aranges := Create_Stream (C.Obj.all, Aranges);
      C.Info    := Create_Stream (C.Obj.all, Info);
      C.Lines   := Create_Stream (C.Obj.all, Lines);

      --  The .debug_line_str section may be available in DWARF 5

      if Line_Str /= Null_Section then
         C.Line_Str := Create_Stream (C.Obj.all, Line_Str);
      end if;

      --  All operations are successful, context is valid

      C.Has_Debug := True;
   end Open;

   ------------------
   -- Parse_Header --
   ------------------

   procedure Parse_Header (C : in out Dwarf_Context) is
      Header : Line_Info_Header renames C.Header;

      Char : uint8;
      Prev : uint8;
      --  The most recently read character and the one preceding it

      Dummy : uint32;
      --  Destination for reads we don't care about

      Buf : Buffer;
      Off : Offset;

      First_Byte_Of_Header : Offset;
      Last_Byte_Of_Header  : Offset;

      Standard_Opcode_Lengths : Opcode_Length_Array;
      pragma Unreferenced (Standard_Opcode_Lengths);

   begin
      Tell (C.Lines, First_Byte_Of_Header);

      Read_Initial_Length (C.Lines, Header.Unit_Length, Header.Is64);

      Tell (C.Lines, Off);
      C.Next_Header := Off + Header.Unit_Length;

      Header.Version := Read (C.Lines);

      if Header.Version >= 5 then
         Header.Address_Size          := Read (C.Lines);
         Header.Segment_Selector_Size := Read (C.Lines);
      else
         Header.Address_Size          := 0;
         Header.Segment_Selector_Size := 0;
      end if;

      Header.Header_Length := Read (C.Lines);
      Tell (C.Lines, Last_Byte_Of_Header);
      Last_Byte_Of_Header :=
        Last_Byte_Of_Header + Offset (Header.Header_Length) - 1;

      Header.Minimum_Insn_Length := Read (C.Lines);

      if Header.Version >= 4 then
         Header.Maximum_Op_Per_Insn := Read (C.Lines);
      else
         Header.Maximum_Op_Per_Insn := 0;
      end if;

      Header.Default_Is_Stmt := Read (C.Lines);
      Header.Line_Base       := Read (C.Lines);
      Header.Line_Range      := Read (C.Lines);
      Header.Opcode_Base     := Read (C.Lines);

      --  Standard_Opcode_Lengths is an array of Opcode_Base bytes specifying
      --  the number of LEB128 operands for each of the standard opcodes.

      for J in 1 .. Integer (Header.Opcode_Base - 1) loop
         Standard_Opcode_Lengths (J) := Read (C.Lines);
      end loop;

      --  The Directories table follows. Up to DWARF 4, this is a list of null
      --  terminated strings terminated by a null byte. In DWARF 5, this is a
      --  sequence of Directories_Count entries which are encoded as described
      --  by the Directory_Entry_Format field. We store its offset for later.

      if Header.Version <= 4 then
         Tell (C.Lines, Header.Directories);
         Char := Read (C.Lines);

         if Char /= 0 then
            loop
               Prev := Char;
               Char := Read (C.Lines);
               exit when Char = 0 and Prev = 0;
            end loop;
         end if;

      else
         Header.Directory_Entry_Format_Count := Read (C.Lines);
         Read_Entry_Format_Array (C.Lines,
           Header.Directory_Entry_Format,
           Header.Directory_Entry_Format_Count);

         Header.Directories_Count := Read_LEB128 (C.Lines);
         Tell (C.Lines, Header.Directories);
         for J in 1 .. Header.Directories_Count loop
            for K in 1 .. Integer (Header.Directory_Entry_Format_Count) loop
               Skip_Form (C.Lines,
                 Header.Directory_Entry_Format (K).Form,
                 Header.Is64,
                 Header.Address_Size);
            end loop;
         end loop;
      end if;

      --  The File_Names table is next. Up to DWARF 4, this is a list of record
      --  containing a null terminated string for the file name, an unsigned
      --  LEB128 directory index in the Directories table, an unsigned LEB128
      --  modification time, and an unsigned LEB128 for the file length; the
      --  table is terminated by a null byte. In DWARF 5, this is a sequence
      --  of File_Names_Count entries which are encoded as described by the
      --  File_Name_Entry_Format field. We store its offset for later decoding.

      if Header.Version <= 4 then
         Tell (C.Lines, Header.File_Names);

         --  Read the file names

         loop
            Read_C_String (C.Lines, Buf);
            exit when Buf (0) = 0;
            Dummy := Read_LEB128 (C.Lines); --  Skip the directory index.
            Dummy := Read_LEB128 (C.Lines); --  Skip the modification time.
            Dummy := Read_LEB128 (C.Lines); --  Skip the file length.
         end loop;

      else
         Header.File_Name_Entry_Format_Count := Read (C.Lines);
         Read_Entry_Format_Array (C.Lines,
           Header.File_Name_Entry_Format,
           Header.File_Name_Entry_Format_Count);

         Header.File_Names_Count := Read_LEB128 (C.Lines);
         Tell (C.Lines, Header.File_Names);
         for J in 1 .. Header.File_Names_Count loop
            for K in 1 .. Integer (Header.File_Name_Entry_Format_Count) loop
               Skip_Form (C.Lines,
                 Header.File_Name_Entry_Format (K).Form,
                 Header.Is64,
                 Header.Address_Size);
            end loop;
         end loop;
      end if;

      --  Check we're where we think we are. This sanity check ensures we think
      --  the header ends where the header says it does. It we aren't, then we
      --  have probably gotten out of sync somewhere.

      Tell (C.Lines, Off);

      if Header.Unit_Length /= 0
        and then Off /= Last_Byte_Of_Header + 1
      then
         raise Dwarf_Error with "parse error reading DWARF information";
      end if;
   end Parse_Header;

   ---------------------------
   -- Read_And_Execute_Insn --
   ---------------------------

   procedure Read_And_Execute_Insn
     (C    : in out Dwarf_Context;
      Done :    out Boolean)
   is
      Opcode          : uint8;
      Extended_Opcode : uint8;
      uint32_Operand  : uint32;
      int32_Operand   : int32;
      uint16_Operand  : uint16;
      Off             : Offset;

      Extended_Length : uint32;
      pragma Unreferenced (Extended_Length);

      Obj : Object_File renames C.Obj.all;
      Registers : Line_Info_Registers renames C.Registers;
      Header : Line_Info_Header renames C.Header;

   begin
      Done             := False;
      Registers.Is_Row := False;

      if Registers.End_Sequence then
         Initialize_State_Machine (C);
      end if;

      --  If we have reached the next header, read it. Beware of possibly empty
      --  blocks.

      --  When testing for the end of section, beware of possible zero padding
      --  at the end. Bail out as soon as there's not even room for at least a
      --  DW_LNE_end_sequence, 3 bytes from Off to Off+2. This resolves to
      --  Off+2 > Last_Offset_Within_Section, that is Off+2 > Section_Length-1,
      --  or Off+3 > Section_Length.

      Tell (C.Lines, Off);
      while Off = C.Next_Header loop
         Initialize_State_Machine (C);
         Parse_Header (C);
         Tell (C.Lines, Off);
         exit when Off + 3 > Length (C.Lines);
      end loop;

      --  Test whether we're done

      Tell (C.Lines, Off);

      --  We are finished when we either reach the end of the section, or we
      --  have reached zero padding at the end of the section.

      if Header.Unit_Length = 0 or else Off + 3 > Length (C.Lines) then
         Done := True;
         return;
      end if;

      --  Read and interpret an instruction

      Opcode := Read (C.Lines);

      --  Extended opcodes

      if Opcode = DW_LNS_extended_op then
         Extended_Length := Read_LEB128 (C.Lines);
         Extended_Opcode := Read (C.Lines);

         case Extended_Opcode is
            when DW_LNE_end_sequence =>

               --  Mark the end of a sequence of source locations

               Registers.End_Sequence := True;
               Registers.Is_Row       := True;

            when DW_LNE_set_address =>

               --  Set the program counter to a word

               Registers.Address := Read_Address (Obj, C.Lines);

            when DW_LNE_define_file =>

               --  Not implemented

               raise Dwarf_Error with "DWARF operator not implemented";

            when DW_LNE_set_discriminator =>

               --  Ignored

               int32_Operand := Read_LEB128 (C.Lines);

            when others =>

               --  Fail on an unrecognized opcode

               raise Dwarf_Error with "DWARF operator not implemented";
         end case;

      --  Standard opcodes

      elsif Opcode < Header.Opcode_Base then
         case Opcode is

            --  Append a row to the line info matrix

            when DW_LNS_copy =>
               Registers.Basic_Block := False;
               Registers.Is_Row      := True;

            --  Add an unsigned word to the program counter

            when DW_LNS_advance_pc =>
               uint32_Operand    := Read_LEB128 (C.Lines);
               Registers.Address :=
                 Registers.Address +
                 uint64 (uint32_Operand * uint32 (Header.Minimum_Insn_Length));

            --  Add a signed word to the current source line

            when DW_LNS_advance_line =>
               int32_Operand  := Read_LEB128 (C.Lines);
               Registers.Line :=
                 uint32 (int32 (Registers.Line) + int32_Operand);

            --  Set the current source file

            when DW_LNS_set_file =>
               uint32_Operand := Read_LEB128 (C.Lines);
               Registers.File := uint32_Operand;

            --  Set the current source column

            when DW_LNS_set_column =>
               uint32_Operand   := Read_LEB128 (C.Lines);
               Registers.Column := uint32_Operand;

            --  Toggle the "is statement" flag. GCC doesn't seem to set this???

            when DW_LNS_negate_stmt =>
               Registers.Is_Stmt := not Registers.Is_Stmt;

            --  Mark the beginning of a basic block

            when DW_LNS_set_basic_block =>
               Registers.Basic_Block := True;

            --  Advance the program counter as by the special opcode 255

            when DW_LNS_const_add_pc =>
               Registers.Address :=
                 Registers.Address +
                 uint64
                   (((255 - Header.Opcode_Base) / Header.Line_Range) *
                    Header.Minimum_Insn_Length);

            --  Advance the program counter by a constant

            when DW_LNS_fixed_advance_pc =>
               uint16_Operand    := Read (C.Lines);
               Registers.Address :=
                 Registers.Address + uint64 (uint16_Operand);

            --  The following are not implemented and ignored

            when DW_LNS_set_prologue_end =>
               null;

            when DW_LNS_set_epilogue_begin =>
               null;

            when DW_LNS_set_isa =>
               null;

            --  Anything else is an error

            when others =>
               raise Dwarf_Error with "DWARF operator not implemented";
         end case;

      --  Decode a special opcode. This is a line and address increment encoded
      --  in a single byte 'special opcode' as described in 6.2.5.1.

      else
         declare
            Address_Increment : int32;
            Line_Increment    : int32;

         begin
            Opcode := Opcode - Header.Opcode_Base;

            --  The adjusted opcode is a uint8 encoding an address increment
            --  and a signed line increment. The upperbound is allowed to be
            --  greater than int8'last so we decode using int32 directly to
            --  prevent overflows.

            Address_Increment :=
              int32 (Opcode / Header.Line_Range) *
              int32 (Header.Minimum_Insn_Length);
            Line_Increment :=
              int32 (Header.Line_Base) +
              int32 (Opcode mod Header.Line_Range);

            Registers.Address :=
              Registers.Address + uint64 (Address_Increment);
            Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment);
            Registers.Basic_Block    := False;
            Registers.Is_Row         := True;
         end;
      end if;

   exception
      when Dwarf_Error =>

         --  In case of errors during parse, just stop reading

         Registers.Is_Row := False;
         Done             := True;
   end Read_And_Execute_Insn;

   ----------------------
   -- Set_Load_Address --
   ----------------------

   procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is
   begin
      C.Load_Address := Addr;
   end Set_Load_Address;

   ------------------
   -- To_File_Name --
   ------------------

   function To_File_Name
     (C    : in out Dwarf_Context;
      File :        uint32) return String
   is
      Buf : Buffer;
      Off : Offset;

      Dir_Idx : uint32;
      pragma Unreferenced (Dir_Idx);

      Mod_Time : uint32;
      pragma Unreferenced (Mod_Time);

      Length : uint32;
      pragma Unreferenced (Length);

      File_Entry_Format : Entry_Format_Array
        renames C.Header.File_Name_Entry_Format;

   begin
      Seek (C.Lines, C.Header.File_Names);

      --  Find the entry. Note that, up to DWARF 4, the index is 1-based
      --  whereas, in DWARF 5, it is 0-based.

      if C.Header.Version <= 4 then
         for J in 1 .. File loop
            Read_C_String (C.Lines, Buf);

            if Buf (Buf'First) = 0 then
               return "???";
            end if;

            Dir_Idx  := Read_LEB128 (C.Lines);
            Mod_Time := Read_LEB128 (C.Lines);
            Length   := Read_LEB128 (C.Lines);
         end loop;

      --  DWARF 5

      else
         for J in 0 .. File loop
            for K in 1 .. Integer (C.Header.File_Name_Entry_Format_Count) loop
               if File_Entry_Format (K).C_Type = DW_LNCT_path then
                  case File_Entry_Format (K).Form is
                     when DW_FORM_string =>
                        Read_C_String (C.Lines, Buf);

                     when DW_FORM_line_strp =>
                        Read_Section_Offset (C.Lines, Off, C.Header.Is64);
                        if J = File then
                           Seek (C.Line_Str, Off);
                           Read_C_String (C.Line_Str, Buf);
                        end if;

                     when others =>
                        raise Dwarf_Error with "DWARF form not implemented";
                  end case;

               else
                  Skip_Form (C.Lines,
                    File_Entry_Format (K).Form,
                    C.Header.Is64,
                    C.Header.Address_Size);
               end if;
            end loop;
         end loop;
      end if;

      return To_String (Buf);
   end To_File_Name;

   -------------------------
   -- Read_Initial_Length --
   -------------------------

   procedure Read_Initial_Length
     (S    : in out Mapped_Stream;
      Len  :    out Offset;
      Is64 :    out Boolean)
   is
      Len32 : uint32;
      Len64 : uint64;

   begin
      Len32 := Read (S);
      if Len32 < 16#ffff_fff0# then
         Is64 := False;
         Len  := Offset (Len32);
      elsif Len32 < 16#ffff_ffff# then
         --  Invalid length
         raise Constraint_Error;
      else
         Is64  := True;
         Len64 := Read (S);
         Len   := Offset (Len64);
      end if;
   end Read_Initial_Length;

   -------------------------
   -- Read_Section_Offset --
   -------------------------

   procedure Read_Section_Offset
     (S    : in out Mapped_Stream;
      Len  :    out Offset;
      Is64 :        Boolean)
   is
   begin
      if Is64 then
         Len := Offset (uint64'(Read (S)));
      else
         Len := Offset (uint32'(Read (S)));
      end if;
   end Read_Section_Offset;

   -----------------------------
   -- Read_Entry_Format_Array --
   -----------------------------

   procedure Read_Entry_Format_Array
     (S    : in out Mapped_Stream;
      A    :    out Entry_Format_Array;
      Len  :        uint8)
   is
      C_Type, Form : uint32;
      N            : Integer;

   begin
      N := A'First;

      for J in 1 .. Len loop
         C_Type := Read_LEB128 (S);
         Form   := Read_LEB128 (S);

         case C_Type is
            when DW_LNCT_path .. DW_LNCT_MD5 =>
               if N not in A'Range then
                  raise Dwarf_Error with "duplicate DWARF content type";
               end if;

               A (N) := (C_Type, Form);
               N := N + 1;

            when DW_LNCT_lo_user .. DW_LNCT_hi_user =>
               null;

            when others =>
               raise Dwarf_Error with "DWARF content type not implemented";
         end case;
      end loop;
   end Read_Entry_Format_Array;

   --------------------
   -- Aranges_Lookup --
   --------------------

   procedure Aranges_Lookup
     (C           : in out Dwarf_Context;
      Addr        :        Address;
      Info_Offset :    out Offset;
      Success     :    out Boolean)
   is
   begin
      Info_Offset := 0;
      Seek (C.Aranges, 0);

      while Tell (C.Aranges) < Length (C.Aranges) loop
         Read_Aranges_Header (C, Info_Offset, Success);
         exit when not Success;

         loop
            declare
               Start : Address;
               Len   : Storage_Count;
            begin
               Read_Aranges_Entry (C, Start, Len);
               exit when Start = 0 and Len = 0;
               if Addr >= Start
                 and then Addr < Start + Len
               then
                  Success := True;
                  return;
               end if;
            end;
         end loop;
      end loop;

      Success := False;
   end Aranges_Lookup;

   ---------------
   -- Skip_Form --
   ---------------

   procedure Skip_Form
     (S      : in out Mapped_Stream;
      Form   :        uint32;
      Is64   :        Boolean;
      Ptr_Sz :        uint8)
   is
      Skip : Offset;

   begin
      --  7.5.5 Classes and Forms

      case Form is
         when DW_FORM_addr =>
            Skip := Offset (Ptr_Sz);
         when DW_FORM_block1 =>
            Skip := Offset (uint8'(Read (S)));
         when DW_FORM_block2 =>
            Skip := Offset (uint16'(Read (S)));
         when DW_FORM_block4 =>
            Skip := Offset (uint32'(Read (S)));
         when DW_FORM_block | DW_FORM_exprloc =>
            Skip := Offset (uint32'(Read_LEB128 (S)));
         when DW_FORM_addrx1
            | DW_FORM_data1
            | DW_FORM_flag
            | DW_FORM_ref1
            | DW_FORM_strx1
           =>
            Skip := 1;
         when DW_FORM_addrx2
            | DW_FORM_data2
            | DW_FORM_ref2
            | DW_FORM_strx2
           =>
            Skip := 2;
         when DW_FORM_addrx3 | DW_FORM_strx3 =>
            Skip := 3;
         when DW_FORM_addrx4
            | DW_FORM_data4
            | DW_FORM_ref4
            | DW_FORM_ref_sup4
            | DW_FORM_strx4
           =>
            Skip := 4;
         when DW_FORM_data8
            | DW_FORM_ref8
            | DW_FORM_ref_sup8
            | DW_FORM_ref_sig8
           =>
            Skip := 8;
         when DW_FORM_data16 =>
            Skip := 16;
         when DW_FORM_sdata =>
            declare
               Val : constant int32 := Read_LEB128 (S);
               pragma Unreferenced (Val);
            begin
               return;
            end;
         when DW_FORM_addrx
            | DW_FORM_loclistx
            | DW_FORM_ref_udata
            | DW_FORM_rnglistx
            | DW_FORM_strx
            | DW_FORM_udata
           =>
            declare
               Val : constant uint32 := Read_LEB128 (S);
               pragma Unreferenced (Val);
            begin
               return;
            end;
         when DW_FORM_flag_present | DW_FORM_implicit_const =>
            return;
         when DW_FORM_ref_addr
            | DW_FORM_sec_offset
            | DW_FORM_strp
            | DW_FORM_line_strp
            | DW_FORM_strp_sup
           =>
            Skip := (if Is64 then 8 else 4);
         when DW_FORM_string =>
            while uint8'(Read (S)) /= 0 loop
               null;
            end loop;
            return;
         when DW_FORM_indirect =>
            raise Dwarf_Error with "DW_FORM_indirect not implemented";
         when others =>
            raise Dwarf_Error with "DWARF form not implemented";
      end case;

      Seek (S, Tell (S) + Skip);
   end Skip_Form;

   -----------------
   -- Seek_Abbrev --
   -----------------

   procedure Seek_Abbrev
     (C             : in out Dwarf_Context;
      Abbrev_Offset :        Offset;
      Abbrev_Num    :        uint32)
   is
      Abbrev    : uint32;
      Tag       : uint32;
      Has_Child : uint8;
      pragma Unreferenced (Tag, Has_Child);

   begin
      Seek (C.Abbrev, Abbrev_Offset);

      --  7.5.3 Abbreviations Tables

      loop
         Abbrev := Read_LEB128 (C.Abbrev);

         exit when Abbrev = Abbrev_Num;

         Tag       := Read_LEB128 (C.Abbrev);
         Has_Child := Read (C.Abbrev);

         loop
            declare
               Name : constant uint32 := Read_LEB128 (C.Abbrev);
               Form : constant uint32 := Read_LEB128 (C.Abbrev);
               Cst  : int32;
               pragma Unreferenced (Cst);

            begin
               --  DW_FORM_implicit_const takes its value from the table

               if Form = DW_FORM_implicit_const then
                  Cst := Read_LEB128 (C.Abbrev);
               end if;

               exit when Name = 0 and then Form = 0;
            end;
         end loop;
      end loop;
   end Seek_Abbrev;

   -----------------------
   -- Debug_Info_Lookup --
   -----------------------

   procedure Debug_Info_Lookup
     (C           : in out Dwarf_Context;
      Info_Offset :        Offset;
      Line_Offset :    out Offset;
      Success     :    out Boolean)
   is
      Unit_Length   : Offset;
      Is64          : Boolean;
      Version       : uint16;
      Abbrev_Offset : Offset;
      Addr_Sz       : uint8;
      Abbrev        : uint32;
      Has_Child     : uint8;
      pragma Unreferenced (Has_Child);
      Unit_Type     : uint8;
      pragma Unreferenced (Unit_Type);

   begin
      Line_Offset := 0;
      Success := False;

      Seek (C.Info, Info_Offset);

      --  7.5.1.1 Compilation Unit Header

      Read_Initial_Length (C.Info, Unit_Length, Is64);

      Version := Read (C.Info);

      if Version >= 5 then
         Unit_Type := Read (C.Info);

         Addr_Sz := Read (C.Info);
         if Addr_Sz /= (Address'Size / SSU) then
            return;
         end if;

         Read_Section_Offset (C.Info, Abbrev_Offset, Is64);

      elsif Version >= 2 then
         Read_Section_Offset (C.Info, Abbrev_Offset, Is64);

         Addr_Sz := Read (C.Info);
         if Addr_Sz /= (Address'Size / SSU) then
            return;
         end if;

      else
         return;
      end if;

      --  Read DIEs

      loop
         Abbrev := Read_LEB128 (C.Info);
         exit when Abbrev /= 0;
      end loop;

      --  Read abbrev table

      Seek_Abbrev (C, Abbrev_Offset, Abbrev);

      --  Then the tag

      if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then
         return;
      end if;

      --  Then the has child flag

      Has_Child := Read (C.Abbrev);

      loop
         declare
            Name : constant uint32 := Read_LEB128 (C.Abbrev);
            Form : constant uint32 := Read_LEB128 (C.Abbrev);
         begin
            exit when Name = 0 and Form = 0;
            if Name = DW_AT_Stmt_List then
               case Form is
                  when DW_FORM_sec_offset =>
                     Read_Section_Offset (C.Info, Line_Offset, Is64);
                  when DW_FORM_data4 =>
                     Line_Offset := Offset (uint32'(Read (C.Info)));
                  when DW_FORM_data8 =>
                     Line_Offset := Offset (uint64'(Read (C.Info)));
                  when others =>
                     --  Unhandled form
                     return;
               end case;

               Success := True;
               return;
            else
               Skip_Form (C.Info, Form, Is64, Addr_Sz);
            end if;
         end;
      end loop;
   end Debug_Info_Lookup;

   -------------------------
   -- Read_Aranges_Header --
   -------------------------

   procedure Read_Aranges_Header
     (C           : in out Dwarf_Context;
      Info_Offset :    out Offset;
      Success     :    out Boolean)
   is
      Unit_Length : Offset;
      Is64        : Boolean;
      Version     : uint16;
      Sz          : uint8;

   begin
      Success     := False;
      Info_Offset := 0;

      Read_Initial_Length (C.Aranges, Unit_Length, Is64);

      Version := Read (C.Aranges);
      if Version /= 2 then
         return;
      end if;

      Read_Section_Offset (C.Aranges, Info_Offset, Is64);

      --  Read address_size (ubyte)

      Sz := Read (C.Aranges);
      if Sz /= (Address'Size / SSU) then
         return;
      end if;

      --  Read segment_size (ubyte)

      Sz := Read (C.Aranges);
      if Sz /= 0 then
         return;
      end if;

      --  Handle alignment on twice the address size

      declare
         Cur_Off : constant Offset := Tell (C.Aranges);
         Align   : constant Offset := 2 * Address'Size / SSU;
         Space   : constant Offset := Cur_Off mod Align;
      begin
         if Space /= 0 then
            Seek (C.Aranges, Cur_Off + Align - Space);
         end if;
      end;

      Success := True;
   end Read_Aranges_Header;

   ------------------------
   -- Read_Aranges_Entry --
   ------------------------

   procedure Read_Aranges_Entry
     (C     : in out Dwarf_Context;
      Start :    out Address;
      Len   :    out Storage_Count)
   is
   begin
      --  Read table

      if Address'Size = 32 then
         declare
            S, L : uint32;
         begin
            S     := Read (C.Aranges);
            L     := Read (C.Aranges);
            Start := Address (S);
            Len   := Storage_Count (L);
         end;

      elsif Address'Size = 64 then
         declare
            S, L : uint64;
         begin
            S     := Read (C.Aranges);
            L     := Read (C.Aranges);
            Start := Address (S);
            Len   := Storage_Count (L);
         end;

      else
         raise Constraint_Error;
      end if;
   end Read_Aranges_Entry;

   ------------------
   -- Enable_Cache --
   ------------------

   procedure Enable_Cache (C : in out Dwarf_Context) is
      Cache : Search_Array_Access;

   begin
      --  Phase 1: count number of symbols.
      --  Phase 2: fill the cache.

      declare
         S               : Object_Symbol;
         Val             : uint64;
         Xcode_Low       : constant uint64 := uint64 (C.Low);
         Xcode_High      : constant uint64 := uint64 (C.High);
         Sz              : uint32;
         Addr, Prev_Addr : uint32;
         Nbr_Symbols     : Natural;
      begin
         for Phase in 1 .. 2 loop
            Nbr_Symbols := 0;
            S           := First_Symbol (C.Obj.all);
            Prev_Addr   := uint32'Last;
            while S /= Null_Symbol loop
               --  Discard symbols of length 0 or located outside of the
               --  execution code section outer boundaries.

               Sz := uint32 (Size (S));
               Val := Value (S);

               if Sz > 0
                 and then Val >= Xcode_Low
                 and then Val <= Xcode_High
               then
                  Addr := uint32 (Val - Xcode_Low);

                  --  Try to filter symbols at the same address. This is a best
                  --  effort as they might not be consecutive.

                  if Addr /= Prev_Addr then
                     Nbr_Symbols := Nbr_Symbols + 1;
                     Prev_Addr   := Addr;

                     if Phase = 2 then
                        C.Cache (Nbr_Symbols) :=
                          (First => Addr,
                           Size  => Sz,
                           Sym   => uint32 (Off (S)),
                           Line  => 0);
                     end if;
                  end if;
               end if;

               S := Next_Symbol (C.Obj.all, S);
            end loop;

            if Phase = 1 then
               --  Allocate the cache

               Cache   := new Search_Array (1 .. Nbr_Symbols);
               C.Cache := Cache;
            end if;
         end loop;
         pragma Assert (Nbr_Symbols = C.Cache'Last);
      end;

      --  Sort the cache

      Sort_Search_Array (C.Cache.all);

      --  Set line offsets

      if not C.Has_Debug then
         return;
      end if;

      declare
         Info_Offset : Offset;
         Line_Offset : Offset;
         Success     : Boolean;
         Ar_Start    : Address;
         Ar_Len      : Storage_Count;
         Start, Len  : uint32;
         First, Last : Natural;
         Mid         : Natural;

      begin
         Seek (C.Aranges, 0);

         while Tell (C.Aranges) < Length (C.Aranges) loop
            Read_Aranges_Header (C, Info_Offset, Success);
            exit when not Success;

            Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success);
            exit when not Success;

            --  Read table

            loop
               Read_Aranges_Entry (C, Ar_Start, Ar_Len);
               exit when Ar_Start = Null_Address and Ar_Len = 0;

               Len   := uint32 (Ar_Len);
               Start := uint32 (Ar_Start - C.Low);

               --  Search START in the array

               First := Cache'First;
               Last  := Cache'Last;
               Mid := First;  --  In case of array with one element
               while First < Last loop
                  Mid := First + (Last - First) / 2;
                  if Start < Cache (Mid).First then
                     Last := Mid - 1;
                  elsif Start >= Cache (Mid).First + Cache (Mid).Size then
                     First := Mid + 1;
                  else
                     exit;
                  end if;
               end loop;

               --  Fill info

               --  There can be overlapping symbols

               while Mid > Cache'First
                 and then Cache (Mid - 1).First <= Start
                 and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start
               loop
                  Mid := Mid - 1;
               end loop;
               while Mid <= Cache'Last loop
                  if Start < Cache (Mid).First + Cache (Mid).Size
                    and then Start + Len > Cache (Mid).First
                  then
                     --  MID is within the bounds

                     Cache (Mid).Line := uint32 (Line_Offset);
                  elsif Start + Len <= Cache (Mid).First then
                     --  Over

                     exit;
                  end if;
                  Mid := Mid + 1;
               end loop;
            end loop;
         end loop;
      end;
   end Enable_Cache;

   ----------------------
   -- Symbolic_Address --
   ----------------------

   procedure Symbolic_Address
     (C           : in out Dwarf_Context;
      Addr        :        Address;
      Dir_Name    :    out Str_Access;
      File_Name   :    out Str_Access;
      Subprg_Name :    out String_Ptr_Len;
      Line_Num    :    out Natural)
   is
      procedure Set_Result (Match : Line_Info_Registers);
      --  Set results using match

      procedure Set_Result (Match : Line_Info_Registers) is
         Dir_Idx : uint32;
         Off     : Offset;

         Mod_Time : uint32;
         pragma Unreferenced (Mod_Time);

         Length : uint32;
         pragma Unreferenced (Length);

         Directory_Entry_Format : Entry_Format_Array
           renames C.Header.Directory_Entry_Format;

         File_Entry_Format : Entry_Format_Array
           renames C.Header.File_Name_Entry_Format;

      begin
         Seek (C.Lines, C.Header.File_Names);
         Dir_Idx := 0;

         --  Find the entry. Note that, up to DWARF 4, the index is 1-based
         --  whereas, in DWARF 5, it is 0-based.

         if C.Header.Version <= 4 then
            for J in 1 .. Match.File loop
               File_Name := Read_C_String (C.Lines);

               if File_Name (File_Name'First) = ASCII.NUL then
                  --  End of file list, so incorrect entry
                  return;
               end if;

               Dir_Idx  := Read_LEB128 (C.Lines);
               Mod_Time := Read_LEB128 (C.Lines);
               Length   := Read_LEB128 (C.Lines);
            end loop;

            if Dir_Idx = 0 then
               --  No directory

               Dir_Name := null;

            else
               Seek (C.Lines, C.Header.Directories);

               for J in 1 .. Dir_Idx loop
                  Dir_Name := Read_C_String (C.Lines);

                  if Dir_Name (Dir_Name'First) = ASCII.NUL then
                     --  End of directory list, so ill-formed table

                     return;
                  end if;
               end loop;
            end if;

         --  DWARF 5

         else
            for J in 0 .. Match.File loop
               for K in 1 .. Integer (C.Header.File_Name_Entry_Format_Count)
               loop
                  if File_Entry_Format (K).C_Type = DW_LNCT_path then
                     case File_Entry_Format (K).Form is
                        when DW_FORM_string =>
                           File_Name := Read_C_String (C.Lines);

                        when DW_FORM_line_strp =>
                           Read_Section_Offset (C.Lines, Off, C.Header.Is64);
                           if J = Match.File then
                              Seek (C.Line_Str, Off);
                              File_Name := Read_C_String (C.Line_Str);
                           end if;

                        when others =>
                           raise Dwarf_Error with "DWARF form not implemented";
                     end case;

                  elsif File_Entry_Format (K).C_Type = DW_LNCT_directory_index
                  then
                     case File_Entry_Format (K).Form is
                        when DW_FORM_data1 =>
                           Dir_Idx := uint32 (uint8'(Read (C.Lines)));

                        when DW_FORM_data2 =>
                           Dir_Idx := uint32 (uint16'(Read (C.Lines)));

                        when DW_FORM_udata =>
                           Dir_Idx := Read_LEB128 (C.Lines);

                        when others =>
                           raise Dwarf_Error with
                             "invalid DWARF form for DW_LNCT_directory_index";
                     end case;

                  else
                     Skip_Form (C.Lines,
                       File_Entry_Format (K).Form,
                       C.Header.Is64,
                       C.Header.Address_Size);
                  end if;
               end loop;
            end loop;

            Seek (C.Lines, C.Header.Directories);

            for J in 0 .. Dir_Idx loop
               for K in 1 .. Integer (C.Header.Directory_Entry_Format_Count)
               loop
                  if Directory_Entry_Format (K).C_Type = DW_LNCT_path then
                     case Directory_Entry_Format (K).Form is
                        when DW_FORM_string =>
                           Dir_Name := Read_C_String (C.Lines);

                        when DW_FORM_line_strp =>
                           Read_Section_Offset (C.Lines, Off, C.Header.Is64);
                           if J = Dir_Idx then
                              Seek (C.Line_Str, Off);
                              Dir_Name := Read_C_String (C.Line_Str);
                           end if;

                        when others =>
                           raise Dwarf_Error with "DWARF form not implemented";
                     end case;

                  else
                     Skip_Form (C.Lines,
                       Directory_Entry_Format (K).Form,
                       C.Header.Is64,
                       C.Header.Address_Size);
                  end if;
               end loop;
            end loop;
         end if;

         Line_Num := Natural (Match.Line);
      end Set_Result;

      Addr_Int     : constant uint64 := uint64 (Addr);
      Previous_Row : Line_Info_Registers;
      Info_Offset  : Offset;
      Line_Offset  : Offset;
      Success      : Boolean;
      Done         : Boolean;
      S            : Object_Symbol;

   begin
      --  Initialize result

      Dir_Name    := null;
      File_Name   := null;
      Subprg_Name := (null, 0);
      Line_Num    := 0;

      --  Look up the symbol in the cache

      if C.Cache /= null then
         declare
            Addr_Off         : constant uint32 := uint32 (Addr - C.Low);
            First, Last, Mid : Natural;
         begin
            First := C.Cache'First;
            Last  := C.Cache'Last;
            Mid   := First;

            while First <= Last loop
               Mid := First + (Last - First) / 2;
               if Addr_Off < C.Cache (Mid).First then
                  Last := Mid - 1;
               elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then
                  First := Mid + 1;
               else
                  exit;
               end if;
            end loop;

            if Addr_Off >= C.Cache (Mid).First
              and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size
            then
               Line_Offset := Offset (C.Cache (Mid).Line);
               S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym));
               Subprg_Name := Object_Reader.Name (C.Obj.all, S);
            else
               return;
            end if;
         end;

      --  Search for the symbol in the binary

      else
         S := First_Symbol (C.Obj.all);
         while S /= Null_Symbol loop
            if Spans (S, Addr_Int) then
               Subprg_Name := Object_Reader.Name (C.Obj.all, S);
               exit;
            end if;

            S := Next_Symbol (C.Obj.all, S);
         end loop;

         --  Search address in aranges table

         Aranges_Lookup (C, Addr, Info_Offset, Success);
         if not Success then
            return;
         end if;

         --  Search stmt_list in info table

         Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success);
         if not Success then
            return;
         end if;
      end if;

      Seek (C.Lines, Line_Offset);
      C.Next_Header := 0;
      Initialize_State_Machine (C);
      Parse_Header (C);
      Previous_Row.Line := 0;

      --  Advance to the first entry

      loop
         Read_And_Execute_Insn (C, Done);

         if C.Registers.Is_Row then
            Previous_Row := C.Registers;
            exit;
         end if;

         exit when Done;
      end loop;

      --  Read the rest of the entries

      while Tell (C.Lines) < C.Next_Header loop
         Read_And_Execute_Insn (C, Done);

         if C.Registers.Is_Row then
            if not Previous_Row.End_Sequence
              and then Addr_Int >= Previous_Row.Address
              and then Addr_Int < C.Registers.Address
            then
               Set_Result (Previous_Row);
               return;

            elsif Addr_Int = C.Registers.Address then
               Set_Result (C.Registers);
               return;
            end if;

            Previous_Row := C.Registers;
         end if;

         exit when Done;
      end loop;
   end Symbolic_Address;

   -------------------
   -- String_Length --
   -------------------

   function String_Length (Str : Str_Access) return Natural is
   begin
      for I in Str'Range loop
         if Str (I) = ASCII.NUL then
            return I - Str'First;
         end if;
      end loop;

      return Str'Last;
   end String_Length;

   ------------------------
   -- Symbolic_Traceback --
   ------------------------

   procedure Symbolic_Traceback
     (Cin          :        Dwarf_Context;
      Traceback    :        STE.Tracebacks_Array;
      Suppress_Hex :        Boolean;
      Symbol_Found :    out Boolean;
      Res          : in out System.Bounded_Strings.Bounded_String)
   is
      use Ada.Characters.Handling;
      C : Dwarf_Context := Cin;

      Addr_In_Traceback : Address;

      Dir_Name    : Str_Access;
      File_Name   : Str_Access;
      Subprg_Name : String_Ptr_Len;
      Line_Num    : Natural;
      Off         : Natural;

   begin
      if not C.Has_Debug then
         Symbol_Found := False;
         return;
      else
         Symbol_Found := True;
      end if;

      for J in Traceback'Range loop
         --  If the buffer is full, no need to do any useless work
         exit when Is_Full (Res);

         Addr_In_Traceback := STE.PC_For (Traceback (J));

         Symbolic_Address
           (C,
            Addr_In_Traceback - Get_Load_Displacement (C),
            Dir_Name,
            File_Name,
            Subprg_Name,
            Line_Num);

         --  If we're not requested to suppress hex addresses, emit it now.

         if not Suppress_Hex then
            Append_Address (Res, Addr_In_Traceback);
            Append (Res, ' ');
         end if;

         if File_Name /= null then
            declare
               Last   : constant Natural := String_Length (File_Name);
               Is_Ada : constant Boolean :=
                 Last > 3
                 and then
                   To_Upper (String (File_Name (Last - 3 .. Last - 1))) =
                   ".AD";
               --  True if this is an Ada file. This doesn't take into account
               --  nonstandard file-naming conventions, but that's OK; this is
               --  purely cosmetic. It covers at least .ads, .adb, and .ada.

               Line_Image : constant String := Natural'Image (Line_Num);
            begin
               if Subprg_Name.Len /= 0 then
                  --  For Ada code, Symbol_Image is in all lower case; we don't
                  --  have the case from the original source code. But the best
                  --  guess is Mixed_Case, so convert to that.

                  if Is_Ada then
                     declare
                        Symbol_Image : String :=
                          Object_Reader.Decoded_Ada_Name
                            (C.Obj.all,
                             Subprg_Name);
                     begin
                        for K in Symbol_Image'Range loop
                           if K = Symbol_Image'First
                             or else not
                             (Is_Letter (Symbol_Image (K - 1))
                              or else Is_Digit (Symbol_Image (K - 1)))
                           then
                              Symbol_Image (K) := To_Upper (Symbol_Image (K));
                           end if;
                        end loop;
                        Append (Res, Symbol_Image);
                     end;
                  else
                     Off := Strip_Leading_Char (C.Obj.all, Subprg_Name);

                     Append
                       (Res,
                        String (Subprg_Name.Ptr (Off .. Subprg_Name.Len)));
                  end if;
               else
                  Append (Res, "???");
               end if;

               Append (Res, " at ");
               Append (Res, String (File_Name (1 .. Last)));
               Append (Res, ':');
               Append (Res, Line_Image (2 .. Line_Image'Last));
            end;
         else
            if Subprg_Name.Len > 0 then
               Off := Strip_Leading_Char (C.Obj.all, Subprg_Name);

               Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len)));
            else
               Append (Res, "???");
            end if;

            Append (Res, " at ???");
         end if;

         Append (Res, ASCII.LF);
      end loop;
   end Symbolic_Traceback;

end System.Dwarf_Lines;