a-numaux.adb<a-numaux-x86.adb \
s-atocou.adb<s-atocou-builtin.adb
+# Implementation of symbolic traceback based on dwarf
+TRASYM_DWARF_UNIX_PAIRS = \
+ s-trasym.adb<s-trasym-dwarf.adb \
+ s-mmosin.ads<s-mmosin-unix.ads \
+ s-mmosin.adb<s-mmosin-unix.adb \
+ s-mmauni.ads<s-mmauni-long.ads
+
+TRASYM_DWARF_MINGW_PAIRS = \
+ s-trasym.adb<s-trasym-dwarf.adb \
+ s-mmosin.ads<s-mmosin-mingw.ads \
+ s-mmosin.adb<s-mmosin-mingw.adb
+
+TRASYM_DWARF_COMMON_OBJS = s-objrea$(objext) s-dwalin$(objext) s-mmap$(objext) \
+ s-mmosin$(objext)
+
+TRASYM_DWARF_UNIX_OBJS = $(TRASYM_DWARF_COMMON_OBJS) s-mmauni$(objext)
+
+TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS)
+
# Shared library version
LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
s-tpopsp.adb<s-tpopsp-tls.adb \
+ $(TRASYM_DWARF_UNIX_PAIRS) \
g-sercom.adb<g-sercom-linux.adb \
+ s-tsmona.adb<s-tsmona-linux.adb \
a-exetim.adb<a-exetim-posix.adb \
a-exetim.ads<a-exetim-default.ads \
s-linux.ads<s-linux.ads \
EH_MECHANISM=-gcc
THREADSLIB = -lpthread -lrt
EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
s-tpopsp.adb<s-tpopsp-tls.adb \
s-taspri.ads<s-taspri-posix.ads \
g-sercom.adb<g-sercom-linux.adb \
+ $(TRASYM_DWARF_UNIX_PAIRS) \
+ s-tsmona.adb<s-tsmona-linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
system.ads<system-linux-x86.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
EH_MECHANISM=-gcc
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Polling (Off);
+-- We must turn polling off for this unit, because otherwise we can get
+-- elaboration circularities when polling is turned on
+
+with Ada.Characters.Handling;
+with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
+with Ada.Unchecked_Deallocation;
+with Ada.Containers.Generic_Array_Sort;
+
+with Interfaces; use Interfaces;
+
+with System; use System;
+with System.Storage_Elements; use System.Storage_Elements;
+with System.Address_Image;
+with System.IO; use System.IO;
+with System.Object_Reader; use System.Object_Reader;
+with System.Traceback_Entries; use System.Traceback_Entries;
+with System.Mmap; use System.Mmap;
+with System.Bounded_Strings; use System.Bounded_Strings;
+
+package body System.Dwarf_Lines is
+
+ SSU : constant := System.Storage_Unit;
+
+ 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 Dwarf-4 7.2.2
+
+ procedure Read_Section_Offset
+ (S : in out Mapped_Stream;
+ Len : out Offset;
+ Is64 : Boolean);
+ -- Read a section offset, as specified by Dwarf-4 7.4
+
+ procedure Read_Aranges_Entry
+ (C : in out Dwarf_Context;
+ Start : out Integer_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 prologue 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_Prologue (C : in out Dwarf_Context);
+ -- Decode a DWARF statement program prologue
+
+ procedure Read_And_Execute_Isn
+ (C : in out Dwarf_Context;
+ Done : out Boolean);
+ -- Read an execute a statement program instruction
+
+ function To_File_Name
+ (C : in out Dwarf_Context;
+ Code : uint32) return String;
+ -- Extract a file name from the prologue
+
+ type Callback is 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 --
+ -----------------------
+
+ -- 6.2.5.2 Standard Opcodes
+
+ 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;
+
+ -- From the DWARF version 4 public review draft
+
+ DW_LNE_set_discriminator : constant := 4;
+
+ -- Attribute encodings
+
+ DW_TAG_Compile_Unit : constant := 16#11#;
+
+ DW_AT_Stmt_List : constant := 16#10#;
+
+ 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_ref_sig8 : constant := 16#20#;
+
+ ---------
+ -- "<" --
+ ---------
+
+ 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
+ Put (System.Address_Image (C.Low + Storage_Count (Cache (I).First)));
+ Put (" - ");
+ Put
+ (System.Address_Image
+ (C.Low + Storage_Count (Cache (I).First + Cache (I).Size)));
+ Put (" l@");
+ Put
+ (System.Address_Image
+ (To_Address (Integer_Address (Cache (I).Line))));
+ Put (": ");
+ S := Read_Symbol (C.Obj.all, Offset (Cache (I).Sym));
+ Name := Object_Reader.Name (C.Obj.all, S);
+ Put (String (Name.Ptr (1 .. Name.Len)));
+ New_Line;
+ 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_Isn (C, Done);
+
+ if C.Registers.Is_Row then
+ F.all (C);
+ end if;
+
+ exit when Done;
+ end loop;
+ end For_Each_Row;
+
+ ---------------------
+ -- Initialize_Pass --
+ ---------------------
+
+ procedure Initialize_Pass (C : in out Dwarf_Context) is
+ begin
+ Seek (C.Lines, 0);
+ C.Next_Prologue := 0;
+
+ Initialize_State_Machine (C);
+ end Initialize_Pass;
+
+ ------------------------------
+ -- Initialize_State_Machine --
+ ------------------------------
+
+ procedure Initialize_State_Machine (C : in out Dwarf_Context) is
+ begin
+ C.Registers :=
+ (Address => 0,
+ File => 1,
+ Line => 1,
+ Column => 0,
+ Is_Stmt => C.Prologue.Default_Is_Stmt = 0,
+ Basic_Block => False,
+ End_Sequence => False,
+ Prologue_End => False,
+ Epilogue_Begin => False,
+ ISA => 0,
+ Is_Row => False);
+ end Initialize_State_Machine;
+
+ ---------------
+ -- Is_Inside --
+ ---------------
+
+ function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is
+ begin
+ return Addr >= C.Low and Addr <= C.High;
+ end Is_Inside;
+
+ ---------
+ -- Low --
+ ---------
+
+ function Low (C : Dwarf_Context) return Address is
+ begin
+ return C.Low;
+ end Low;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (File_Name : String;
+ C : out Dwarf_Context;
+ Success : out Boolean)
+ is
+ Line_Sec, Info_Sec, Abbrev_Sec, Aranges_Sec : Object_Section;
+ Hi, Lo : uint64;
+ begin
+ -- Not a success by default
+
+ Success := False;
+
+ -- Open file
+
+ C.Obj := Open (File_Name, C.In_Exception);
+
+ if C.Obj = null then
+ return;
+ end if;
+
+ Success := True;
+
+ -- Get memory bounds
+
+ Get_Memory_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
+ Line_Sec := Get_Section (C.Obj.all, ".dwline");
+ Abbrev_Sec := Get_Section (C.Obj.all, ".dwabrev");
+ Info_Sec := Get_Section (C.Obj.all, ".dwinfo");
+ Aranges_Sec := Get_Section (C.Obj.all, ".dwarnge");
+ else
+ Line_Sec := Get_Section (C.Obj.all, ".debug_line");
+ Abbrev_Sec := Get_Section (C.Obj.all, ".debug_abbrev");
+ Info_Sec := Get_Section (C.Obj.all, ".debug_info");
+ Aranges_Sec := Get_Section (C.Obj.all, ".debug_aranges");
+ end if;
+
+ if Line_Sec = Null_Section
+ or else Abbrev_Sec = Null_Section
+ or else Info_Sec = Null_Section
+ or else Aranges_Sec = Null_Section
+ then
+ C.Has_Debug := False;
+ return;
+ end if;
+
+ C.Lines := Create_Stream (C.Obj.all, Line_Sec);
+ C.Abbrev := Create_Stream (C.Obj.all, Abbrev_Sec);
+ C.Info := Create_Stream (C.Obj.all, Info_Sec);
+ C.Aranges := Create_Stream (C.Obj.all, Aranges_Sec);
+
+ -- All operations are successful, context is valid
+
+ C.Has_Debug := True;
+ end Open;
+
+ --------------------
+ -- Parse_Prologue --
+ --------------------
+
+ procedure Parse_Prologue (C : in out Dwarf_Context) is
+ 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_Prologue : Offset;
+ Last_Byte_Of_Prologue : Offset;
+
+ Max_Op_Per_Insn : uint8;
+ pragma Unreferenced (Max_Op_Per_Insn);
+
+ Prologue : Line_Info_Prologue renames C.Prologue;
+
+ begin
+ Tell (C.Lines, First_Byte_Of_Prologue);
+ Prologue.Unit_Length := Read (C.Lines);
+ Tell (C.Lines, Off);
+ C.Next_Prologue := Off + Offset (Prologue.Unit_Length);
+
+ Prologue.Version := Read (C.Lines);
+ Prologue.Prologue_Length := Read (C.Lines);
+ Tell (C.Lines, Last_Byte_Of_Prologue);
+ Last_Byte_Of_Prologue :=
+ Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1;
+
+ Prologue.Min_Isn_Length := Read (C.Lines);
+
+ if Prologue.Version >= 4 then
+ Max_Op_Per_Insn := Read (C.Lines);
+ end if;
+
+ Prologue.Default_Is_Stmt := Read (C.Lines);
+ Prologue.Line_Base := Read (C.Lines);
+ Prologue.Line_Range := Read (C.Lines);
+ Prologue.Opcode_Base := Read (C.Lines);
+
+ -- 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 .. uint32 (Prologue.Opcode_Base - 1) loop
+ Prologue.Opcode_Lengths (J) := Read (C.Lines);
+ end loop;
+
+ -- The include directories table follows. This is a list of null
+ -- terminated strings terminated by a double null. We only store
+ -- its offset for later decoding.
+
+ Tell (C.Lines, Prologue.Includes_Offset);
+ 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;
+
+ -- The file_names table is next. Each record is a null terminated string
+ -- for the file name, an unsigned LEB128 directory index, an unsigned
+ -- LEB128 modification time, and an LEB128 file length. The table is
+ -- terminated by a null byte.
+
+ Tell (C.Lines, Prologue.File_Names_Offset);
+
+ loop
+ -- Read the filename
+
+ 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;
+
+ -- Check we're where we think we are. This sanity check ensures we think
+ -- the prologue ends where the prologue says it does. It we aren't then
+ -- we've probably gotten out of sync somewhere.
+
+ Tell (C.Lines, Off);
+
+ if Prologue.Unit_Length /= 0
+ and then Off /= Last_Byte_Of_Prologue + 1
+ then
+ raise Dwarf_Error with "Parse error reading DWARF information";
+ end if;
+ end Parse_Prologue;
+
+ --------------------------
+ -- Read_And_Execute_Isn --
+ --------------------------
+
+ procedure Read_And_Execute_Isn
+ (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;
+ Prologue : Line_Info_Prologue renames C.Prologue;
+
+ begin
+ Done := False;
+ Registers.Is_Row := False;
+
+ if Registers.End_Sequence then
+ Initialize_State_Machine (C);
+ end if;
+
+ -- Read the next prologue
+
+ Tell (C.Lines, Off);
+ while Off = C.Next_Prologue loop
+ Initialize_State_Machine (C);
+ Parse_Prologue (C);
+ Tell (C.Lines, Off);
+ exit when Off + 4 >= 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 Prologue.Unit_Length = 0 or else Off + 4 >= Length (C.Lines) then
+ Done := True;
+ return;
+ end if;
+
+ -- Read and interpret an instruction
+
+ Opcode := Read (C.Lines);
+
+ -- Extended opcodes
+
+ if Opcode = 0 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 < Prologue.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 (Prologue.Min_Isn_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 - Prologue.Opcode_Base) / Prologue.Line_Range) *
+ Prologue.Min_Isn_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 - Prologue.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 / Prologue.Line_Range) *
+ int32 (Prologue.Min_Isn_Length);
+ Line_Increment :=
+ int32 (Prologue.Line_Base) +
+ int32 (Opcode mod Prologue.Line_Range);
+
+ Registers.Address :=
+ Registers.Address + uint64 (Address_Increment);
+ Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment);
+ Registers.Basic_Block := False;
+ Registers.Prologue_End := False;
+ Registers.Epilogue_Begin := 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_Isn;
+
+ ----------------------
+ -- Set_Load_Address --
+ ----------------------
+
+ procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is
+ begin
+ if Addr = Null_Address then
+ return;
+ else
+ C.Load_Slide :=
+ To_Integer (Addr) - Integer_Address (Get_Load_Address (C.Obj.all));
+
+ C.Low := To_Address (To_Integer (C.Low) + C.Load_Slide);
+ C.High := To_Address (To_Integer (C.High) + C.Load_Slide);
+ end if;
+ end Set_Load_Address;
+
+ ------------------
+ -- To_File_Name --
+ ------------------
+
+ function To_File_Name
+ (C : in out Dwarf_Context;
+ Code : uint32) return String
+ is
+ Buf : Buffer;
+ J : uint32;
+
+ Dir_Idx : uint32;
+ pragma Unreferenced (Dir_Idx);
+
+ Mod_Time : uint32;
+ pragma Unreferenced (Mod_Time);
+
+ Length : uint32;
+ pragma Unreferenced (Length);
+
+ begin
+ Seek (C.Lines, C.Prologue.File_Names_Offset);
+
+ -- Find the entry
+
+ J := 0;
+ loop
+ J := J + 1;
+ 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);
+ exit when J = Code;
+ end loop;
+
+ 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;
+
+ --------------------
+ -- Aranges_Lookup --
+ --------------------
+
+ procedure Aranges_Lookup
+ (C : in out Dwarf_Context;
+ Addr : Address;
+ Info_Offset : out Offset;
+ Success : out Boolean)
+ is
+ begin
+ 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 : Integer_Address;
+ Len : Storage_Count;
+ begin
+ Read_Aranges_Entry (C, Start, Len);
+ exit when Start = 0 and Len = 0;
+ if Addr >= To_Address (Start)
+ and then Addr < To_Address (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
+ case Form is
+ when DW_FORM_addr =>
+ Skip := Offset (Ptr_Sz);
+ when DW_FORM_block2 =>
+ Skip := Offset (uint16'(Read (S)));
+ when DW_FORM_block4 =>
+ Skip := Offset (uint32'(Read (S)));
+ when DW_FORM_data2 | DW_FORM_ref2 =>
+ Skip := 2;
+ when DW_FORM_data4 | DW_FORM_ref4 =>
+ Skip := 4;
+ when DW_FORM_data8 | DW_FORM_ref8 | DW_FORM_ref_sig8 =>
+ Skip := 8;
+ when DW_FORM_string =>
+ while uint8'(Read (S)) /= 0 loop
+ null;
+ end loop;
+ return;
+ when DW_FORM_block | DW_FORM_exprloc =>
+ Skip := Offset (uint32'(Read_LEB128 (S)));
+ when DW_FORM_block1 | DW_FORM_ref1 =>
+ Skip := Offset (uint8'(Read (S)));
+ when DW_FORM_data1 | DW_FORM_flag =>
+ Skip := 1;
+ when DW_FORM_sdata =>
+ declare
+ Val : constant int32 := Read_LEB128 (S);
+ pragma Unreferenced (Val);
+ begin
+ return;
+ end;
+ when DW_FORM_strp | DW_FORM_ref_addr | DW_FORM_sec_offset =>
+ Skip := (if Is64 then 8 else 4);
+ when DW_FORM_udata | DW_FORM_ref_udata =>
+ declare
+ Val : constant uint32 := Read_LEB128 (S);
+ pragma Unreferenced (Val);
+ begin
+ return;
+ end;
+ when DW_FORM_flag_present =>
+ return;
+ when DW_FORM_indirect =>
+ raise Constraint_Error;
+ when others =>
+ raise Constraint_Error;
+ 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
+ Num : uint32;
+ Abbrev : uint32;
+ Tag : uint32;
+ Has_Child : uint8;
+ pragma Unreferenced (Abbrev, Tag, Has_Child);
+ begin
+ Seek (C.Abbrev, Abbrev_Offset);
+
+ Num := 1;
+
+ loop
+ exit when Num = Abbrev_Num;
+
+ Abbrev := Read_LEB128 (C.Abbrev);
+ 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);
+ begin
+ exit when Name = 0 and Form = 0;
+ end;
+ end loop;
+
+ Num := Num + 1;
+ 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);
+ begin
+ Success := False;
+
+ Seek (C.Info, Info_Offset);
+
+ Read_Initial_Length (C.Info, Unit_Length, Is64);
+
+ Version := Read (C.Info);
+ if Version not in 2 .. 4 then
+ return;
+ end if;
+
+ Read_Section_Offset (C.Info, Abbrev_Offset, Is64);
+
+ Addr_Sz := Read (C.Info);
+ if Addr_Sz /= (Address'Size / SSU) then
+ 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);
+
+ -- First ULEB128 is the abbrev code
+
+ if Read_LEB128 (C.Abbrev) /= Abbrev then
+ -- Ill formed abbrev table
+ return;
+ end if;
+
+ -- Then the tag
+
+ if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then
+ -- Expect compile unit
+ 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;
+
+ return;
+ 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;
+
+ 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 Integer_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 := Integer_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 := Integer_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;
+ 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 whose length is 0
+ Sz := uint32 (Size (S));
+
+ -- Try to filter symbols at the same address. This is a best
+ -- effort as they might not be consecutive.
+ Addr := uint32 (Value (S) - uint64 (C.Low));
+ if Sz > 0 and then 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;
+
+ 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 : Integer_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 = 0 and Ar_Len = 0;
+
+ Len := uint32 (Ar_Len);
+ Start := uint32 (Ar_Start - To_Integer (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;
+ J : uint32;
+
+ Mod_Time : uint32;
+ pragma Unreferenced (Mod_Time);
+
+ Length : uint32;
+ pragma Unreferenced (Length);
+
+ begin
+ Seek (C.Lines, C.Prologue.File_Names_Offset);
+
+ -- Find the entry
+
+ J := 0;
+ loop
+ J := J + 1;
+ 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);
+ exit when J = Match.File;
+ end loop;
+
+ if Dir_Idx = 0 then
+ -- No directory
+ Dir_Name := null;
+
+ else
+ Seek (C.Lines, C.Prologue.Includes_Offset);
+
+ J := 0;
+ loop
+ J := J + 1;
+ 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;
+
+ exit when J = Dir_Idx;
+
+ end loop;
+ end if;
+
+ Line_Num := Natural (Match.Line);
+ end Set_Result;
+
+ Addr_Int : constant Integer_Address := To_Integer (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;
+
+ if C.Cache /= null then
+ -- Look in the cache
+ declare
+ Addr_Off : constant uint32 := uint32 (Addr - C.Low);
+ First, Last, Mid : Natural;
+ begin
+ First := C.Cache'First;
+ Last := C.Cache'Last;
+ 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
+ -- Not found
+ return;
+ end if;
+ end;
+ else
+ -- Search symbol
+ S := First_Symbol (C.Obj.all);
+ while S /= Null_Symbol loop
+ if Spans (S, uint64 (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_Prologue := 0;
+ Initialize_State_Machine (C);
+ Parse_Prologue (C);
+
+ -- Advance to the first entry
+
+ loop
+ Read_And_Execute_Isn (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_Prologue loop
+ Read_And_Execute_Isn (C, Done);
+
+ if C.Registers.Is_Row then
+ if not Previous_Row.End_Sequence
+ and then Addr_Int >= Integer_Address (Previous_Row.Address)
+ and then Addr_Int < Integer_Address (C.Registers.Address)
+ then
+ Set_Result (Previous_Row);
+ return;
+
+ elsif Addr_Int = Integer_Address (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 : AET.Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Symbol_Found : in out Boolean;
+ Res : in out System.Bounded_Strings.Bounded_String)
+ is
+ use Ada.Characters.Handling;
+ C : Dwarf_Context := Cin;
+ Addr : 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 := PC_For (Traceback (J));
+ Symbolic_Address
+ (C,
+ To_Address (To_Integer (Addr) + C.Load_Slide),
+ Dir_Name,
+ File_Name,
+ Subprg_Name,
+ Line_Num);
+
+ 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;
+ 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 Suppress_Hex then
+ Append (Res, "...");
+ else
+ Append_Address (Res, Addr);
+ end if;
+
+ if Subprg_Name.Len > 0 then
+ Off := Strip_Leading_Char (C.Obj.all, Subprg_Name);
+
+ Append (Res, ' ');
+ Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len)));
+ end if;
+
+ Append (Res, " at ???");
+ end if;
+
+ Append (Res, ASCII.LF);
+ end loop;
+ end Symbolic_Traceback;
+end System.Dwarf_Lines;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . D W A R F _ L I N E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides routines to read DWARF line number information from
+-- a generic object file with as little overhead as possible. This allows
+-- conversions from PC addresses to human readable source locations.
+--
+-- Objects must be built with debugging information, however only the
+-- .debug_line section of the object file is referenced. In cases where object
+-- size is a consideration it's possible to strip all other .debug sections,
+-- which will decrease the size of the object significantly.
+
+pragma Polling (Off);
+-- We must turn polling off for this unit, because otherwise we can get
+-- elaboration circularities when polling is turned on
+
+with Ada.Exceptions.Traceback;
+
+with System.Object_Reader;
+with System.Storage_Elements;
+with System.Bounded_Strings;
+
+package System.Dwarf_Lines is
+
+ package AET renames Ada.Exceptions.Traceback;
+ package SOR renames System.Object_Reader;
+
+ type Dwarf_Context (In_Exception : Boolean := False) is private;
+ -- Type encapsulation the state of the Dwarf reader. When In_Exception
+ -- is True we are parsing as part of a exception handler decorator, we do
+ -- not want an exception to be raised, the parsing is done safely skipping
+ -- DWARF file that cannot be read or with stripped debug section for
+ -- example.
+
+ procedure Open
+ (File_Name : String;
+ C : out Dwarf_Context;
+ Success : out Boolean);
+ procedure Close (C : in out Dwarf_Context);
+ -- Open and close files
+
+ procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address);
+ -- Set the load address of a file. This is used to rebase PIE (Position
+ -- Independant Executable) binaries.
+
+ function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean;
+ pragma Inline (Is_Inside);
+ -- Return true iff Addr is within the module
+
+ function Low (C : Dwarf_Context) return Address;
+ pragma Inline (Low);
+ -- Return the lowest address of C
+
+ procedure Dump (C : in out Dwarf_Context);
+ -- Dump each row found in the object's .debug_lines section to standard out
+
+ procedure Dump_Cache (C : Dwarf_Context);
+ -- Dump the cache (if present)
+
+ procedure Enable_Cache (C : in out Dwarf_Context);
+ -- Read symbols information to speed up Symbolic_Traceback.
+
+ procedure Symbolic_Traceback
+ (Cin : Dwarf_Context;
+ Traceback : AET.Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Symbol_Found : in out Boolean;
+ Res : in out System.Bounded_Strings.Bounded_String);
+ -- Generate a string for a traceback suitable for displaying to the user.
+ -- If one or more symbols are found, Symbol_Found is set to True. This
+ -- allows the caller to fall back to hexadecimal addresses.
+
+ Dwarf_Error : exception;
+ -- Raised if a problem is encountered parsing DWARF information. Can be a
+ -- result of a logic error or malformed DWARF information.
+
+private
+ -- The following section numbers reference
+
+ -- "DWARF Debugging Information Format, Version 3"
+
+ -- published by the Standards Group, http://freestandards.org.
+
+ -- 6.2.2 State Machine Registers
+
+ type Line_Info_Registers is record
+ Address : SOR.uint64;
+ File : SOR.uint32;
+ Line : SOR.uint32;
+ Column : SOR.uint32;
+ Is_Stmt : Boolean;
+ Basic_Block : Boolean;
+ End_Sequence : Boolean;
+ Prologue_End : Boolean;
+ Epilogue_Begin : Boolean;
+ ISA : SOR.uint32;
+ Is_Row : Boolean;
+ end record;
+
+ -- 6.2.4 The Line Number Program Prologue
+
+ MAX_OPCODE_LENGTHS : constant := 256;
+
+ type Opcodes_Lengths_Array is
+ array (SOR.uint32 range 1 .. MAX_OPCODE_LENGTHS) of SOR.uint8;
+
+ type Line_Info_Prologue is record
+ Unit_Length : SOR.uint32;
+ Version : SOR.uint16;
+ Prologue_Length : SOR.uint32;
+ Min_Isn_Length : SOR.uint8;
+ Default_Is_Stmt : SOR.uint8;
+ Line_Base : SOR.int8;
+ Line_Range : SOR.uint8;
+ Opcode_Base : SOR.uint8;
+ Opcode_Lengths : Opcodes_Lengths_Array;
+ Includes_Offset : SOR.Offset;
+ File_Names_Offset : SOR.Offset;
+ end record;
+
+ type Search_Entry is record
+ First : SOR.uint32;
+ Size : SOR.uint32;
+ -- Function bounds as offset to the base address.
+
+ Sym : SOR.uint32;
+ -- Symbol offset to get the name.
+
+ Line : SOR.uint32;
+ -- Dwarf line offset.
+ end record;
+
+ type Search_Array is array (Natural range <>) of Search_Entry;
+
+ type Search_Array_Access is access Search_Array;
+
+ type Dwarf_Context (In_Exception : Boolean := False) is record
+ Load_Slide : System.Storage_Elements.Integer_Address := 0;
+ Low, High : Address;
+ -- Bounds of the module
+
+ Obj : SOR.Object_File_Access;
+ -- The object file containing dwarf sections
+
+ Has_Debug : Boolean;
+ -- True if all debug sections are available
+
+ Cache : Search_Array_Access;
+ -- Quick access to symbol and debug info (when present).
+
+ Lines : SOR.Mapped_Stream;
+ Aranges : SOR.Mapped_Stream;
+ Info : SOR.Mapped_Stream;
+ Abbrev : SOR.Mapped_Stream;
+ -- Dwarf line, aranges, info and abbrev sections
+
+ Prologue : Line_Info_Prologue;
+ Registers : Line_Info_Registers;
+ Next_Prologue : SOR.Offset;
+ -- State for lines
+ end record;
+
+end System.Dwarf_Lines;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . O B J E C T _ R E A D E R --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2009-2017, 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.Unchecked_Conversion;
+
+with Interfaces.C;
+
+with System.CRTL;
+
+package body System.Object_Reader is
+ use Interfaces;
+ use Interfaces.C;
+ use System.Mmap;
+
+ SSU : constant := System.Storage_Unit;
+
+ function To_int32 is new Ada.Unchecked_Conversion (uint32, int32);
+
+ function Trim_Trailing_Nuls (Str : String) return String;
+ -- Return a copy of a string with any trailing NUL characters truncated
+
+ procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32);
+ -- Check that the SIZE bytes at the current offset are still in the stream
+
+ -------------------------------------
+ -- ELF object file format handling --
+ -------------------------------------
+
+ generic
+ type uword is mod <>;
+
+ package ELF_Ops is
+
+ -- ELF version codes
+
+ ELFCLASS32 : constant := 1; -- 32 bit ELF
+ ELFCLASS64 : constant := 2; -- 64 bit ELF
+
+ -- ELF machine codes
+
+ EM_NONE : constant := 0; -- No machine
+ EM_SPARC : constant := 2; -- SUN SPARC
+ EM_386 : constant := 3; -- Intel 80386
+ EM_MIPS : constant := 8; -- MIPS RS3000 Big-Endian
+ EM_MIPS_RS3_LE : constant := 10; -- MIPS RS3000 Little-Endian
+ EM_SPARC32PLUS : constant := 18; -- Sun SPARC 32+
+ EM_PPC : constant := 20; -- PowerPC
+ EM_PPC64 : constant := 21; -- PowerPC 64-bit
+ EM_ARM : constant := 40; -- ARM
+ EM_SPARCV9 : constant := 43; -- SPARC v9 64-bit
+ EM_IA_64 : constant := 50; -- Intel Merced
+ EM_X86_64 : constant := 62; -- AMD x86-64 architecture
+
+ EN_NIDENT : constant := 16;
+
+ type E_Ident_Type is array (0 .. EN_NIDENT - 1) of uint8;
+
+ type Header is record
+ E_Ident : E_Ident_Type; -- Magic number and other info
+ E_Type : uint16; -- Object file type
+ E_Machine : uint16; -- Architecture
+ E_Version : uint32; -- Object file version
+ E_Entry : uword; -- Entry point virtual address
+ E_Phoff : uword; -- Program header table file offset
+ E_Shoff : uword; -- Section header table file offset
+ E_Flags : uint32; -- Processor-specific flags
+ E_Ehsize : uint16; -- ELF header size in bytes
+ E_Phentsize : uint16; -- Program header table entry size
+ E_Phnum : uint16; -- Program header table entry count
+ E_Shentsize : uint16; -- Section header table entry size
+ E_Shnum : uint16; -- Section header table entry count
+ E_Shstrndx : uint16; -- Section header string table index
+ end record;
+
+ type Section_Header is record
+ Sh_Name : uint32; -- Section name string table index
+ Sh_Type : uint32; -- Section type
+ Sh_Flags : uword; -- Section flags
+ Sh_Addr : uword; -- Section virtual addr at execution
+ Sh_Offset : uword; -- Section file offset
+ Sh_Size : uword; -- Section size in bytes
+ Sh_Link : uint32; -- Link to another section
+ Sh_Info : uint32; -- Additional section information
+ Sh_Addralign : uword; -- Section alignment
+ Sh_Entsize : uword; -- Entry size if section holds table
+ end record;
+
+ SHF_ALLOC : constant := 2;
+
+ type Symtab_Entry32 is record
+ St_Name : uint32; -- Name (string table index)
+ St_Value : uint32; -- Value
+ St_Size : uint32; -- Size in bytes
+ St_Info : uint8; -- Type and binding attributes
+ St_Other : uint8; -- Undefined
+ St_Shndx : uint16; -- Defining section
+ end record;
+
+ type Symtab_Entry64 is record
+ St_Name : uint32; -- Name (string table index)
+ St_Info : uint8; -- Type and binding attributes
+ St_Other : uint8; -- Undefined
+ St_Shndx : uint16; -- Defining section
+ St_Value : uint64; -- Value
+ St_Size : uint64; -- Size in bytes
+ end record;
+
+ function Read_Header (F : in out Mapped_Stream) return Header;
+ -- Read a header from an ELF format object
+
+ function First_Symbol
+ (Obj : in out ELF_Object_File) return Object_Symbol;
+ -- Return the first element in the symbol table, or Null_Symbol if the
+ -- symbol table is empty.
+
+ function Read_Symbol
+ (Obj : in out ELF_Object_File;
+ Off : Offset) return Object_Symbol;
+ -- Read a symbol at offset Off
+
+ function Name
+ (Obj : in out ELF_Object_File;
+ Sym : Object_Symbol) return String_Ptr_Len;
+ -- Return the name of the symbol
+
+ function Name
+ (Obj : in out ELF_Object_File;
+ Sec : Object_Section) return String;
+ -- Return the name of a section
+
+ function Get_Section
+ (Obj : in out ELF_Object_File;
+ Shnum : uint32) return Object_Section;
+ -- Fetch a section by index from zero
+
+ function Initialize
+ (F : Mapped_File;
+ Hdr : Header;
+ In_Exception : Boolean) return ELF_Object_File;
+ -- Initialize an object file
+
+ end ELF_Ops;
+
+ -----------------------------------
+ -- PECOFF object format handling --
+ -----------------------------------
+
+ package PECOFF_Ops is
+
+ -- Constants and data layout are taken from the document "Microsoft
+ -- Portable Executable and Common Object File Format Specification"
+ -- Revision 8.1.
+
+ Signature_Loc_Offset : constant := 16#3C#;
+ -- Offset of pointer to the file signature
+
+ Size_Of_Standard_Header_Fields : constant := 16#18#;
+ -- Length in bytes of the standard header record
+
+ Function_Symbol_Type : constant := 16#20#;
+ -- Type field value indicating a symbol refers to a function
+
+ Not_Function_Symbol_Type : constant := 16#00#;
+ -- Type field value indicating a symbol does not refer to a function
+
+ type Magic_Array is array (0 .. 3) of uint8;
+ -- Array of magic numbers from the header
+
+ -- Magic numbers for PECOFF variants
+
+ VARIANT_PE32 : constant := 16#010B#;
+ VARIANT_PE32_PLUS : constant := 16#020B#;
+
+ -- PECOFF machine codes
+
+ IMAGE_FILE_MACHINE_I386 : constant := 16#014C#;
+ IMAGE_FILE_MACHINE_IA64 : constant := 16#0200#;
+ IMAGE_FILE_MACHINE_AMD64 : constant := 16#8664#;
+
+ -- PECOFF Data layout
+
+ type Header is record
+ Magics : Magic_Array;
+ Machine : uint16;
+ NumberOfSections : uint16;
+ TimeDateStamp : uint32;
+ PointerToSymbolTable : uint32;
+ NumberOfSymbols : uint32;
+ SizeOfOptionalHeader : uint16;
+ Characteristics : uint16;
+ Variant : uint16;
+ end record;
+
+ pragma Pack (Header);
+
+ type Optional_Header_PE32 is record
+ Magic : uint16;
+ MajorLinkerVersion : uint8;
+ MinorLinkerVersion : uint8;
+ SizeOfCode : uint32;
+ SizeOfInitializedData : uint32;
+ SizeOfUninitializedData : uint32;
+ AddressOfEntryPoint : uint32;
+ BaseOfCode : uint32;
+ BaseOfData : uint32; -- Note: not in PE32+
+ ImageBase : uint32;
+ SectionAlignment : uint32;
+ FileAlignment : uint32;
+ MajorOperatingSystemVersion : uint16;
+ MinorOperationSystemVersion : uint16;
+ MajorImageVersion : uint16;
+ MinorImageVersion : uint16;
+ MajorSubsystemVersion : uint16;
+ MinorSubsystemVersion : uint16;
+ Win32VersionValue : uint32;
+ SizeOfImage : uint32;
+ SizeOfHeaders : uint32;
+ Checksum : uint32;
+ Subsystem : uint16;
+ DllCharacteristics : uint16;
+ SizeOfStackReserve : uint32;
+ SizeOfStackCommit : uint32;
+ SizeOfHeapReserve : uint32;
+ SizeOfHeapCommit : uint32;
+ LoaderFlags : uint32;
+ NumberOfRvaAndSizes : uint32;
+ end record;
+ pragma Pack (Optional_Header_PE32);
+ pragma Assert (Optional_Header_PE32'Size = 96 * SSU);
+
+ type Optional_Header_PE64 is record
+ Magic : uint16;
+ MajorLinkerVersion : uint8;
+ MinorLinkerVersion : uint8;
+ SizeOfCode : uint32;
+ SizeOfInitializedData : uint32;
+ SizeOfUninitializedData : uint32;
+ AddressOfEntryPoint : uint32;
+ BaseOfCode : uint32;
+ ImageBase : uint64;
+ SectionAlignment : uint32;
+ FileAlignment : uint32;
+ MajorOperatingSystemVersion : uint16;
+ MinorOperationSystemVersion : uint16;
+ MajorImageVersion : uint16;
+ MinorImageVersion : uint16;
+ MajorSubsystemVersion : uint16;
+ MinorSubsystemVersion : uint16;
+ Win32VersionValue : uint32;
+ SizeOfImage : uint32;
+ SizeOfHeaders : uint32;
+ Checksum : uint32;
+ Subsystem : uint16;
+ DllCharacteristics : uint16;
+ SizeOfStackReserve : uint64;
+ SizeOfStackCommit : uint64;
+ SizeOfHeapReserve : uint64;
+ SizeOfHeapCommit : uint64;
+ LoaderFlags : uint32;
+ NumberOfRvaAndSizes : uint32;
+ end record;
+ pragma Pack (Optional_Header_PE64);
+ pragma Assert (Optional_Header_PE64'Size = 112 * SSU);
+
+ subtype Name_Str is String (1 .. 8);
+
+ type Section_Header is record
+ Name : Name_Str;
+ VirtualSize : uint32;
+ VirtualAddress : uint32;
+ SizeOfRawData : uint32;
+ PointerToRawData : uint32;
+ PointerToRelocations : uint32;
+ PointerToLinenumbers : uint32;
+ NumberOfRelocations : uint16;
+ NumberOfLinenumbers : uint16;
+ Characteristics : uint32;
+ end record;
+
+ pragma Pack (Section_Header);
+
+ IMAGE_SCN_CNT_CODE : constant := 16#0020#;
+
+ type Symtab_Entry is record
+ Name : Name_Str;
+ Value : uint32;
+ SectionNumber : int16;
+ TypeField : uint16;
+ StorageClass : uint8;
+ NumberOfAuxSymbols : uint8;
+ end record;
+
+ pragma Pack (Symtab_Entry);
+
+ type Auxent_Section is record
+ Length : uint32;
+ NumberOfRelocations : uint16;
+ NumberOfLinenumbers : uint16;
+ CheckSum : uint32;
+ Number : uint16;
+ Selection : uint8;
+ Unused1 : uint8;
+ Unused2 : uint8;
+ Unused3 : uint8;
+ end record;
+
+ for Auxent_Section'Size use 18 * 8;
+
+ function Read_Header (F : in out Mapped_Stream) return Header;
+ -- Read the object file header
+
+ function First_Symbol
+ (Obj : in out PECOFF_Object_File) return Object_Symbol;
+ -- Return the first element in the symbol table, or Null_Symbol if the
+ -- symbol table is empty.
+
+ function Read_Symbol
+ (Obj : in out PECOFF_Object_File;
+ Off : Offset) return Object_Symbol;
+ -- Read a symbol at offset Off
+
+ function Name
+ (Obj : in out PECOFF_Object_File;
+ Sym : Object_Symbol) return String_Ptr_Len;
+ -- Return the name of the symbol
+
+ function Name
+ (Obj : in out PECOFF_Object_File;
+ Sec : Object_Section) return String;
+ -- Return the name of a section
+
+ function Get_Section
+ (Obj : in out PECOFF_Object_File;
+ Index : uint32) return Object_Section;
+ -- Fetch a section by index from zero
+
+ function Initialize
+ (F : Mapped_File;
+ Hdr : Header;
+ In_Exception : Boolean) return PECOFF_Object_File;
+ -- Initialize an object file
+
+ end PECOFF_Ops;
+
+ -------------------------------------
+ -- XCOFF-32 object format handling --
+ -------------------------------------
+
+ package XCOFF32_Ops is
+
+ -- XCOFF Data layout
+
+ type Header is record
+ f_magic : uint16;
+ f_nscns : uint16;
+ f_timdat : uint32;
+ f_symptr : uint32;
+ f_nsyms : uint32;
+ f_opthdr : uint16;
+ f_flags : uint16;
+ end record;
+
+ type Auxiliary_Header is record
+ o_mflag : uint16;
+ o_vstamp : uint16;
+ o_tsize : uint32;
+ o_dsize : uint32;
+ o_bsize : uint32;
+ o_entry : uint32;
+ o_text_start : uint32;
+ o_data_start : uint32;
+ o_toc : uint32;
+ o_snentry : uint16;
+ o_sntext : uint16;
+ o_sndata : uint16;
+ o_sntoc : uint16;
+ o_snloader : uint16;
+ o_snbss : uint16;
+ o_algntext : uint16;
+ o_algndata : uint16;
+ o_modtype : uint16;
+ o_cpuflag : uint8;
+ o_cputype : uint8;
+ o_maxstack : uint32;
+ o_maxdata : uint32;
+ o_debugger : uint32;
+ o_flags : uint8;
+ o_sntdata : uint16;
+ o_sntbss : uint16;
+ end record;
+ pragma Unreferenced (Auxiliary_Header);
+ -- Not used, but not removed (just in case)
+
+ subtype Name_Str is String (1 .. 8);
+
+ type Section_Header is record
+ s_name : Name_Str;
+ s_paddr : uint32;
+ s_vaddr : uint32;
+ s_size : uint32;
+ s_scnptr : uint32;
+ s_relptr : uint32;
+ s_lnnoptr : uint32;
+ s_nreloc : uint16;
+ s_nlnno : uint16;
+ s_flags : uint32;
+ end record;
+
+ pragma Pack (Section_Header);
+
+ STYP_TEXT : constant := 16#0020#;
+
+ type Symbol_Entry is record
+ n_name : Name_Str;
+ n_value : uint32;
+ n_scnum : uint16;
+ n_type : uint16;
+ n_sclass : uint8;
+ n_numaux : uint8;
+ end record;
+ for Symbol_Entry'Size use 18 * 8;
+
+ type Aux_Entry is record
+ x_scnlen : uint32;
+ x_parmhash : uint32;
+ x_snhash : uint16;
+ x_smtyp : uint8;
+ x_smclass : uint8;
+ x_stab : uint32;
+ x_snstab : uint16;
+ end record;
+ for Aux_Entry'Size use 18 * 8;
+
+ pragma Pack (Aux_Entry);
+
+ C_EXT : constant := 2;
+ C_HIDEXT : constant := 107;
+ C_WEAKEXT : constant := 111;
+
+ XTY_LD : constant := 2;
+ -- Magic constant should be documented, especially since it's changed???
+
+ function Read_Header (F : in out Mapped_Stream) return Header;
+ -- Read the object file header
+
+ function First_Symbol
+ (Obj : in out XCOFF32_Object_File) return Object_Symbol;
+ -- Return the first element in the symbol table, or Null_Symbol if the
+ -- symbol table is empty.
+
+ function Read_Symbol
+ (Obj : in out XCOFF32_Object_File;
+ Off : Offset) return Object_Symbol;
+ -- Read a symbol at offset Off
+
+ function Name
+ (Obj : in out XCOFF32_Object_File;
+ Sym : Object_Symbol) return String_Ptr_Len;
+ -- Return the name of the symbol
+
+ function Name
+ (Obj : in out XCOFF32_Object_File;
+ Sec : Object_Section) return String;
+ -- Return the name of a section
+
+ function Initialize
+ (F : Mapped_File;
+ Hdr : Header;
+ In_Exception : Boolean) return XCOFF32_Object_File;
+ -- Initialize an object file
+
+ function Get_Section
+ (Obj : in out XCOFF32_Object_File;
+ Index : uint32) return Object_Section;
+ -- Fetch a section by index from zero
+
+ end XCOFF32_Ops;
+
+ -------------
+ -- ELF_Ops --
+ -------------
+
+ package body ELF_Ops is
+
+ function Get_String_Table (Obj : in out ELF_Object_File)
+ return Object_Section;
+ -- Fetch the section containing the string table
+
+ function Get_Symbol_Table (Obj : in out ELF_Object_File)
+ return Object_Section;
+ -- Fetch the section containing the symbol table
+
+ function Read_Section_Header
+ (Obj : in out ELF_Object_File;
+ Shnum : uint32) return Section_Header;
+ -- Read the header for an ELF format object section indexed from zero
+
+ ------------------
+ -- First_Symbol --
+ ------------------
+
+ function First_Symbol
+ (Obj : in out ELF_Object_File) return Object_Symbol
+ is
+ begin
+ if Obj.Symtab_Last = 0 then
+ return Null_Symbol;
+ else
+ return Read_Symbol (Obj, 0);
+ end if;
+ end First_Symbol;
+
+ -----------------
+ -- Get_Section --
+ -----------------
+
+ function Get_Section
+ (Obj : in out ELF_Object_File;
+ Shnum : uint32) return Object_Section
+ is
+ SHdr : constant Section_Header := Read_Section_Header (Obj, Shnum);
+ begin
+ return (Shnum,
+ Offset (SHdr.Sh_Offset),
+ uint64 (SHdr.Sh_Addr),
+ uint64 (SHdr.Sh_Size),
+ (SHdr.Sh_Flags and SHF_ALLOC) /= 0);
+ end Get_Section;
+
+ ------------------------
+ -- Get_String_Table --
+ ------------------------
+
+ function Get_String_Table
+ (Obj : in out ELF_Object_File) return Object_Section
+ is
+ begin
+ -- All cases except MIPS IRIX, string table located in .strtab
+
+ if Obj.Arch /= MIPS then
+ return Get_Section (Obj, ".strtab");
+
+ -- On IRIX only .dynstr is available
+
+ else
+ return Get_Section (Obj, ".dynstr");
+ end if;
+ end Get_String_Table;
+
+ ------------------------
+ -- Get_Symbol_Table --
+ ------------------------
+
+ function Get_Symbol_Table
+ (Obj : in out ELF_Object_File) return Object_Section
+ is
+ begin
+ -- All cases except MIPS IRIX, symbol table located in .symtab
+
+ if Obj.Arch /= MIPS then
+ return Get_Section (Obj, ".symtab");
+
+ -- On IRIX, symbol table located somewhere other than .symtab
+
+ else
+ return Get_Section (Obj, ".dynsym");
+ end if;
+ end Get_Symbol_Table;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ function Initialize
+ (F : Mapped_File;
+ Hdr : Header;
+ In_Exception : Boolean) return ELF_Object_File
+ is
+ Res : ELF_Object_File
+ (Format => (case uword'Size is
+ when 64 => ELF64,
+ when 32 => ELF32,
+ when others => raise Program_Error));
+ Sec : Object_Section;
+ begin
+ Res.MF := F;
+ Res.In_Exception := In_Exception;
+ Res.Num_Sections := uint32 (Hdr.E_Shnum);
+
+ case Hdr.E_Machine is
+ when EM_SPARC
+ | EM_SPARC32PLUS
+ =>
+ Res.Arch := SPARC;
+
+ when EM_386 =>
+ Res.Arch := i386;
+
+ when EM_MIPS
+ | EM_MIPS_RS3_LE
+ =>
+ Res.Arch := MIPS;
+
+ when EM_PPC =>
+ Res.Arch := PPC;
+
+ when EM_PPC64 =>
+ Res.Arch := PPC64;
+
+ when EM_SPARCV9 =>
+ Res.Arch := SPARC64;
+
+ when EM_IA_64 =>
+ Res.Arch := IA64;
+
+ when EM_X86_64 =>
+ Res.Arch := x86_64;
+
+ when others =>
+ raise Format_Error with "unrecognized architecture";
+ end case;
+
+ -- Map section table and section string table
+ Res.Sectab_Stream := Create_Stream
+ (F, File_Size (Hdr.E_Shoff),
+ File_Size (Hdr.E_Shnum) * File_Size (Hdr.E_Shentsize));
+ Sec := Get_Section (Res, uint32 (Hdr.E_Shstrndx));
+ Res.Secstr_Stream := Create_Stream (Res, Sec);
+
+ -- Map symbol and string table
+ Sec := Get_Symbol_Table (Res);
+ Res.Symtab_Stream := Create_Stream (Res, Sec);
+ Res.Symtab_Last := Offset (Sec.Size);
+
+ Sec := Get_String_Table (Res);
+ Res.Symstr_Stream := Create_Stream (Res, Sec);
+
+ return Res;
+ end Initialize;
+
+ -----------------
+ -- Read_Header --
+ -----------------
+
+ function Read_Header (F : in out Mapped_Stream) return Header is
+ Hdr : Header;
+ begin
+ Seek (F, 0);
+ Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU));
+ return Hdr;
+ end Read_Header;
+
+ -------------------------
+ -- Read_Section_Header --
+ -------------------------
+
+ function Read_Section_Header
+ (Obj : in out ELF_Object_File;
+ Shnum : uint32) return Section_Header
+ is
+ Shdr : Section_Header;
+ begin
+ Seek (Obj.Sectab_Stream, Offset (Shnum * Section_Header'Size / SSU));
+ Read_Raw (Obj.Sectab_Stream, Shdr'Address, Section_Header'Size / SSU);
+ return Shdr;
+ end Read_Section_Header;
+
+ -----------------
+ -- Read_Symbol --
+ -----------------
+
+ function Read_Symbol
+ (Obj : in out ELF_Object_File;
+ Off : Offset) return Object_Symbol
+ is
+ ST_Entry32 : Symtab_Entry32;
+ ST_Entry64 : Symtab_Entry64;
+ Res : Object_Symbol;
+
+ begin
+ Seek (Obj.Symtab_Stream, Off);
+
+ case uword'Size is
+ when 32 =>
+ Read_Raw (Obj.Symtab_Stream, ST_Entry32'Address,
+ uint32 (ST_Entry32'Size / SSU));
+ Res := (Off,
+ Off + ST_Entry32'Size / SSU,
+ uint64 (ST_Entry32.St_Value),
+ uint64 (ST_Entry32.St_Size));
+
+ when 64 =>
+ Read_Raw (Obj.Symtab_Stream, ST_Entry64'Address,
+ uint32 (ST_Entry64'Size / SSU));
+ Res := (Off,
+ Off + ST_Entry64'Size / SSU,
+ ST_Entry64.St_Value,
+ ST_Entry64.St_Size);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ return Res;
+ end Read_Symbol;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name
+ (Obj : in out ELF_Object_File;
+ Sec : Object_Section) return String
+ is
+ SHdr : Section_Header;
+ begin
+ SHdr := Read_Section_Header (Obj, Sec.Num);
+ return Offset_To_String (Obj.Secstr_Stream, Offset (SHdr.Sh_Name));
+ end Name;
+
+ function Name
+ (Obj : in out ELF_Object_File;
+ Sym : Object_Symbol) return String_Ptr_Len
+ is
+ ST_Entry32 : Symtab_Entry32;
+ ST_Entry64 : Symtab_Entry64;
+ Name_Off : Offset;
+
+ begin
+ -- Test that this symbol is not null
+
+ if Sym = Null_Symbol then
+ return (null, 0);
+ end if;
+
+ -- Read the symbol table entry
+
+ Seek (Obj.Symtab_Stream, Sym.Off);
+
+ case uword'Size is
+ when 32 =>
+ Read_Raw (Obj.Symtab_Stream, ST_Entry32'Address,
+ uint32 (ST_Entry32'Size / SSU));
+ Name_Off := Offset (ST_Entry32.St_Name);
+
+ when 64 =>
+ Read_Raw (Obj.Symtab_Stream, ST_Entry64'Address,
+ uint32 (ST_Entry64'Size / SSU));
+ Name_Off := Offset (ST_Entry64.St_Name);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Fetch the name from the string table
+
+ Seek (Obj.Symstr_Stream, Name_Off);
+ return Read (Obj.Symstr_Stream);
+ end Name;
+
+ end ELF_Ops;
+
+ package ELF32_Ops is new ELF_Ops (uint32);
+ package ELF64_Ops is new ELF_Ops (uint64);
+
+ ----------------
+ -- PECOFF_Ops --
+ ----------------
+
+ package body PECOFF_Ops is
+
+ function Decode_Name
+ (Obj : in out PECOFF_Object_File;
+ Raw_Name : String) return String;
+ -- A section name is an 8 byte field padded on the right with null
+ -- characters, or a '\' followed by an ASCII decimal string indicating
+ -- an offset in to the string table. This routine decodes this
+
+ function Get_Section_Virtual_Address
+ (Obj : in out PECOFF_Object_File;
+ Index : uint32) return uint64;
+ -- Fetch the address at which a section is loaded
+
+ function Read_Section_Header
+ (Obj : in out PECOFF_Object_File;
+ Index : uint32) return Section_Header;
+ -- Read a header from section table
+
+ function String_Table
+ (Obj : in out PECOFF_Object_File;
+ Index : Offset) return String;
+ -- Return an entry from the string table
+
+ -----------------
+ -- Decode_Name --
+ -----------------
+
+ function Decode_Name
+ (Obj : in out PECOFF_Object_File;
+ Raw_Name : String) return String
+ is
+ Name_Or_Ref : constant String := Trim_Trailing_Nuls (Raw_Name);
+ Off : Offset;
+
+ begin
+ -- We should never find a symbol with a zero length name. If we do it
+ -- probably means we are not parsing the symbol table correctly. If
+ -- this happens we raise a fatal error.
+
+ if Name_Or_Ref'Length = 0 then
+ raise Format_Error with
+ "found zero length symbol in symbol table";
+ end if;
+
+ if Name_Or_Ref (1) /= '/' then
+ return Name_Or_Ref;
+ else
+ Off := Offset'Value (Name_Or_Ref (2 .. Name_Or_Ref'Last));
+ return String_Table (Obj, Off);
+ end if;
+ end Decode_Name;
+
+ ------------------
+ -- First_Symbol --
+ ------------------
+
+ function First_Symbol
+ (Obj : in out PECOFF_Object_File) return Object_Symbol is
+ begin
+ -- Return Null_Symbol in the case that the symbol table is empty
+
+ if Obj.Symtab_Last = 0 then
+ return Null_Symbol;
+ end if;
+
+ return Read_Symbol (Obj, 0);
+ end First_Symbol;
+
+ -----------------
+ -- Get_Section --
+ -----------------
+
+ function Get_Section
+ (Obj : in out PECOFF_Object_File;
+ Index : uint32) return Object_Section
+ is
+ Sec : constant Section_Header := Read_Section_Header (Obj, Index);
+ begin
+ -- Use VirtualSize instead of SizeOfRawData. The latter is rounded to
+ -- the page size, so it may add garbage to the content. On the other
+ -- side, the former may be larger than the latter in case of 0
+ -- padding.
+
+ return (Index,
+ Offset (Sec.PointerToRawData),
+ uint64 (Sec.VirtualAddress) + Obj.ImageBase,
+ uint64 (Sec.VirtualSize),
+ (Sec.Characteristics and IMAGE_SCN_CNT_CODE) /= 0);
+ end Get_Section;
+
+ ---------------------------------
+ -- Get_Section_Virtual_Address --
+ ---------------------------------
+
+ function Get_Section_Virtual_Address
+ (Obj : in out PECOFF_Object_File;
+ Index : uint32) return uint64
+ is
+ Sec : Section_Header;
+
+ begin
+ -- Try cache
+
+ if Index = Obj.GSVA_Sec then
+ return Obj.GSVA_Addr;
+ end if;
+
+ Obj.GSVA_Sec := Index;
+ Sec := Read_Section_Header (Obj, Index);
+ Obj.GSVA_Addr := Obj.ImageBase + uint64 (Sec.VirtualAddress);
+ return Obj.GSVA_Addr;
+ end Get_Section_Virtual_Address;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ function Initialize
+ (F : Mapped_File;
+ Hdr : Header;
+ In_Exception : Boolean) return PECOFF_Object_File
+ is
+ Res : PECOFF_Object_File
+ (Format => (case Hdr.Variant is
+ when PECOFF_Ops.VARIANT_PE32 => PECOFF,
+ when PECOFF_Ops.VARIANT_PE32_PLUS => PECOFF_PLUS,
+ when others => raise Program_Error
+ with "unrecognized PECOFF variant"));
+ Symtab_Size : constant Offset :=
+ Offset (Hdr.NumberOfSymbols) * (Symtab_Entry'Size / SSU);
+ Strtab_Size : uint32;
+ Hdr_Offset : Offset;
+ Opt_Offset : File_Size;
+ Opt_Stream : Mapped_Stream;
+ begin
+ Res.MF := F;
+ Res.In_Exception := In_Exception;
+
+ case Hdr.Machine is
+ when PECOFF_Ops.IMAGE_FILE_MACHINE_I386 =>
+ Res.Arch := i386;
+ when PECOFF_Ops.IMAGE_FILE_MACHINE_IA64 =>
+ Res.Arch := IA64;
+ when PECOFF_Ops.IMAGE_FILE_MACHINE_AMD64 =>
+ Res.Arch := x86_64;
+ when others =>
+ raise Format_Error with "unrecognized architecture";
+ end case;
+
+ Res.Num_Sections := uint32 (Hdr.NumberOfSections);
+
+ -- Map symbol table and the first following word (which is the length
+ -- of the string table).
+
+ Res.Symtab_Last := Symtab_Size;
+ Res.Symtab_Stream := Create_Stream
+ (F,
+ File_Size (Hdr.PointerToSymbolTable),
+ File_Size (Symtab_Size + 4));
+
+ -- Map string table. The first 4 bytes are the length of the string
+ -- table and are part of it.
+
+ Seek (Res.Symtab_Stream, Symtab_Size);
+ Strtab_Size := Read (Res.Symtab_Stream);
+ Res.Symstr_Stream := Create_Stream
+ (F,
+ File_Size (Hdr.PointerToSymbolTable) + File_Size (Symtab_Size),
+ File_Size (Strtab_Size));
+
+ -- Map section table
+
+ Opt_Stream := Create_Stream (Res.Mf, Signature_Loc_Offset, 4);
+ Hdr_Offset := Offset (uint32'(Read (Opt_Stream)));
+ Close (Opt_Stream);
+ Res.Sectab_Stream := Create_Stream
+ (F,
+ File_Size (Hdr_Offset +
+ Size_Of_Standard_Header_Fields +
+ Offset (Hdr.SizeOfOptionalHeader)),
+ File_Size (Res.Num_Sections)
+ * File_Size (Section_Header'Size / SSU));
+
+ -- Read optional header and extract image base
+
+ Opt_Offset := File_Size (Hdr_Offset + Size_Of_Standard_Header_Fields);
+
+ if Res.Format = PECOFF then
+ declare
+ Opt_32 : Optional_Header_PE32;
+ begin
+ Opt_Stream := Create_Stream
+ (Res.Mf, Opt_Offset, Opt_32'Size / SSU);
+ Read_Raw
+ (Opt_Stream, Opt_32'Address, uint32 (Opt_32'Size / SSU));
+ Res.ImageBase := uint64 (Opt_32.ImageBase);
+ Close (Opt_Stream);
+ end;
+
+ else
+ declare
+ Opt_64 : Optional_Header_PE64;
+ begin
+ Opt_Stream := Create_Stream
+ (Res.Mf, Opt_Offset, Opt_64'Size / SSU);
+ Read_Raw
+ (Opt_Stream, Opt_64'Address, uint32 (Opt_64'Size / SSU));
+ Res.ImageBase := Opt_64.ImageBase;
+ Close (Opt_Stream);
+ end;
+ end if;
+
+ return Res;
+ end Initialize;
+
+ -----------------
+ -- Read_Symbol --
+ -----------------
+
+ function Read_Symbol
+ (Obj : in out PECOFF_Object_File;
+ Off : Offset) return Object_Symbol
+ is
+ ST_Entry : Symtab_Entry;
+ ST_Last : Symtab_Entry;
+ Aux_Entry : Auxent_Section;
+ Sz : constant Offset := ST_Entry'Size / SSU;
+ Result : Object_Symbol;
+ Noff : Offset;
+ Sym_Off : Offset;
+
+ begin
+ -- Seek to the successor of Prev
+
+ Noff := Off;
+
+ loop
+ Sym_Off := Noff;
+
+ Seek (Obj.Symtab_Stream, Sym_Off);
+ Read_Raw (Obj.Symtab_Stream, ST_Entry'Address, uint32 (Sz));
+
+ -- Skip AUX entries
+
+ Noff := Noff + Offset (1 + ST_Entry.NumberOfAuxSymbols) * Sz;
+
+ exit when ST_Entry.TypeField = Function_Symbol_Type
+ and then ST_Entry.SectionNumber > 0;
+
+ if Noff >= Obj.Symtab_Last then
+ return Null_Symbol;
+ end if;
+ end loop;
+
+ -- Construct the symbol
+
+ Result :=
+ (Off => Sym_Off,
+ Next => Noff,
+ Value => uint64 (ST_Entry.Value),
+ Size => 0);
+
+ -- Set the size as accurately as possible
+
+ -- The size of a symbol is not directly available so we try scanning
+ -- to the next function and assuming the code ends there.
+
+ loop
+ -- Read symbol and AUX entries
+
+ Sym_Off := Noff;
+ Seek (Obj.Symtab_Stream, Sym_Off);
+ Read_Raw (Obj.Symtab_Stream, ST_Last'Address, uint32 (Sz));
+
+ for I in 1 .. ST_Last.NumberOfAuxSymbols loop
+ Read_Raw (Obj.Symtab_Stream, Aux_Entry'Address, uint32 (Sz));
+ end loop;
+
+ Noff := Noff + Offset (1 + ST_Last.NumberOfAuxSymbols) * Sz;
+
+ if ST_Last.TypeField = Function_Symbol_Type then
+ if ST_Last.SectionNumber = ST_Entry.SectionNumber
+ and then ST_Last.Value >= ST_Entry.Value
+ then
+ -- Symbol is a function past ST_Entry
+
+ Result.Size := uint64 (ST_Last.Value - ST_Entry.Value);
+
+ else
+ -- Not correlated function
+
+ Result.Next := Sym_Off;
+ end if;
+
+ exit;
+
+ elsif ST_Last.SectionNumber = ST_Entry.SectionNumber
+ and then ST_Last.TypeField = Not_Function_Symbol_Type
+ and then ST_Last.StorageClass = 3
+ and then ST_Last.NumberOfAuxSymbols = 1
+ then
+ -- Symbol is a section
+
+ Result.Size := uint64 (ST_Last.Value + Aux_Entry.Length
+ - ST_Entry.Value);
+ Result.Next := Noff;
+ exit;
+ end if;
+
+ exit when Noff >= Obj.Symtab_Last;
+ end loop;
+
+ -- Relocate the address
+
+ Result.Value :=
+ Result.Value + Get_Section_Virtual_Address
+ (Obj, uint32 (ST_Entry.SectionNumber - 1));
+
+ return Result;
+ end Read_Symbol;
+
+ ------------------
+ -- Read_Header --
+ ------------------
+
+ function Read_Header (F : in out Mapped_Stream) return Header is
+ Hdr : Header;
+ Off : int32;
+
+ begin
+ -- Skip the MSDOS stub, and seek directly to the file offset
+
+ Seek (F, Signature_Loc_Offset);
+ Off := Read (F);
+
+ -- Read the COFF file header
+
+ Seek (F, Offset (Off));
+ Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU));
+ return Hdr;
+ end Read_Header;
+
+ -------------------------
+ -- Read_Section_Header --
+ -------------------------
+
+ function Read_Section_Header
+ (Obj : in out PECOFF_Object_File;
+ Index : uint32) return Section_Header
+ is
+ Sec : Section_Header;
+ begin
+ Seek (Obj.Sectab_Stream, Offset (Index * Section_Header'Size / SSU));
+ Read_Raw (Obj.Sectab_Stream, Sec'Address, Section_Header'Size / SSU);
+ return Sec;
+ end Read_Section_Header;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name
+ (Obj : in out PECOFF_Object_File;
+ Sec : Object_Section) return String
+ is
+ Shdr : constant Section_Header := Read_Section_Header (Obj, Sec.Num);
+ begin
+ return Decode_Name (Obj, Shdr.Name);
+ end Name;
+
+ -------------------
+ -- String_Table --
+ -------------------
+
+ function String_Table
+ (Obj : in out PECOFF_Object_File;
+ Index : Offset) return String is
+ begin
+ -- An index of zero is used to represent an empty string, as the
+ -- first word of the string table is specified to contain the length
+ -- of the table rather than its contents.
+
+ if Index = 0 then
+ return "";
+
+ else
+ return Offset_To_String (Obj.Symstr_Stream, Index);
+ end if;
+ end String_Table;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name
+ (Obj : in out PECOFF_Object_File;
+ Sym : Object_Symbol) return String_Ptr_Len
+ is
+ ST_Entry : Symtab_Entry;
+
+ begin
+ Seek (Obj.Symtab_Stream, Sym.Off);
+ Read_Raw (Obj.Symtab_Stream, ST_Entry'Address, ST_Entry'Size / SSU);
+
+ declare
+ -- Symbol table entries are packed and Table_Entry.Name may not be
+ -- sufficiently aligned to interpret as a 32 bit word, so it is
+ -- copied to a temporary
+
+ Aligned_Name : Name_Str := ST_Entry.Name;
+ for Aligned_Name'Alignment use 4;
+
+ First_Word : uint32;
+ pragma Import (Ada, First_Word);
+ -- Suppress initialization in Normalized_Scalars mode
+ for First_Word'Address use Aligned_Name (1)'Address;
+
+ Second_Word : uint32;
+ pragma Import (Ada, Second_Word);
+ -- Suppress initialization in Normalized_Scalars mode
+ for Second_Word'Address use Aligned_Name (5)'Address;
+
+ begin
+ if First_Word = 0 then
+ -- Second word is an offset in the symbol table
+ if Second_Word = 0 then
+ return (null, 0);
+ else
+ Seek (Obj.Symstr_Stream, int64 (Second_Word));
+ return Read (Obj.Symstr_Stream);
+ end if;
+ else
+ -- Inlined symbol name
+ Seek (Obj.Symtab_Stream, Sym.Off);
+ return To_String_Ptr_Len (Read (Obj.Symtab_Stream), 8);
+ end if;
+ end;
+ end Name;
+
+ end PECOFF_Ops;
+
+ -----------------
+ -- XCOFF32_Ops --
+ -----------------
+
+ package body XCOFF32_Ops is
+
+ function Read_Section_Header
+ (Obj : in out XCOFF32_Object_File;
+ Index : uint32) return Section_Header;
+ -- Read a header from section table
+
+ -----------------
+ -- Read_Symbol --
+ -----------------
+
+ function Read_Symbol
+ (Obj : in out XCOFF32_Object_File;
+ Off : Offset) return Object_Symbol
+ is
+ Sym : Symbol_Entry;
+ Sz : constant Offset := Symbol_Entry'Size / SSU;
+ Aux : Aux_Entry;
+ Result : Object_Symbol;
+ Noff : Offset;
+ Sym_Off : Offset;
+
+ procedure Read_LD_Symbol;
+ -- Read the next LD symbol
+
+ --------------------
+ -- Read_LD_Symbol --
+ --------------------
+
+ procedure Read_LD_Symbol is
+ begin
+ loop
+ Sym_Off := Noff;
+
+ Read_Raw (Obj.Symtab_Stream, Sym'Address, uint32 (Sz));
+
+ Noff := Noff + Offset (1 + Sym.n_numaux) * Sz;
+
+ for J in 1 .. Sym.n_numaux loop
+ Read_Raw (Obj.Symtab_Stream, Aux'Address, uint32 (Sz));
+ end loop;
+
+ exit when Noff >= Obj.Symtab_Last;
+
+ exit when Sym.n_numaux = 1
+ and then Sym.n_scnum /= 0
+ and then (Sym.n_sclass = C_EXT
+ or else Sym.n_sclass = C_HIDEXT
+ or else Sym.n_sclass = C_WEAKEXT)
+ and then Aux.x_smtyp = XTY_LD;
+ end loop;
+ end Read_LD_Symbol;
+
+ -- Start of processing for Read_Symbol
+
+ begin
+ Seek (Obj.Symtab_Stream, Off);
+ Noff := Off;
+ Read_LD_Symbol;
+
+ if Noff >= Obj.Symtab_Last then
+ return Null_Symbol;
+ end if;
+
+ -- Construct the symbol
+
+ Result := (Off => Sym_Off,
+ Next => Noff,
+ Value => uint64 (Sym.n_value),
+ Size => 0);
+
+ -- Look for the next symbol to compute the size
+
+ Read_LD_Symbol;
+
+ if Noff >= Obj.Symtab_Last then
+ return Null_Symbol;
+ end if;
+
+ Result.Size := uint64 (Sym.n_value) - Result.Value;
+ Result.Next := Sym_Off;
+ return Result;
+ end Read_Symbol;
+
+ ------------------
+ -- First_Symbol --
+ ------------------
+
+ function First_Symbol
+ (Obj : in out XCOFF32_Object_File) return Object_Symbol
+ is
+ begin
+ -- Return Null_Symbol in the case that the symbol table is empty
+
+ if Obj.Symtab_Last = 0 then
+ return Null_Symbol;
+ end if;
+
+ return Read_Symbol (Obj, 0);
+ end First_Symbol;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ function Initialize
+ (F : Mapped_File;
+ Hdr : Header;
+ In_Exception : Boolean) return XCOFF32_Object_File
+ is
+ Res : XCOFF32_Object_File (Format => XCOFF32);
+ Strtab_Sz : uint32;
+ begin
+ Res.Mf := F;
+ Res.In_Exception := In_Exception;
+
+ Res.Arch := PPC;
+
+ -- Map sections table
+ Res.Num_Sections := uint32 (Hdr.f_nscns);
+ Res.Sectab_Stream := Create_Stream
+ (F,
+ File_Size (Header'Size / SSU) + File_Size (Hdr.f_opthdr),
+ File_Size (Hdr.f_nscns) * (Section_Header'Size / SSU));
+
+ -- Map symbols table
+ Res.Symtab_Last := Offset (Hdr.f_nscns) * (Symbol_Entry'Size / SSU);
+ Res.Symtab_Stream := Create_Stream
+ (F,
+ File_Size (Hdr.f_symptr),
+ File_Size (Res.Symtab_Last) + 4);
+
+ -- Map string table
+ Seek (Res.Symtab_Stream, Res.Symtab_Last);
+ Strtab_Sz := Read (Res.Symtab_Stream);
+ Res.Symstr_Stream := Create_Stream
+ (F,
+ File_Size (Res.Symtab_Last) + 4,
+ File_Size (Strtab_Sz) - 4);
+
+ return Res;
+ end Initialize;
+
+ -----------------
+ -- Get_Section --
+ -----------------
+
+ function Get_Section
+ (Obj : in out XCOFF32_Object_File;
+ Index : uint32) return Object_Section
+ is
+ Sec : constant Section_Header := Read_Section_Header (Obj, Index);
+ begin
+ return (Index, Offset (Sec.s_scnptr),
+ uint64 (Sec.s_vaddr),
+ uint64 (Sec.s_size),
+ (Sec.s_flags and STYP_TEXT) /= 0);
+ end Get_Section;
+
+ -----------------
+ -- Read_Header --
+ -----------------
+
+ function Read_Header (F : in out Mapped_Stream) return Header is
+ Hdr : Header;
+ begin
+ Seek (F, 0);
+ Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU));
+ return Hdr;
+ end Read_Header;
+
+ -------------------------
+ -- Read_Section_Header --
+ -------------------------
+
+ function Read_Section_Header
+ (Obj : in out XCOFF32_Object_File;
+ Index : uint32) return Section_Header
+ is
+ Sec : Section_Header;
+
+ begin
+ -- Seek to the end of the object header
+
+ Seek (Obj.Sectab_Stream, Offset (Index * Section_Header'Size / SSU));
+
+ -- Read the section
+
+ Read_Raw (Obj.Sectab_Stream, Sec'Address, Section_Header'Size / SSU);
+
+ return Sec;
+ end Read_Section_Header;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name
+ (Obj : in out XCOFF32_Object_File;
+ Sec : Object_Section) return String
+ is
+ Hdr : Section_Header;
+ begin
+ Hdr := Read_Section_Header (Obj, Sec.Num);
+ return Trim_Trailing_Nuls (Hdr.s_name);
+ end Name;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name
+ (Obj : in out XCOFF32_Object_File;
+ Sym : Object_Symbol) return String_Ptr_Len
+ is
+ Symbol : Symbol_Entry;
+
+ begin
+ Seek (Obj.Symtab_Stream, Sym.Off);
+ Read_Raw (Obj.Symtab_Stream, Symbol'Address, Symbol'Size / SSU);
+
+ declare
+ First_Word : uint32;
+ pragma Import (Ada, First_Word);
+ -- Suppress initialization in Normalized_Scalars mode
+ for First_Word'Address use Symbol.n_name (1)'Address;
+
+ Second_Word : uint32;
+ pragma Import (Ada, Second_Word);
+ -- Suppress initialization in Normalized_Scalars mode
+ for Second_Word'Address use Symbol.n_name (5)'Address;
+
+ begin
+ if First_Word = 0 then
+ if Second_Word = 0 then
+ return (null, 0);
+ else
+ Seek (Obj.Symstr_Stream, int64 (Second_Word));
+ return Read (Obj.Symstr_Stream);
+ end if;
+ else
+ Seek (Obj.Symtab_Stream, Sym.Off);
+ return To_String_Ptr_Len (Read (Obj.Symstr_Stream), 8);
+ end if;
+ end;
+ end Name;
+ end XCOFF32_Ops;
+
+ ----------
+ -- Arch --
+ ----------
+
+ function Arch (Obj : Object_File) return Object_Arch is
+ begin
+ return Obj.Arch;
+ end Arch;
+
+ function Create_Stream
+ (Mf : Mapped_File;
+ File_Offset : File_Size;
+ File_Length : File_Size)
+ return Mapped_Stream
+ is
+ Region : Mapped_Region;
+ begin
+ Read (Mf, Region, File_Offset, File_Length, False);
+ return (Region, 0, Offset (File_Length));
+ end Create_Stream;
+
+ function Create_Stream
+ (Obj : Object_File;
+ Sec : Object_Section) return Mapped_Stream is
+ begin
+ return Create_Stream (Obj.Mf, File_Size (Sec.Off), File_Size (Sec.Size));
+ end Create_Stream;
+
+ procedure Tell (Obj : in out Mapped_Stream; Off : out Offset) is
+ begin
+ Off := Obj.Off;
+ end Tell;
+
+ function Tell (Obj : Mapped_Stream) return Offset is
+ begin
+ return Obj.Off;
+ end Tell;
+
+ function Length (Obj : Mapped_Stream) return Offset is
+ begin
+ return Obj.Len;
+ end Length;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (S : in out Mapped_Stream) is
+ begin
+ Free (S.Region);
+ end Close;
+
+ procedure Close (Obj : in out Object_File) is
+ begin
+ Close (Obj.Symtab_Stream);
+ Close (Obj.Symstr_Stream);
+ Close (Obj.Sectab_Stream);
+
+ case Obj.Format is
+ when ELF =>
+ Close (Obj.Secstr_Stream);
+ when Any_PECOFF =>
+ null;
+ when XCOFF32 =>
+ null;
+ end case;
+
+ Close (Obj.Mf);
+ end Close;
+
+ ------------------------
+ -- Strip_Leading_Char --
+ ------------------------
+
+ function Strip_Leading_Char
+ (Obj : in out Object_File;
+ Sym : String_Ptr_Len) return Positive is
+ begin
+ if (Obj.Format = PECOFF and then Sym.Ptr (1) = '_')
+ or else
+ (Obj.Format = XCOFF32 and then Sym.Ptr (1) = '.')
+ then
+ return 2;
+ else
+ return 1;
+ end if;
+ end Strip_Leading_Char;
+
+ ----------------------
+ -- Decoded_Ada_Name --
+ ----------------------
+
+ function Decoded_Ada_Name
+ (Obj : in out Object_File;
+ Sym : String_Ptr_Len) return String
+ is
+ procedure gnat_decode
+ (Coded_Name_Addr : Address;
+ Ada_Name_Addr : Address;
+ Verbose : int);
+ pragma Import (C, gnat_decode, "__gnat_decode");
+
+ subtype size_t is Interfaces.C.size_t;
+
+ Sym_Name : constant String :=
+ String (Sym.Ptr (1 .. Sym.Len)) & ASCII.NUL;
+ Decoded : char_array (0 .. size_t (Sym.Len) * 2 + 60);
+ Off : Natural;
+ begin
+ -- In the PECOFF case most but not all symbol table entries have an
+ -- extra leading underscore. In this case we trim it.
+
+ Off := Strip_Leading_Char (Obj, Sym);
+
+ gnat_decode (Sym_Name (Off)'Address, Decoded'Address, 0);
+
+ return To_Ada (Decoded);
+ end Decoded_Ada_Name;
+
+ ------------------
+ -- First_Symbol --
+ ------------------
+
+ function First_Symbol (Obj : in out Object_File) return Object_Symbol is
+ begin
+ case Obj.Format is
+ when ELF32 => return ELF32_Ops.First_Symbol (Obj);
+ when ELF64 => return ELF64_Ops.First_Symbol (Obj);
+ when Any_PECOFF => return PECOFF_Ops.First_Symbol (Obj);
+ when XCOFF32 => return XCOFF32_Ops.First_Symbol (Obj);
+ end case;
+ end First_Symbol;
+
+ ------------
+ -- Format --
+ ------------
+
+ function Format (Obj : Object_File) return Object_Format is
+ begin
+ return Obj.Format;
+ end Format;
+
+ ----------------------
+ -- Get_Load_Address --
+ ----------------------
+
+ function Get_Load_Address (Obj : Object_File) return uint64 is
+ begin
+ raise Format_Error with "Get_Load_Address not implemented";
+ return 0;
+ end Get_Load_Address;
+
+ -----------------
+ -- Get_Section --
+ -----------------
+
+ function Get_Section
+ (Obj : in out Object_File;
+ Shnum : uint32) return Object_Section is
+ begin
+ case Obj.Format is
+ when ELF32 => return ELF32_Ops.Get_Section (Obj, Shnum);
+ when ELF64 => return ELF64_Ops.Get_Section (Obj, Shnum);
+ when Any_PECOFF => return PECOFF_Ops.Get_Section (Obj, Shnum);
+ when XCOFF32 => return XCOFF32_Ops.Get_Section (Obj, Shnum);
+ end case;
+ end Get_Section;
+
+ function Get_Section
+ (Obj : in out Object_File;
+ Sec_Name : String) return Object_Section
+ is
+ Sec : Object_Section;
+
+ begin
+ for J in 0 .. Obj.Num_Sections - 1 loop
+ Sec := Get_Section (Obj, J);
+
+ if Name (Obj, Sec) = Sec_Name then
+ return Sec;
+ end if;
+ end loop;
+
+ if Obj.In_Exception then
+ return Null_Section;
+ else
+ raise Format_Error with "could not find section in object file";
+ end if;
+ end Get_Section;
+
+ -----------------------
+ -- Get_Memory_Bounds --
+ -----------------------
+
+ procedure Get_Memory_Bounds
+ (Obj : in out Object_File;
+ Low, High : out uint64) is
+ Sec : Object_Section;
+ begin
+ -- First set as an empty range
+ Low := uint64'Last;
+ High := uint64'First;
+
+ for Idx in 1 .. Num_Sections (Obj) loop
+ Sec := Get_Section (Obj, Idx - 1);
+ if Sec.Flag_Alloc then
+ if Sec.Addr < Low then
+ Low := Sec.Addr;
+ end if;
+ if Sec.Addr + Sec.Size > High then
+ High := Sec.Addr + Sec.Size;
+ end if;
+ end if;
+ end loop;
+ end Get_Memory_Bounds;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name
+ (Obj : in out Object_File;
+ Sec : Object_Section) return String is
+ begin
+ case Obj.Format is
+ when ELF32 => return ELF32_Ops.Name (Obj, Sec);
+ when ELF64 => return ELF64_Ops.Name (Obj, Sec);
+ when Any_PECOFF => return PECOFF_Ops.Name (Obj, Sec);
+ when XCOFF32 => return XCOFF32_Ops.Name (Obj, Sec);
+ end case;
+ end Name;
+
+ function Name
+ (Obj : in out Object_File;
+ Sym : Object_Symbol) return String_Ptr_Len is
+ begin
+ case Obj.Format is
+ when ELF32 => return ELF32_Ops.Name (Obj, Sym);
+ when ELF64 => return ELF64_Ops.Name (Obj, Sym);
+ when Any_PECOFF => return PECOFF_Ops.Name (Obj, Sym);
+ when XCOFF32 => return XCOFF32_Ops.Name (Obj, Sym);
+ end case;
+ end Name;
+
+ -----------------
+ -- Next_Symbol --
+ -----------------
+
+ function Next_Symbol
+ (Obj : in out Object_File;
+ Prev : Object_Symbol) return Object_Symbol is
+ begin
+ -- Test whether we've reached the end of the symbol table
+
+ if Prev.Next >= Obj.Symtab_Last then
+ return Null_Symbol;
+ end if;
+
+ return Read_Symbol (Obj, Prev.Next);
+ end Next_Symbol;
+
+ ---------
+ -- Num --
+ ---------
+
+ function Num (Sec : Object_Section) return uint32 is
+ begin
+ return Sec.Num;
+ end Num;
+
+ ------------------
+ -- Num_Sections --
+ ------------------
+
+ function Num_Sections (Obj : Object_File) return uint32 is
+ begin
+ return Obj.Num_Sections;
+ end Num_Sections;
+
+ ---------
+ -- Off --
+ ---------
+
+ function Off (Sec : Object_Section) return Offset is
+ begin
+ return Sec.Off;
+ end Off;
+
+ function Off (Sym : Object_Symbol) return Offset is
+ begin
+ return Sym.Off;
+ end Off;
+
+ ----------------------
+ -- Offset_To_String --
+ ----------------------
+
+ function Offset_To_String
+ (S : in out Mapped_Stream;
+ Off : Offset) return String
+ is
+ Buf : Buffer;
+ begin
+ Seek (S, Off);
+ Read_C_String (S, Buf);
+ return To_String (Buf);
+ end Offset_To_String;
+
+ ----------
+ -- Open --
+ ----------
+
+ function Open
+ (File_Name : String;
+ In_Exception : Boolean := False) return Object_File_Access
+ is
+ F : Mapped_File;
+ Hdr_Stream : Mapped_Stream;
+
+ begin
+ -- Open the file
+
+ F := Open_Read_No_Exception (File_Name);
+
+ if F = Invalid_Mapped_File then
+ if In_Exception then
+ return null;
+ else
+ raise IO_Error with "could not open object file";
+ end if;
+ end if;
+
+ Hdr_Stream := Create_Stream (F, 0, 4096);
+
+ declare
+ Hdr : constant ELF32_Ops.Header := ELF32_Ops.Read_Header (Hdr_Stream);
+
+ begin
+ -- Look for the magic numbers for the ELF case
+
+ if Hdr.E_Ident (0) = 16#7F# and then
+ Hdr.E_Ident (1) = Character'Pos ('E') and then
+ Hdr.E_Ident (2) = Character'Pos ('L') and then
+ Hdr.E_Ident (3) = Character'Pos ('F') and then
+ Hdr.E_Ident (4) = ELF32_Ops.ELFCLASS32
+ then
+ Close (Hdr_Stream);
+ return new Object_File'
+ (ELF32_Ops.Initialize (F, Hdr, In_Exception));
+ end if;
+ end;
+
+ declare
+ Hdr : constant ELF64_Ops.Header :=
+ ELF64_Ops.Read_Header (Hdr_Stream);
+
+ begin
+ -- Look for the magic numbers for the ELF case
+
+ if Hdr.E_Ident (0) = 16#7F# and then
+ Hdr.E_Ident (1) = Character'Pos ('E') and then
+ Hdr.E_Ident (2) = Character'Pos ('L') and then
+ Hdr.E_Ident (3) = Character'Pos ('F') and then
+ Hdr.E_Ident (4) = ELF32_Ops.ELFCLASS64
+ then
+ Close (Hdr_Stream);
+ return new Object_File'
+ (ELF64_Ops.Initialize (F, Hdr, In_Exception));
+ end if;
+ end;
+
+ declare
+ Hdr : constant PECOFF_Ops.Header :=
+ PECOFF_Ops.Read_Header (Hdr_Stream);
+
+ begin
+ -- Test the magic numbers
+
+ if Hdr.Magics (0) = Character'Pos ('P') and then
+ Hdr.Magics (1) = Character'Pos ('E') and then
+ Hdr.Magics (2) = 0 and then
+ Hdr.Magics (3) = 0
+ then
+ Close (Hdr_Stream);
+ return new Object_File'
+ (PECOFF_Ops.Initialize (F, Hdr, In_Exception));
+ end if;
+
+ exception
+ -- If this is not a PECOFF file then we've done a seek and read to a
+ -- random address, possibly raising IO_Error
+
+ when IO_Error =>
+ null;
+ end;
+
+ declare
+ Hdr : constant XCOFF32_Ops.Header :=
+ XCOFF32_Ops.Read_Header (Hdr_Stream);
+
+ begin
+ -- Test the magic numbers
+
+ if Hdr.f_magic = 8#0737# then
+ Close (Hdr_Stream);
+ return new Object_File'
+ (XCOFF32_Ops.Initialize (F, Hdr, In_Exception));
+ end if;
+ end;
+
+ Close (Hdr_Stream);
+
+ if In_Exception then
+ return null;
+ else
+ raise Format_Error with "unrecognized object format";
+ end if;
+ end Open;
+
+ ----------
+ -- Read --
+ ----------
+
+ function Read (S : in out Mapped_Stream) return Mmap.Str_Access
+ is
+ function To_Str_Access is
+ new Ada.Unchecked_Conversion (Address, Str_Access);
+ begin
+ return To_Str_Access (Data (S.Region) (Natural (S.Off + 1))'Address);
+ end Read;
+
+ function Read (S : in out Mapped_Stream) return String_Ptr_Len is
+ begin
+ return To_String_Ptr_Len (Read (S));
+ end Read;
+
+ procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32) is
+ begin
+ if S.Off + Offset (Size) > Offset (Last (S.Region)) then
+ raise IO_Error with "could not read from object file";
+ end if;
+ end Check_Read_Offset;
+
+ procedure Read_Raw
+ (S : in out Mapped_Stream;
+ Addr : Address;
+ Size : uint32)
+ is
+ function To_Str_Access is
+ new Ada.Unchecked_Conversion (Address, Str_Access);
+
+ Sz : constant Offset := Offset (Size);
+ begin
+ -- Check size
+
+ pragma Debug (Check_Read_Offset (S, Size));
+
+ -- Copy data
+
+ To_Str_Access (Addr) (1 .. Positive (Sz)) :=
+ Data (S.Region) (Positive (S.Off + 1) .. Positive (S.Off + Sz));
+
+ -- Update offset
+
+ S.Off := S.Off + Sz;
+ end Read_Raw;
+
+ function Read (S : in out Mapped_Stream) return uint8 is
+ Data : uint8;
+ begin
+ Read_Raw (S, Data'Address, Data'Size / SSU);
+ return Data;
+ end Read;
+
+ function Read (S : in out Mapped_Stream) return uint16 is
+ Data : uint16;
+ begin
+ Read_Raw (S, Data'Address, Data'Size / SSU);
+ return Data;
+ end Read;
+
+ function Read (S : in out Mapped_Stream) return uint32 is
+ Data : uint32;
+ begin
+ Read_Raw (S, Data'Address, Data'Size / SSU);
+ return Data;
+ end Read;
+
+ function Read (S : in out Mapped_Stream) return uint64 is
+ Data : uint64;
+ begin
+ Read_Raw (S, Data'Address, Data'Size / SSU);
+ return Data;
+ end Read;
+
+ function Read (S : in out Mapped_Stream) return int8 is
+ Data : int8;
+ begin
+ Read_Raw (S, Data'Address, Data'Size / SSU);
+ return Data;
+ end Read;
+
+ function Read (S : in out Mapped_Stream) return int16 is
+ Data : int16;
+ begin
+ Read_Raw (S, Data'Address, Data'Size / SSU);
+ return Data;
+ end Read;
+
+ function Read (S : in out Mapped_Stream) return int32 is
+ Data : int32;
+ begin
+ Read_Raw (S, Data'Address, Data'Size / SSU);
+ return Data;
+ end Read;
+
+ function Read (S : in out Mapped_Stream) return int64 is
+ Data : int64;
+ begin
+ Read_Raw (S, Data'Address, Data'Size / SSU);
+ return Data;
+ end Read;
+
+ ------------------
+ -- Read_Address --
+ ------------------
+
+ function Read_Address
+ (Obj : Object_File; S : in out Mapped_Stream) return uint64 is
+ Address_32 : uint32;
+ Address_64 : uint64;
+
+ begin
+ case Obj.Arch is
+ when i386
+ | MIPS
+ | PPC
+ | SPARC
+ =>
+ Address_32 := Read (S);
+ return uint64 (Address_32);
+
+ when IA64
+ | PPC64
+ | SPARC64
+ | x86_64
+ =>
+ Address_64 := Read (S);
+ return Address_64;
+
+ when Unknown =>
+ raise Format_Error with "unrecognized machine architecture";
+ end case;
+ end Read_Address;
+
+ -------------------
+ -- Read_C_String --
+ -------------------
+
+ procedure Read_C_String (S : in out Mapped_Stream; B : out Buffer) is
+ J : Integer := 0;
+
+ begin
+ loop
+ -- Handle overflow case
+
+ if J = B'Last then
+ B (J) := 0;
+ exit;
+ end if;
+
+ B (J) := Read (S);
+ exit when B (J) = 0;
+ J := J + 1;
+ end loop;
+ end Read_C_String;
+
+ -------------------
+ -- Read_C_String --
+ -------------------
+
+ function Read_C_String (S : in out Mapped_Stream) return Str_Access is
+ Res : constant Str_Access := Read (S);
+
+ begin
+ for J in Res'Range loop
+ if S.Off + Offset (J - 1) > Offset (Last (S.Region)) then
+ raise IO_Error with "could not read from object file";
+ end if;
+
+ if Res (J) = ASCII.NUL then
+ S.Off := S.Off + Offset (J);
+ return Res;
+ end if;
+ end loop;
+
+ -- Overflow case
+ raise Constraint_Error;
+ end Read_C_String;
+
+ -----------------
+ -- Read_LEB128 --
+ -----------------
+
+ function Read_LEB128 (S : in out Mapped_Stream) return uint32 is
+ B : uint8;
+ Shift : Integer := 0;
+ Res : uint32 := 0;
+
+ begin
+ loop
+ B := Read (S);
+ Res := Res or Shift_Left (uint32 (B and 16#7f#), Shift);
+ exit when (B and 16#80#) = 0;
+ Shift := Shift + 7;
+ end loop;
+
+ return Res;
+ end Read_LEB128;
+
+ function Read_LEB128 (S : in out Mapped_Stream) return int32 is
+ B : uint8;
+ Shift : Integer := 0;
+ Res : uint32 := 0;
+
+ begin
+ loop
+ B := Read (S);
+ Res := Res or Shift_Left (uint32 (B and 16#7f#), Shift);
+ Shift := Shift + 7;
+ exit when (B and 16#80#) = 0;
+ end loop;
+
+ if Shift < 32 and then (Res and Shift_Left (1, Shift - 1)) /= 0 then
+ Res := Res or Shift_Left (-1, Shift);
+ end if;
+
+ return To_int32 (Res);
+ end Read_LEB128;
+
+ -----------------
+ -- Read_Symbol --
+ -----------------
+
+ function Read_Symbol
+ (Obj : in out Object_File;
+ Off : Offset) return Object_Symbol is
+ begin
+ case Obj.Format is
+ when ELF32 => return ELF32_Ops.Read_Symbol (Obj, Off);
+ when ELF64 => return ELF64_Ops.Read_Symbol (Obj, Off);
+ when Any_PECOFF => return PECOFF_Ops.Read_Symbol (Obj, Off);
+ when XCOFF32 => return XCOFF32_Ops.Read_Symbol (Obj, Off);
+ end case;
+ end Read_Symbol;
+
+ ----------
+ -- Seek --
+ ----------
+
+ procedure Seek (S : in out Mapped_Stream; Off : Offset) is
+ begin
+ if Off < 0 or else Off > Offset (Last (S.Region)) then
+ raise IO_Error with "could not seek to offset in object file";
+ end if;
+
+ S.Off := Off;
+ end Seek;
+
+ ----------
+ -- Size --
+ ----------
+
+ function Size (Sec : Object_Section) return uint64 is
+ begin
+ return Sec.Size;
+ end Size;
+
+ function Size (Sym : Object_Symbol) return uint64 is
+ begin
+ return Sym.Size;
+ end Size;
+
+ ------------
+ -- Strlen --
+ ------------
+
+ function Strlen (Buf : Buffer) return int32 is
+ begin
+ return int32 (CRTL.strlen (Buf'Address));
+ end Strlen;
+
+ -----------
+ -- Spans --
+ -----------
+
+ function Spans (Sym : Object_Symbol; Addr : uint64) return Boolean is
+ begin
+ return Addr >= Sym.Value and then Addr < Sym.Value + Sym.Size;
+ end Spans;
+
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (Buf : Buffer) return String is
+ Result : String (1 .. Integer (CRTL.strlen (Buf'Address)));
+ for Result'Address use Buf'Address;
+ pragma Import (Ada, Result);
+
+ begin
+ return Result;
+ end To_String;
+
+ -----------------------
+ -- To_String_Ptr_Len --
+ -----------------------
+
+ function To_String_Ptr_Len
+ (Ptr : Mmap.Str_Access;
+ Max_Len : Natural := Natural'Last) return String_Ptr_Len is
+ begin
+ for I in 1 .. Max_Len loop
+ if Ptr (I) = ASCII.NUL then
+ return (Ptr, I - 1);
+ end if;
+ end loop;
+ return (Ptr, Max_Len);
+ end To_String_Ptr_Len;
+
+ ------------------------
+ -- Trim_Trailing_Nuls --
+ ------------------------
+
+ function Trim_Trailing_Nuls (Str : String) return String is
+ begin
+ for J in Str'Range loop
+ if Str (J) = ASCII.NUL then
+ return Str (Str'First .. J - 1);
+ end if;
+ end loop;
+
+ return Str;
+ end Trim_Trailing_Nuls;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value (Sym : Object_Symbol) return uint64 is
+ begin
+ return Sym.Value;
+ end Value;
+
+end System.Object_Reader;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . O B J E C T _ R E A D E R --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package implements a simple, minimal overhead reader for object files
+-- composed of sections of untyped heterogeneous binary data.
+
+with Interfaces;
+with System.Mmap;
+
+package System.Object_Reader is
+
+ --------------
+ -- Limits --
+ --------------
+
+ BUFFER_SIZE : constant := 8 * 1024;
+
+ ------------------
+ -- Object files --
+ ------------------
+
+ type Object_File (<>) is private;
+
+ type Object_File_Access is access Object_File;
+
+ ---------------------
+ -- Object sections --
+ ----------------------
+
+ type Object_Section is private;
+
+ Null_Section : constant Object_Section;
+
+ --------------------
+ -- Object symbols --
+ --------------------
+
+ type Object_Symbol is private;
+
+ ------------------------
+ -- Object format type --
+ ------------------------
+
+ type Object_Format is
+ (ELF32,
+ -- Object format is 32-bit ELF
+
+ ELF64,
+ -- Object format is 64-bit ELF
+
+ PECOFF,
+ -- Object format is Microsoft PECOFF
+
+ PECOFF_PLUS,
+ -- Object format is Microsoft PECOFF+
+
+ XCOFF32);
+ -- Object format is AIX 32-bit XCOFF
+
+ -- PECOFF | PECOFF_PLUS appears so often as a case choice, would
+ -- seem a good idea to have a subtype name covering these two choices ???
+
+ ------------------------------
+ -- Object architecture type --
+ ------------------------------
+
+ type Object_Arch is
+ (Unknown,
+ -- The target architecture has not yet been determined
+
+ SPARC,
+ -- 32-bit SPARC
+
+ SPARC64,
+ -- 64-bit SPARC
+
+ i386,
+ -- Intel IA32
+
+ MIPS,
+ -- MIPS Technologies MIPS
+
+ x86_64,
+ -- x86-64 (64-bit AMD/Intel)
+
+ IA64,
+ -- Intel IA64
+
+ PPC,
+ -- 32-bit PowerPC
+
+ PPC64);
+ -- 64-bit PowerPC
+
+ ------------------
+ -- Target types --
+ ------------------
+
+ subtype Offset is Interfaces.Integer_64;
+
+ subtype uint8 is Interfaces.Unsigned_8;
+ subtype uint16 is Interfaces.Unsigned_16;
+ subtype uint32 is Interfaces.Unsigned_32;
+ subtype uint64 is Interfaces.Unsigned_64;
+
+ subtype int8 is Interfaces.Integer_8;
+ subtype int16 is Interfaces.Integer_16;
+ subtype int32 is Interfaces.Integer_32;
+ subtype int64 is Interfaces.Integer_64;
+
+ type Buffer is array (0 .. BUFFER_SIZE - 1) of uint8;
+
+ type String_Ptr_Len is record
+ Ptr : Mmap.Str_Access;
+ Len : Natural;
+ end record;
+ -- A string made from a pointer and a length. Not all strings for name
+ -- are C strings: COFF inlined symbol names have a max length of 8.
+
+ -------------------------------------------
+ -- Operations on buffers of untyped data --
+ -------------------------------------------
+
+ function To_String (Buf : Buffer) return String;
+ -- Construct string from C style null-terminated string stored in a buffer
+
+ function To_String_Ptr_Len
+ (Ptr : Mmap.Str_Access;
+ Max_Len : Natural := Natural'Last) return String_Ptr_Len;
+ -- Convert PTR to a String_Ptr_Len.
+
+ function Strlen (Buf : Buffer) return int32;
+ -- Return the length of a C style null-terminated string
+
+ -------------------------
+ -- Opening and closing --
+ -------------------------
+
+ function Open
+ (File_Name : String;
+ In_Exception : Boolean := False) return Object_File_Access;
+ -- Open the object file and initialize the reader. In_Exception is true
+ -- when the parsing is done as part of an exception handler decorator. In
+ -- this mode we do not want to raise an exception.
+
+ procedure Close (Obj : in out Object_File);
+ -- Close the object file
+
+ -----------------------
+ -- Sequential access --
+ -----------------------
+
+ type Mapped_Stream is private;
+ -- Provide an abstraction of a stream on a memory mapped file
+
+ function Create_Stream (Mf : System.Mmap.Mapped_File;
+ File_Offset : System.Mmap.File_Size;
+ File_Length : System.Mmap.File_Size)
+ return Mapped_Stream;
+ -- Create a stream from Mf
+
+ procedure Close (S : in out Mapped_Stream);
+ -- Close the stream (deallocate memory)
+
+ procedure Read_Raw
+ (S : in out Mapped_Stream;
+ Addr : Address;
+ Size : uint32);
+ pragma Inline (Read_Raw);
+ -- Read a number of fixed sized records
+
+ procedure Seek (S : in out Mapped_Stream; Off : Offset);
+ -- Seek to an absolute offset in bytes
+
+ procedure Tell (Obj : in out Mapped_Stream; Off : out Offset)
+ with Inline;
+ function Tell (Obj : Mapped_Stream) return Offset
+ with Inline;
+ -- Fetch the current offset
+
+ function Length (Obj : Mapped_Stream) return Offset
+ with Inline;
+ -- Length of the stream
+
+ function Read (S : in out Mapped_Stream) return Mmap.Str_Access;
+ -- Provide a pointer in memory at the current offset
+
+ function Read (S : in out Mapped_Stream) return String_Ptr_Len;
+ -- Provide a pointer in memory at the current offset
+
+ function Read (S : in out Mapped_Stream) return uint8;
+ function Read (S : in out Mapped_Stream) return uint16;
+ function Read (S : in out Mapped_Stream) return uint32;
+ function Read (S : in out Mapped_Stream) return uint64;
+ function Read (S : in out Mapped_Stream) return int8;
+ function Read (S : in out Mapped_Stream) return int16;
+ function Read (S : in out Mapped_Stream) return int32;
+ function Read (S : in out Mapped_Stream) return int64;
+ -- Read a scalar
+
+ function Read_Address
+ (Obj : Object_File; S : in out Mapped_Stream) return uint64;
+ -- Read either a 64 or 32 bit address from the file stream depending on the
+ -- address size of the target architecture and promote it to a 64 bit type.
+
+ function Read_LEB128 (S : in out Mapped_Stream) return uint32;
+ function Read_LEB128 (S : in out Mapped_Stream) return int32;
+ -- Read a value encoding in Little-Endian Base 128 format
+
+ procedure Read_C_String (S : in out Mapped_Stream; B : out Buffer);
+ function Read_C_String (S : in out Mapped_Stream) return Mmap.Str_Access;
+ -- Read a C style NULL terminated string
+
+ function Offset_To_String
+ (S : in out Mapped_Stream;
+ Off : Offset) return String;
+ -- Construct a string from a C style NULL terminated string located at an
+ -- offset into the object file.
+
+ ------------------------
+ -- Object information --
+ ------------------------
+
+ function Arch (Obj : Object_File) return Object_Arch;
+ -- Return the object architecture
+
+ function Format (Obj : Object_File) return Object_Format;
+ -- Return the object file format
+
+ function Get_Load_Address (Obj : Object_File) return uint64;
+ -- Return the load address defined in Obj. May raise Format_Error if not
+ -- implemented
+
+ function Num_Sections (Obj : Object_File) return uint32;
+ -- Return the number of sections composing the object file
+
+ function Get_Section
+ (Obj : in out Object_File;
+ Shnum : uint32) return Object_Section;
+ -- Return the Nth section (numbered from zero)
+
+ function Get_Section
+ (Obj : in out Object_File;
+ Sec_Name : String) return Object_Section;
+ -- Return a section by name
+
+ function Create_Stream
+ (Obj : Object_File;
+ Sec : Object_Section) return Mapped_Stream;
+ -- Create a stream for section Sec
+
+ procedure Get_Memory_Bounds
+ (Obj : in out Object_File;
+ Low, High : out uint64);
+ -- Return the low and high addresses of the code for the object file. Can
+ -- be used to check if an address in within this object file. This
+ -- procedure is not efficient and the result should be saved to avoid
+ -- recomputation.
+
+ -------------------------
+ -- Section information --
+ -------------------------
+
+ function Name
+ (Obj : in out Object_File;
+ Sec : Object_Section) return String;
+ -- Return the name of a section as a string
+
+ function Size (Sec : Object_Section) return uint64;
+ -- Return the size of a section in bytes
+
+ function Num (Sec : Object_Section) return uint32;
+ -- Return the index of a section from zero
+
+ function Off (Sec : Object_Section) return Offset;
+ -- Return the byte offset of the section within the object
+
+ ------------------------------
+ -- Symbol table information --
+ ------------------------------
+
+ Null_Symbol : constant Object_Symbol;
+ -- An empty symbol table entry.
+
+ function First_Symbol (Obj : in out Object_File) return Object_Symbol;
+ -- Return the first element in the symbol table or Null_Symbol if the
+ -- symbol table is empty.
+
+ function Next_Symbol
+ (Obj : in out Object_File;
+ Prev : Object_Symbol) return Object_Symbol;
+ -- Return the element following Prev in the symbol table, or Null_Symbol if
+ -- Prev is the last symbol in the table.
+
+ function Read_Symbol
+ (Obj : in out Object_File;
+ Off : Offset) return Object_Symbol;
+ -- Read symbol at Off
+
+ function Name
+ (Obj : in out Object_File;
+ Sym : Object_Symbol) return String_Ptr_Len;
+ -- Return the name of the symbol
+
+ function Decoded_Ada_Name
+ (Obj : in out Object_File;
+ Sym : String_Ptr_Len) return String;
+ -- Return the decoded name of a symbol encoded as per exp_dbug.ads
+
+ function Strip_Leading_Char
+ (Obj : in out Object_File;
+ Sym : String_Ptr_Len) return Positive;
+ -- Return the index of the first character to decode the name. This can
+ -- strip one character for ABI with a prefix (like x86 for PECOFF).
+
+ function Value (Sym : Object_Symbol) return uint64;
+ -- Return the name of the symbol
+
+ function Size (Sym : Object_Symbol) return uint64;
+ -- Return the size of the symbol in bytes
+
+ function Spans (Sym : Object_Symbol; Addr : uint64) return Boolean;
+ -- Determine whether a particular address corresponds to the range
+ -- referenced by this symbol.
+
+ function Off (Sym : Object_Symbol) return Offset;
+ -- Return the offset of the symbol.
+
+ ----------------
+ -- Exceptions --
+ ----------------
+
+ IO_Error : exception;
+ -- Input/Output error reading file
+
+ Format_Error : exception;
+ -- Encountered a problem parsing the object
+
+private
+ type Mapped_Stream is record
+ Region : System.Mmap.Mapped_Region;
+ Off : Offset;
+ Len : Offset;
+ end record;
+
+ subtype ELF is Object_Format range ELF32 .. ELF64;
+ subtype Any_PECOFF is Object_Format range PECOFF .. PECOFF_PLUS;
+
+ type Object_File (Format : Object_Format) is record
+ Mf : System.Mmap.Mapped_File :=
+ System.Mmap.Invalid_Mapped_File;
+ Arch : Object_Arch := Unknown;
+
+ Num_Sections : uint32 := 0;
+ -- Number of sections
+
+ Symtab_Last : Offset; -- Last offset of symbol table
+
+ In_Exception : Boolean := False;
+ -- True if the parsing is done as part of an exception handler
+
+ Sectab_Stream : Mapped_Stream;
+ -- Section table
+
+ Symtab_Stream : Mapped_Stream;
+ -- Symbol table
+
+ Symstr_Stream : Mapped_Stream;
+ -- Symbol strings
+
+ case Format is
+ when ELF =>
+ Secstr_Stream : Mapped_Stream;
+ -- Section strings
+ when Any_PECOFF =>
+ ImageBase : uint64; -- ImageBase value from header
+
+ -- Cache for latest result of Get_Section_Virtual_Address
+
+ GSVA_Sec : uint32 := uint32'Last;
+ GSVA_Addr : uint64;
+ when XCOFF32 =>
+ null;
+ end case;
+ end record;
+
+ subtype ELF_Object_File is Object_File; -- with
+ -- Predicate => ELF_Object_File.Format in ELF;
+ subtype PECOFF_Object_File is Object_File; -- with
+ -- Predicate => PECOFF_Object_File.Format in Any_PECOFF;
+ subtype XCOFF32_Object_File is Object_File; -- with
+ -- Predicate => XCOFF32_Object_File.Format in XCOFF32;
+ -- ???Above predicates cause the compiler to crash when instantiating
+ -- ELF64_Ops (see package body).
+
+ type Object_Section is record
+ Num : uint32 := 0;
+ -- Section index in the section table
+
+ Off : Offset := 0;
+ -- First byte of the section in the object file
+
+ Addr : uint64 := 0;
+ -- Load address of the section. Valid only when Flag_Alloc is true.
+
+ Size : uint64 := 0;
+ -- Length of the section in bytes
+
+ Flag_Alloc : Boolean := False;
+ -- True if the section is mapped in memory by the OS loader
+ end record;
+
+ Null_Section : constant Object_Section := (0, 0, 0, 0, False);
+
+ type Object_Symbol is record
+ Off : Offset := 0; -- Offset of underlying symbol on disk
+ Next : Offset := 0; -- Offset of the following symbol
+ Value : uint64 := 0; -- Value associated with this symbol
+ Size : uint64 := 0; -- Size of the referenced entity
+ end record;
+
+ Null_Symbol : constant Object_Symbol := (0, 0, 0, 0);
+end System.Object_Reader;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K . S Y M B O L I C --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2017, AdaCore --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Run-time symbolic traceback support for targets using DWARF debug data
+
+pragma Polling (Off);
+-- We must turn polling off for this unit, because otherwise we can get
+-- elaboration circularities when polling is turned on.
+
+with Ada.Unchecked_Deallocation;
+
+with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
+with Ada.Containers.Generic_Array_Sort;
+
+with System.Address_To_Access_Conversions;
+with System.Soft_Links;
+with System.CRTL;
+with System.Dwarf_Lines;
+with System.Exception_Traces;
+with System.Standard_Library;
+with System.Traceback_Entries;
+with System.Strings;
+with System.Bounded_Strings;
+
+package body System.Traceback.Symbolic is
+
+ use System.Bounded_Strings;
+ use System.Dwarf_Lines;
+
+ subtype Big_String is String (Positive);
+ -- To deal with C strings
+
+ package Big_String_Conv is new System.Address_To_Access_Conversions
+ (Big_String);
+
+ type Module_Cache;
+ type Module_Cache_Acc is access all Module_Cache;
+
+ type Module_Cache is record
+ Name : Strings.String_Access;
+ -- Name of the module
+
+ C : Dwarf_Context (In_Exception => True);
+ -- Context to symbolize an address within this module
+
+ Chain : Module_Cache_Acc;
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Module_Cache,
+ Module_Cache_Acc);
+
+ Cache_Chain : Module_Cache_Acc;
+ -- Simply linked list of modules
+
+ type Module_Array is array (Natural range <>) of Module_Cache_Acc;
+ type Module_Array_Acc is access Module_Array;
+
+ Modules_Cache : Module_Array_Acc;
+ -- Sorted array of cached modules (if not null)
+
+ Exec_Module : aliased Module_Cache;
+ -- Context for the executable
+
+ type Init_State is (Uninitialized, Initialized, Failed);
+ Exec_Module_State : Init_State := Uninitialized;
+ -- How Exec_Module is initialized
+
+ procedure Init_Exec_Module;
+ -- Initialize Exec_Module if not already initialized
+
+ function Symbolic_Traceback
+ (Traceback : System.Traceback_Entries.Tracebacks_Array;
+ Suppress_Hex : Boolean) return String;
+ function Symbolic_Traceback
+ (E : Ada.Exceptions.Exception_Occurrence;
+ Suppress_Hex : Boolean) return String;
+ -- Suppress_Hex means do not print any hexadecimal addresses, even if the
+ -- symbol is not available.
+
+ function Lt (Left, Right : Module_Cache_Acc) return Boolean;
+ -- Sort function for Module_Cache
+
+ procedure Init_Module
+ (Module : out Module_Cache;
+ Success : out Boolean;
+ Module_Name : String;
+ Load_Address : Address := Null_Address);
+ -- Initialize Module
+
+ procedure Close_Module (Module : in out Module_Cache);
+ -- Finalize Module
+
+ function Value (Item : System.Address) return String;
+ -- Return the String contained in Item, up until the first NUL character
+
+ pragma Warnings (Off, "*Add_Module_To_Cache*");
+ procedure Add_Module_To_Cache (Module_Name : String);
+ -- To be called by Build_Cache_For_All_Modules to add a new module to the
+ -- list. May not be referenced.
+
+ package Module_Name is
+
+ procedure Build_Cache_For_All_Modules;
+ -- Create the cache for all current modules
+
+ function Get (Addr : access System.Address) return String;
+ -- Returns the module name for the given address, Addr may be updated
+ -- to be set relative to a shared library. This depends on the platform.
+ -- Returns an empty string for the main executable.
+
+ function Is_Supported return Boolean;
+ pragma Inline (Is_Supported);
+ -- Returns True if Module_Name is supported, so if the traceback is
+ -- supported for shared libraries.
+
+ end Module_Name;
+
+ package body Module_Name is separate;
+
+ function Executable_Name return String;
+ -- Returns the executable name as reported by argv[0]. If gnat_argv not
+ -- initialized or if argv[0] executable not found in path, function returns
+ -- an empty string.
+
+ function Get_Executable_Load_Address return System.Address;
+ pragma Import
+ (C,
+ Get_Executable_Load_Address,
+ "__gnat_get_executable_load_address");
+ -- Get the load address of the executable, or Null_Address if not known
+
+ procedure Hexa_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Non-symbolic traceback (simply write addresses in hexa)
+
+ procedure Symbolic_Traceback_No_Lock
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Like the public Symbolic_Traceback_No_Lock except there is no provision
+ -- against concurrent accesses.
+
+ procedure Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Module : Module_Cache;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Returns the Traceback for a given module
+
+ procedure Multi_Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Build string containing symbolic traceback for the given call chain
+
+ procedure Multi_Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Module : Module_Cache;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Likewise but using Module
+
+ Max_String_Length : constant := 4096;
+ -- Arbitrary limit on Bounded_Str length
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value (Item : System.Address) return String is
+ begin
+ if Item /= Null_Address then
+ for J in Big_String'Range loop
+ if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then
+ return Big_String_Conv.To_Pointer (Item) (1 .. J - 1);
+ end if;
+ end loop;
+ end if;
+
+ return "";
+ end Value;
+
+ -------------------------
+ -- Add_Module_To_Cache --
+ -------------------------
+
+ procedure Add_Module_To_Cache (Module_Name : String) is
+ Module : Module_Cache_Acc;
+ Success : Boolean;
+ begin
+ Module := new Module_Cache;
+ Init_Module (Module.all, Success, Module_Name);
+ if not Success then
+ Free (Module);
+ return;
+ end if;
+ Module.Chain := Cache_Chain;
+ Cache_Chain := Module;
+ end Add_Module_To_Cache;
+
+ ----------------------
+ -- Init_Exec_Module --
+ ----------------------
+
+ procedure Init_Exec_Module is
+ begin
+ if Exec_Module_State = Uninitialized then
+ declare
+ Exec_Path : constant String := Executable_Name;
+ Exec_Load : constant Address := Get_Executable_Load_Address;
+ Success : Boolean;
+ begin
+ Init_Module (Exec_Module, Success, Exec_Path, Exec_Load);
+
+ if Success then
+ Exec_Module_State := Initialized;
+ else
+ Exec_Module_State := Failed;
+ end if;
+ end;
+ end if;
+ end Init_Exec_Module;
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (Left, Right : Module_Cache_Acc) return Boolean is
+ begin
+ return Low (Left.C) < Low (Right.C);
+ end Lt;
+
+ -----------------------------
+ -- Module_Cache_Array_Sort --
+ -----------------------------
+
+ procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort
+ (Natural,
+ Module_Cache_Acc,
+ Module_Array,
+ Lt);
+
+ ------------------
+ -- Enable_Cache --
+ ------------------
+
+ procedure Enable_Cache (Include_Modules : Boolean := False) is
+ begin
+ -- Can be called at most once
+ if Cache_Chain /= null then
+ return;
+ end if;
+
+ -- Add all modules
+ Init_Exec_Module;
+ Cache_Chain := Exec_Module'Access;
+
+ if Include_Modules then
+ Module_Name.Build_Cache_For_All_Modules;
+ end if;
+
+ -- Build and fill the array of modules
+ declare
+ Count : Natural;
+ Module : Module_Cache_Acc;
+ begin
+ for Phase in 1 .. 2 loop
+ Count := 0;
+ Module := Cache_Chain;
+ while Module /= null loop
+ Count := Count + 1;
+
+ if Phase = 1 then
+ Enable_Cache (Module.C);
+ else
+ Modules_Cache (Count) := Module;
+ end if;
+ Module := Module.Chain;
+ end loop;
+
+ if Phase = 1 then
+ Modules_Cache := new Module_Array (1 .. Count);
+ end if;
+ end loop;
+ end;
+
+ -- Sort the array
+ Module_Cache_Array_Sort (Modules_Cache.all);
+ end Enable_Cache;
+
+ ---------------------
+ -- Executable_Name --
+ ---------------------
+
+ function Executable_Name return String is
+ -- We have to import gnat_argv as an Address to match the type of
+ -- gnat_argv in the binder generated file. Otherwise, we get spurious
+ -- warnings about type mismatch when LTO is turned on.
+
+ Gnat_Argv : System.Address;
+ pragma Import (C, Gnat_Argv, "gnat_argv");
+
+ type Argv_Array is array (0 .. 0) of System.Address;
+ package Conv is new System.Address_To_Access_Conversions (Argv_Array);
+
+ function locate_exec_on_path (A : System.Address) return System.Address;
+ pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");
+
+ begin
+ if Gnat_Argv = Null_Address then
+ return "";
+ end if;
+
+ declare
+ Addr : constant System.Address :=
+ locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0));
+ Result : constant String := Value (Addr);
+
+ begin
+ -- The buffer returned by locate_exec_on_path was allocated using
+ -- malloc, so we should use free to release the memory.
+
+ if Addr /= Null_Address then
+ System.CRTL.free (Addr);
+ end if;
+
+ return Result;
+ end;
+ end Executable_Name;
+
+ ------------------
+ -- Close_Module --
+ ------------------
+
+ procedure Close_Module (Module : in out Module_Cache) is
+ begin
+ Close (Module.C);
+ Strings.Free (Module.Name);
+ end Close_Module;
+
+ -----------------
+ -- Init_Module --
+ -----------------
+
+ procedure Init_Module
+ (Module : out Module_Cache;
+ Success : out Boolean;
+ Module_Name : String;
+ Load_Address : Address := Null_Address)
+ is
+ begin
+ -- Early return if the module is not known
+
+ if Module_Name = "" then
+ Success := False;
+ return;
+ end if;
+
+ Open (Module_Name, Module.C, Success);
+
+ -- If a module can't be opened just return now, we just cannot give more
+ -- information in this case.
+
+ if not Success then
+ return;
+ end if;
+
+ Set_Load_Address (Module.C, Load_Address);
+
+ Module.Name := new String'(Module_Name);
+ end Init_Module;
+
+ -------------------------------
+ -- Module_Symbolic_Traceback --
+ -------------------------------
+
+ procedure Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Module : Module_Cache;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ Success : Boolean := False;
+ begin
+ if Symbolic.Module_Name.Is_Supported then
+ Append (Res, '[');
+ Append (Res, Module.Name.all);
+ Append (Res, ']' & ASCII.LF);
+ end if;
+
+ Dwarf_Lines.Symbolic_Traceback
+ (Module.C,
+ Traceback,
+ Suppress_Hex,
+ Success,
+ Res);
+
+ if not Success then
+ Hexa_Traceback (Traceback, Suppress_Hex, Res);
+ end if;
+
+ -- We must not allow an unhandled exception here, since this function
+ -- may be installed as a decorator for all automatic exceptions.
+
+ exception
+ when others =>
+ return;
+ end Module_Symbolic_Traceback;
+
+ -------------------------------------
+ -- Multi_Module_Symbolic_Traceback --
+ -------------------------------------
+
+ procedure Multi_Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ F : constant Natural := Traceback'First;
+ begin
+ if Traceback'Length = 0 or else Is_Full (Res) then
+ return;
+ end if;
+
+ if Modules_Cache /= null then
+ -- Search in the cache
+
+ declare
+ Addr : constant Address := Traceback (F);
+ Hi, Lo, Mid : Natural;
+ begin
+ Lo := Modules_Cache'First;
+ Hi := Modules_Cache'Last;
+ while Lo <= Hi loop
+ Mid := (Lo + Hi) / 2;
+ if Addr < Low (Modules_Cache (Mid).C) then
+ Hi := Mid - 1;
+ elsif Is_Inside (Modules_Cache (Mid).C, Addr) then
+ Multi_Module_Symbolic_Traceback
+ (Traceback,
+ Modules_Cache (Mid).all,
+ Suppress_Hex,
+ Res);
+ return;
+ else
+ Lo := Mid + 1;
+ end if;
+ end loop;
+
+ -- Not found
+ Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
+ Multi_Module_Symbolic_Traceback
+ (Traceback (F + 1 .. Traceback'Last),
+ Suppress_Hex,
+ Res);
+ end;
+ else
+
+ -- First try the executable
+ if Is_Inside (Exec_Module.C, Traceback (F)) then
+ Multi_Module_Symbolic_Traceback
+ (Traceback,
+ Exec_Module,
+ Suppress_Hex,
+ Res);
+ return;
+ end if;
+
+ -- Otherwise, try a shared library
+ declare
+ Addr : aliased System.Address := Traceback (F);
+ M_Name : constant String := Module_Name.Get (Addr'Access);
+ Module : Module_Cache;
+ Success : Boolean;
+ begin
+ Init_Module (Module, Success, M_Name, System.Null_Address);
+ if Success then
+ Multi_Module_Symbolic_Traceback
+ (Traceback,
+ Module,
+ Suppress_Hex,
+ Res);
+ Close_Module (Module);
+ else
+ -- Module not found
+ Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
+ Multi_Module_Symbolic_Traceback
+ (Traceback (F + 1 .. Traceback'Last),
+ Suppress_Hex,
+ Res);
+ end if;
+ end;
+ end if;
+ end Multi_Module_Symbolic_Traceback;
+
+ procedure Multi_Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Module : Module_Cache;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ Pos : Positive;
+ begin
+ -- Will symbolize the first address...
+
+ Pos := Traceback'First + 1;
+
+ -- ... and all addresses in the same module
+
+ Same_Module :
+ loop
+ exit Same_Module when Pos > Traceback'Last;
+
+ -- Get address to check for corresponding module name
+
+ exit Same_Module when not Is_Inside (Module.C, Traceback (Pos));
+
+ Pos := Pos + 1;
+ end loop Same_Module;
+
+ Module_Symbolic_Traceback
+ (Traceback (Traceback'First .. Pos - 1),
+ Module,
+ Suppress_Hex,
+ Res);
+ Multi_Module_Symbolic_Traceback
+ (Traceback (Pos .. Traceback'Last),
+ Suppress_Hex,
+ Res);
+ end Multi_Module_Symbolic_Traceback;
+
+ --------------------
+ -- Hexa_Traceback --
+ --------------------
+
+ procedure Hexa_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ use System.Traceback_Entries;
+ begin
+ if Suppress_Hex then
+ Append (Res, "...");
+ Append (Res, ASCII.LF);
+ else
+ for J in Traceback'Range loop
+ Append_Address (Res, PC_For (Traceback (J)));
+ Append (Res, ASCII.LF);
+ end loop;
+ end if;
+ end Hexa_Traceback;
+
+ --------------------------------
+ -- Symbolic_Traceback_No_Lock --
+ --------------------------------
+
+ procedure Symbolic_Traceback_No_Lock
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ begin
+ if Symbolic.Module_Name.Is_Supported then
+ Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res);
+ else
+ if Exec_Module_State = Failed then
+ Append (Res, "Call stack traceback locations:" & ASCII.LF);
+ Hexa_Traceback (Traceback, Suppress_Hex, Res);
+ else
+ Module_Symbolic_Traceback
+ (Traceback,
+ Exec_Module,
+ Suppress_Hex,
+ Res);
+ end if;
+ end if;
+ end Symbolic_Traceback_No_Lock;
+
+ ------------------------
+ -- Symbolic_Traceback --
+ ------------------------
+
+ function Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean) return String
+ is
+ Res : Bounded_String (Max_Length => Max_String_Length);
+ begin
+ System.Soft_Links.Lock_Task.all;
+ Init_Exec_Module;
+ Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res);
+ System.Soft_Links.Unlock_Task.all;
+
+ return To_String (Res);
+
+ exception
+ when others =>
+ System.Soft_Links.Unlock_Task.all;
+ raise;
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback
+ (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
+ begin
+ return Symbolic_Traceback (Traceback, Suppress_Hex => False);
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback_No_Hex
+ (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
+ begin
+ return Symbolic_Traceback (Traceback, Suppress_Hex => True);
+ end Symbolic_Traceback_No_Hex;
+
+ function Symbolic_Traceback
+ (E : Ada.Exceptions.Exception_Occurrence;
+ Suppress_Hex : Boolean) return String
+ is
+ begin
+ return Symbolic_Traceback
+ (Ada.Exceptions.Traceback.Tracebacks (E),
+ Suppress_Hex);
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback
+ (E : Ada.Exceptions.Exception_Occurrence) return String
+ is
+ begin
+ return Symbolic_Traceback (E, Suppress_Hex => False);
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback_No_Hex
+ (E : Ada.Exceptions.Exception_Occurrence) return String is
+ begin
+ return Symbolic_Traceback (E, Suppress_Hex => True);
+ end Symbolic_Traceback_No_Hex;
+
+ Exception_Tracebacks_Symbolic : Integer;
+ pragma Import
+ (C,
+ Exception_Tracebacks_Symbolic,
+ "__gl_exception_tracebacks_symbolic");
+ -- Boolean indicating whether symbolic tracebacks should be generated.
+
+ use Standard_Library;
+begin
+ -- If this version of this package is available, and the binder switch -Es
+ -- was given, then we want to use this as the decorator by default, and we
+ -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user
+ -- cannot have already set Exception_Trace, because the runtime library is
+ -- elaborated before user-defined code.
+
+ if Exception_Tracebacks_Symbolic /= 0 then
+ Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access);
+ pragma Assert (Exception_Trace = RM_Convention);
+ Exception_Trace := Unhandled_Raise_In_Main;
+ end if;
+end System.Traceback.Symbolic;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2012-2017, AdaCore --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the GNU/Linux specific version of this package
+with Interfaces.C; use Interfaces.C;
+
+with System.Address_Operations; use System.Address_Operations;
+
+separate (System.Traceback.Symbolic)
+
+package body Module_Name is
+
+ use System;
+
+ pragma Linker_Options ("-ldl");
+
+ function Is_Shared_Lib (Base : Address) return Boolean;
+ -- Returns True if a shared library
+
+ -- The principle is:
+
+ -- 1. We get information about the module containing the address.
+
+ -- 2. We check that the full pathname is pointing to a shared library.
+
+ -- 3. for shared libraries, we return the non relocated address (so
+ -- the absolute address in the shared library).
+
+ -- 4. we also return the full pathname of the module containing this
+ -- address.
+
+ -------------------
+ -- Is_Shared_Lib --
+ -------------------
+
+ function Is_Shared_Lib (Base : Address) return Boolean is
+ EI_NIDENT : constant := 16;
+ type u16 is mod 2 ** 16;
+
+ -- Just declare the needed header information, we just need to read the
+ -- type encoded in the second field.
+
+ type Elf32_Ehdr is record
+ e_ident : char_array (1 .. EI_NIDENT);
+ e_type : u16;
+ end record;
+
+ ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN
+
+ Header : Elf32_Ehdr;
+ pragma Import (Ada, Header);
+ -- Suppress initialization in Normalized_Scalars mode
+ for Header'Address use Base;
+
+ begin
+ return Header.e_type = ET_DYN;
+ exception
+ when others =>
+ return False;
+ end Is_Shared_Lib;
+
+ ---------------------------------
+ -- Build_Cache_For_All_Modules --
+ ---------------------------------
+
+ procedure Build_Cache_For_All_Modules is
+ type link_map;
+ type link_map_acc is access all link_map;
+ pragma Convention (C, link_map_acc);
+
+ type link_map is record
+ l_addr : Address;
+ -- Base address of the shared object
+
+ l_name : Address;
+ -- Null-terminated absolute file name
+
+ l_ld : Address;
+ -- Dynamic section
+
+ l_next, l_prev : link_map_acc;
+ -- Chain
+ end record;
+ pragma Convention (C, link_map);
+
+ type r_debug_type is record
+ r_version : Integer;
+ r_map : link_map_acc;
+ end record;
+ pragma Convention (C, r_debug_type);
+
+ r_debug : r_debug_type;
+ pragma Import (C, r_debug, "_r_debug");
+
+ lm : link_map_acc;
+ begin
+ lm := r_debug.r_map;
+ while lm /= null loop
+ if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then
+ -- Discard non-file (like the executable itself or the gate).
+ Add_Module_To_Cache (Value (lm.l_name));
+ end if;
+ lm := lm.l_next;
+ end loop;
+ end Build_Cache_For_All_Modules;
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (Addr : access System.Address) return String is
+
+ -- Dl_info record for Linux, used to get sym reloc offset
+
+ type Dl_info is record
+ dli_fname : System.Address;
+ dli_fbase : System.Address;
+ dli_sname : System.Address;
+ dli_saddr : System.Address;
+ end record;
+
+ function dladdr
+ (addr : System.Address;
+ info : not null access Dl_info) return int;
+ pragma Import (C, dladdr, "dladdr");
+ -- This is a Linux extension and not POSIX
+
+ info : aliased Dl_info;
+
+ begin
+ if dladdr (Addr.all, info'Access) /= 0 then
+
+ -- If we have a shared library we need to adjust the address to
+ -- be relative to the base address of the library.
+
+ if Is_Shared_Lib (info.dli_fbase) then
+ Addr.all := SubA (Addr.all, info.dli_fbase);
+ end if;
+
+ return Value (info.dli_fname);
+
+ -- Not found, fallback to executable name
+
+ else
+ return "";
+ end if;
+
+ exception
+ when others =>
+ return "";
+ end Get;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported return Boolean is
+ begin
+ return True;
+ end Is_Supported;
+
+end Module_Name;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2012-2017, AdaCore --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows specific version of this package
+
+with System.Win32; use System.Win32;
+
+separate (System.Traceback.Symbolic)
+
+package body Module_Name is
+
+ use System;
+
+ ---------------------------------
+ -- Build_Cache_For_All_Modules --
+ ---------------------------------
+
+ procedure Build_Cache_For_All_Modules is
+ begin
+ null;
+ end Build_Cache_For_All_Modules;
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (Addr : access System.Address) return String is
+ Res : DWORD;
+ hModule : aliased HANDLE;
+ Path : String (1 .. 1_024);
+
+ begin
+ if GetModuleHandleEx
+ (GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
+ Addr.all,
+ hModule'Access) = Win32.TRUE
+ then
+ Res := GetModuleFileName (hModule, Path'Address, Path'Length);
+
+ if FreeLibrary (hModule) = Win32.FALSE then
+ null;
+ end if;
+
+ if Res > 0 then
+ return Path (1 .. Positive (Res));
+ end if;
+ end if;
+
+ return "";
+
+ exception
+ when others =>
+ return "";
+ end Get;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported return Boolean is
+ begin
+ return True;
+ end Is_Supported;
+
+end Module_Name;
projects / gcc.git / commitdiff