path: root/src/ortho/mcode/coffdump.adb

--  COFF dumper.
--  Copyright (C) 2006 Tristan Gingold
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation, either version 2 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program.  If not, see <gnu.org/licenses>.
with Coff; use Coff;
with Interfaces; use Interfaces;
with System;
with Ada.Unchecked_Conversion;
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Ada.Text_IO; use Ada.Text_IO;
with Hex_Images; use Hex_Images;

procedure Coffdump is
   type Cstring is array (Unsigned_32 range <>) of Character;
   type Cstring_Acc is access Cstring;
   type Section_Array is array (Unsigned_16 range <>) of Scnhdr;
   type Section_Array_Acc is access Section_Array;
   --  Array of sections.
   Sections : Section_Array_Acc;

   type External_Symbol is array (0 .. Symesz - 1) of Character;
   type External_Symbol_Array is array (Unsigned_32 range <>)
     of External_Symbol;
   type Symbol_Array_Acc is access External_Symbol_Array;
   --  Symbols table.
   External_Symbols : Symbol_Array_Acc;

   --  String table.
   Str : Cstring_Acc;
   Str_Size : Natural;

   Hdr : Filehdr;
   --Sym : Syment;
   Fd : File_Descriptor;
   Skip : Natural;
   Skip_Kind : Unsigned_8;
   Aux_File : Auxent_File;
   Aux_Scn : Auxent_Scn;
   Rel : Reloc;
   Len : Natural;

   Nul : constant Character := Character'Val (0);

   function Find_Nul (S : String) return String is
   begin
      for I in S'Range loop
         if S (I) = Nul then
            return S (S'First .. I - 1);
         end if;
      end loop;
      return S;
   end Find_Nul;

   function Get_String (N : Strent_Type; S : String) return String
   is
   begin
      if N.E_Zeroes /= 0 then
         return Find_Nul (S);
      else
         for I in N.E_Offset .. Str'Last loop
            if Str (I) = Nul then
               return String (Str (N.E_Offset .. I - 1));
            end if;
         end loop;
         raise Program_Error;
      end if;
   end Get_String;

   procedure Memcpy
     (Dst : System.Address; Src : System.Address; Size : Natural);
   pragma Import (C, Memcpy);

   function Get_Section_Name (N : Unsigned_16) return String is
   begin
      if N = N_UNDEF then
         return "UNDEF";
      elsif N = N_ABS then
         return "ABS";
      elsif N = N_DEBUG then
         return "DEBUG";
      elsif N > Hdr.F_Nscns then
         return "???";
      else
         return Find_Nul (Sections (N).S_Name);
      end if;
   end Get_Section_Name;

   function Get_Symbol (N : Unsigned_32) return Syment is
      function Unchecked_Conv is new Ada.Unchecked_Conversion
        (Source => External_Symbol, Target => Syment);
   begin
      if N > Hdr.F_Nsyms then
         raise Constraint_Error;
      end if;
      return Unchecked_Conv (External_Symbols (N));
   end Get_Symbol;

   function Get_Symbol_Name (N : Unsigned_32) return String
   is
      S : Syment := Get_Symbol (N);
   begin
      return Get_String (S.E.E, S.E.E_Name);
   end Get_Symbol_Name;
begin
   for I in 1 .. Argument_Count loop
      Fd := Open_Read (Argument (I), Binary);
      if Fd = Invalid_FD then
         Put_Line ("cannot open " & Argument (I));
         return;
      end if;
      --  Read file header.
      if Read (Fd, Hdr'Address, Filehdr_Size) /= Filehdr_Size then
         Put_Line ("cannot read header");
         return;
      end if;
      Put_Line ("File: " & Argument (I));
      Put_Line ("magic:               " & Hex_Image (Hdr.F_Magic));
      Put_Line ("number of sections:  " & Hex_Image (Hdr.F_Nscns));
      Put_Line ("time and date stamp: " & Hex_Image (Hdr.F_Timdat));
      Put_Line ("symtab file pointer: " & Hex_Image (Hdr.F_Symptr));
      Put_Line ("nbr symtab entries:  " & Hex_Image (Hdr.F_Nsyms));
      Put_Line ("opt header size:     " & Hex_Image (Hdr.F_Opthdr));
      Put_Line ("flags:               " & Hex_Image (Hdr.F_Flags));

      --  Read sections header.
      Lseek (Fd, Long_Integer (Hdr.F_Opthdr), Seek_Cur);
      Sections := new Section_Array (1 .. Hdr.F_Nscns);
      Len := Scnhdr_Size * Natural (Hdr.F_Nscns);
      if Read (Fd, Sections (1)'Address, Len) /= Len then
         Put_Line ("cannot read section header");
         return;
      end if;
      for I in 1 .. Hdr.F_Nscns loop
         declare
            S: Scnhdr renames Sections (I);
         begin
            Put_Line ("Section " & Find_Nul (S.S_Name));
            Put_Line ("Physical address :     " & Hex_Image (S.S_Paddr));
            Put_Line ("Virtual address :      " & Hex_Image (S.S_Vaddr));
            Put_Line ("section size :         " & Hex_Image (S.S_Size));
            Put_Line ("section pointer :      " & Hex_Image (S.S_Scnptr));
            Put_Line ("relocation pointer :   " & Hex_Image (S.S_Relptr));
            Put_Line ("line num pointer :     " & Hex_Image (S.S_Lnnoptr));
            Put_Line ("Nbr reloc entries :    " & Hex_Image (S.S_Nreloc));
            Put_Line ("Nbr line num entries : " & Hex_Image (S.S_Nlnno));
            Put_Line ("Flags :                " & Hex_Image (S.S_Flags));
         end;
      end loop;

      --  Read string table.
      Lseek (Fd,
             Long_Integer (Hdr.F_Symptr + Hdr.F_Nsyms * Unsigned_32 (Symesz)),
             Seek_Set);
      if Read (Fd, Str_Size'Address, 4) /= 4 then
         Put_Line ("cannot read string table size");
         return;
      end if;
      Str := new Cstring (0 .. Unsigned_32 (Str_Size));
      if Read (Fd, Str (4)'Address, Str_Size - 4) /= Str_Size - 4 then
         Put_Line ("cannot read string table");
         return;
      end if;

      --  Read symbol table.
      Lseek (Fd, Long_Integer (Hdr.F_Symptr), Seek_Set);
      External_Symbols := new External_Symbol_Array (0 .. Hdr.F_Nsyms - 1);
      Len := Natural (Hdr.F_Nsyms) * Symesz;
      if Read (Fd, External_Symbols (0)'Address, Len) /= Len then
            Put_Line ("cannot read symbol");
            return;
         end if;

      Skip := 0;
      Skip_Kind := C_NULL;
      for I in External_Symbols'range loop
         if Skip > 0 then
            case Skip_Kind is
               when C_FILE =>
                  Memcpy (Aux_File'Address, External_Symbols (I)'Address,
                          Aux_File'Size / 8);
                  Put_Line ("aux file : " & Get_String (Aux_File.X_N,
                                                        Aux_File.X_Fname));
                  Skip_Kind := C_NULL;
               when C_STAT =>
                  Memcpy (Aux_Scn'Address, External_Symbols (I)'Address,
                          Aux_Scn'Size / 8);
                  Put_Line ("section len:   " & Hex_Image (Aux_Scn.X_Scnlen));
                  Put_Line ("nbr reloc ent: " & Hex_Image (Aux_Scn.X_Nreloc));
                  Put_Line ("nbr line num:  " & Hex_Image (Aux_Scn.X_Nlinno));
               when others =>
                  Put_Line ("skip");
            end case;
            Skip := Skip - 1;
         else
            declare
               S : Syment := Get_Symbol (I);
            begin
               Put_Line ("Symbol #" & Hex_Image (I));
               Put_Line ("symbol name : " & Get_Symbol_Name (I));
               Put_Line ("symbol value: " & Hex_Image (S.E_Value));
               Put_Line ("section num : " & Hex_Image (S.E_Scnum)
                         & "  " & Get_Section_Name (S.E_Scnum));
               Put_Line ("type        : " & Hex_Image (S.E_Type));
               Put      ("sclass      : " & Hex_Image (S.E_Sclass));
               if Sclass_Desc (S.E_Sclass).Name /= null then
                  Put ("  (");
                  Put (Sclass_Desc (S.E_Sclass).Name.all);
                  Put (" - ");
                  Put (Sclass_Desc (S.E_Sclass).Meaning.all);
                  Put (")");
               end if;
               New_Line;
               Put_Line ("numaux      : " & Hex_Image (S.E_Numaux));
               if S.E_Numaux > 0 then
                  case S.E_Sclass is
                     when C_FILE =>
                        Skip_Kind := C_FILE;
                     when C_STAT =>
                        Skip_Kind := C_STAT;
                     when others =>
                        Skip_Kind := C_NULL;
                  end case;
               end if;
               Skip := Natural (S.E_Numaux);
            end;
         end if;
      end loop;

      --  Disp relocs.
      for I in 1 .. Hdr.F_Nscns loop
         if Sections (I).S_Nreloc > 0 then
            --  Read relocations.
            Put_Line ("Relocations for section " & Get_Section_Name (I));
            Lseek (Fd, Long_Integer (Sections (I).S_Relptr), Seek_Set);
            for J in 1 .. Sections (I).S_Nreloc loop
               if Read (Fd, Rel'Address, Relsz) /= Relsz then
                  Put_Line ("cannot read reloc");
                  return;
               end if;
               Put_Line ("reloc virtual addr: " & Hex_Image (Rel.R_Vaddr));
               Put_Line ("symbol index      : " & Hex_Image (Rel.R_Symndx)
                         & "  " & Get_Symbol_Name (Rel.R_Symndx));
               Put ("type of relocation: " & Hex_Image (Rel.R_Type));
               case Rel.R_Type is
                  when Reloc_Rel32 =>
                     Put (" RELOC_REL32");
                  when Reloc_Addr32 =>
                     Put (" RELOC_ADDR32");
                  when others =>
                     null;
               end case;
               New_Line;
            end loop;
         end if;
      end loop;

      Close (Fd);
   end loop;
end Coffdump;