path: root/src/ortho/mcode/binary_file-macho.adb

--  Binary file Mach-O writer.
--  Copyright (C) 2015 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 Macho; use Macho;
with Macho_Arch64; use Macho_Arch64;

package body Binary_File.Macho is
   procedure Write (Fd : GNAT.OS_Lib.File_Descriptor)
   is
      use GNAT.OS_Lib;

      --  If true, discard local symbols;
      Flag_Discard_Local : Boolean := True;

      procedure Xwrite (Data : System.Address; Len : Natural) is
      begin
         if Write (Fd, Data, Len) /= Len then
            raise Write_Error;
         end if;
      end Xwrite;

      function Symbol_Discarded (S : Symbol) return Boolean is
      begin
         case Get_Scope (S) is
            when Sym_Local =>
               if Flag_Discard_Local then
                  return True;
               end if;
            when Sym_Private =>
               null;
            when Sym_Global =>
               null;
            when Sym_Undef =>
               if not Get_Used (S) then
                  return True;
               end if;
         end case;
         return False;
      end Symbol_Discarded;

      procedure Fill_Name (Dest : out String; Src : String)
      is
         subtype D_Type is String (1 .. Dest'Length);
         D : D_Type renames Dest;
         subtype S_Type is String (1 .. Src'Length);
         S : S_Type renames Src;
      begin
         if S'Length < D'Length then
            D (1 .. S'Length) := S;
            D (S'Length + 1 .. D'Last) := (others => ASCII.NUL);
         else
            D := S (1 .. D'Last);
         end if;
      end Fill_Name;

      type Section_Info_Type is record
         Sect : Section_Acc;
         --  Index of the section symbol (in symtab).
      end record;
      type Section_Info_Array is array (Natural range <>) of Section_Info_Type;
      Sects_Info : Section_Info_Array (1 .. Nbr_Sections);
      type Section_Array is array (Natural range <>) of Section;
      Sects_Hdr : Section_Array (1 .. Nbr_Sections);
      Nbr_Sect : Natural;
      Sect : Section_Acc;

      --  Various offsets.
      File_Offset : Natural;
      Seg_Offset : Natural;
      Symtab_Offset : Natural;
      Strtab_Offset : Natural;
      Sizeof_Cmds : Natural;

      --  Number of symtab entries.
      Nbr_Symbols : Natural;

      Str_Size : Natural;

      --  If true, do local relocs.
      Flag_Reloc : constant Boolean := True;
   begin
      --  If relocations are not performs, then local symbols cannot be
      --  discarded.
      if not Flag_Reloc then
         Flag_Discard_Local := False;
      end if;

      --  Count sections.
      Sect := Section_Chain;
      Nbr_Sect := 0;
      while Sect /= null loop
         Nbr_Sect := Nbr_Sect + 1;
         Sects_Info (Nbr_Sect).Sect := Sect;
         Sect.Number := Nbr_Sect;
         Sect := Sect.Next;
      end loop;

      --  Set sections offset.
      Sizeof_Cmds := Lc_Size + Segment_Command_Size
        + Nbr_Sect * Section_Size
        + Lc_Size + Symtab_Command_Size;
      File_Offset := Header_Size + Sizeof_Cmds;
      Seg_Offset := File_Offset;
      for I in 1 .. Nbr_Sect loop
         Sect := Sects_Info (I).Sect;
         if Sect.Data /= null then
            --  FIXME: alignment ?
            Sects_Hdr (I).Offset := Unsigned_32 (File_Offset);
            File_Offset := File_Offset + Natural (Sect.Pc);
         else
            Sects_Hdr (I).Offset := 0;
         end if;
      end loop;

      --  Relocs
      --  FIXME: todo.

      Symtab_Offset := File_Offset;
      Str_Size := 0;
      Nbr_Symbols := 0;
      for I in Symbols.First .. Symbols.Last loop
         if not Symbol_Discarded (I) then
            Nbr_Symbols := Nbr_Symbols + 1;
            Set_Number (I, Nbr_Symbols);
            Str_Size := Str_Size + Get_Symbol_Name_Length (I) + 1;
         else
            Set_Number (I, 0);
         end if;
      end loop;

      File_Offset := File_Offset + Nbr_Symbols * Nlist_Size;
      Strtab_Offset := File_Offset;

      --  Write file header.
      declare
         Hdr : Header;
         Cputype : Unsigned_32;
      begin
         case Arch is
            when Arch_X86 =>
               Cputype := Cputype_I386;
            when Arch_X86_64 =>
               Cputype := Cputype_I386 + Cpu_Arch_64;
            when others =>
               raise Program_Error;
         end case;
         Hdr := (Magic => Magic,
                 Cputype => Cputype,
                 Cpusubtype => Cpusubtype_I386_All,
                 Filetype => Mh_Object,
                 Ncmds => 2,
                 Sizeofcmds => Unsigned_32 (Sizeof_Cmds),
                 others => 0);
         Xwrite (Hdr'Address, Header_Size);
      end;

      --  Write segment and section commands.
      declare
         Lc : Load_Command;
         Seg : Segment_Command;
      begin
         Lc := (Cmd => Lc_Segment,
                Cmdsize => Unsigned_32 (Lc_Size + Segment_Command_Size
                                          + Nbr_Sect * Section_Size));
         Xwrite (Lc'Address, Lc_Size);
         Seg := (Segname => (others => ASCII.NUL),
                 Vmaddr => 0,
                 Vmsize => 0, --  FIXME
                 Fileoff => Addr_T (Seg_Offset),
                 Filesize => Addr_T (Symtab_Offset - Seg_Offset),
                 Maxprot => 7, --  rwx
                 Initprot => 7,
                 Nsects => Unsigned_32 (Nbr_Sect),
                 Flags => 0);
         Xwrite (Seg'Address, Segment_Command_Size);
      end;

      --  Write section headers.
      for I in 1 .. Nbr_Sect loop
         Sect := Sects_Info (I).Sect;
         declare
            Hdr : Section renames Sects_Hdr (I);
            Secname_Raw : constant String := Sect.Name.all;
            subtype S_Type is String (1 .. Secname_Raw'Length);
            Secname : S_Type renames Secname_Raw;
         begin
            if Secname = ".text" then
               Fill_Name (Hdr.Sectname, "__text");
               Fill_Name (Hdr.Segname, "__TEXT");
            elsif Secname = ".rodata" then
               Fill_Name (Hdr.Sectname, "__const");
               Fill_Name (Hdr.Segname, "__TEXT");
            elsif (Sect.Flags and Section_Debug) /= 0 then
               if Secname'Length > 7
                 and then Secname (1 .. 7) = ".debug_"
               then
                  Fill_Name (Hdr.Sectname,
                             "__debug_" & Secname (8 .. Secname'Last));
               else
                  Fill_Name (Hdr.Sectname, Sect.Name.all);
               end if;
               Fill_Name (Hdr.Segname, "__DWARF");
            else
               Fill_Name (Hdr.Sectname, Secname);
               Fill_Name (Hdr.Segname, "");
            end if;
            Hdr.Addr := Addr_T (Sect.Vaddr);
            Hdr.Size := Addr_T (Sect.Pc);
            Hdr.Align := Unsigned_32 (Sect.Align);
            Hdr.Reloff := 0;
            Hdr.Nreloc := 0;
            Hdr.Flags := 0;
            Hdr.Reserved1 := 0;
            Hdr.Reserved2 := 0;
            Xwrite (Hdr'Address, Section_Size);
         end;
      end loop;

      --  Write symtab command
      declare
         Lc : Load_Command;
         Symtab : Symtab_Command;
      begin
         Lc := (Cmd => Lc_Symtab,
                Cmdsize => Unsigned_32 (Lc_Size + Symtab_Command_Size));
         Xwrite (Lc'Address, Lc_Size);
         Symtab := (Symoff => Unsigned_32 (Symtab_Offset),
                    Nsyms => Unsigned_32 (Nbr_Symbols),
                    Stroff => Unsigned_32 (Strtab_Offset),
                    Strsize => Unsigned_32 (Str_Size));
         Xwrite (Symtab'Address, Symtab_Command_Size);
      end;

      --  Write sections content.
      for I in 1 .. Nbr_Sect loop
         Sect := Sects_Info (I).Sect;
         if Sect.Data /= null then
            Xwrite (Sect.Data (0)'Address, Natural (Sect.Pc));
         end if;
      end loop;

      --  FIXME: write relocs.

      --   Write symbols.
      declare
         Str_Offset : Natural;

         generic
            with procedure Handle (S : Symbol);
         procedure Foreach_Symbol;

         procedure Foreach_Symbol is
         begin
            --  First, the local and private symbols.
            for I in Symbols.First .. Symbols.Last loop
               case Get_Scope (I) is
                  when Sym_Local =>
                     if not Flag_Discard_Local then
                        Handle (I);
                     end if;
                  when Sym_Private =>
                     Handle (I);
                  when Sym_Global
                    | Sym_Undef =>
                     null;
               end case;
            end loop;

            --  Then global symbols
            for I in Symbols.First .. Symbols.Last loop
               case Get_Scope (I) is
                  when Sym_Local
                    | Sym_Private =>
                     null;
                  when Sym_Global =>
                     Handle (I);
                  when Sym_Undef =>
                     null;
               end case;
            end loop;
            --  Then undef symbols.
            for I in Symbols.First .. Symbols.Last loop
               case Get_Scope (I) is
                  when Sym_Local
                    | Sym_Private =>
                     null;
                  when Sym_Global =>
                     null;
                  when Sym_Undef =>
                     if Get_Used (I) then
                        Handle (I);
                     end if;
               end case;
            end loop;
         end Foreach_Symbol;

         procedure Write_Symbol (S : Symbol)
         is
            Sym : Nlist;
         begin
            Sym := (N_Strx => Unsigned_32 (Str_Offset),
                    N_Type => 0,
                    N_Sect => 0,
                    N_Desc => 0,
                    N_Value => Addr_T (Get_Symbol_Value (S)));
            Str_Offset := Str_Offset + Get_Symbol_Name_Length (S) + 1;
            if Get_Scope (S) = Sym_Undef then
               Sym.N_Type := N_Undf;
            else
               if Get_Scope (S) = Sym_Global then
                  Sym.N_Type := N_Sect + N_Ext;
               else
                  Sym.N_Type := N_Sect;
               end if;
               Sym.N_Sect := Unsigned_8 (Get_Section (S).Number);
               Sym.N_Value := Sym.N_Value + Addr_T (Get_Section (S).Vaddr);
            end if;
            Xwrite (Sym'Address, Nlist_Size);
         end Write_Symbol;

         procedure Write_String (Sym : Symbol)
         is
            Str : constant String := Get_Symbol_Name (Sym) & ASCII.NUL;
         begin
            Xwrite (Str'Address, Str'Length);
         end Write_String;

         procedure Write_All_Symbols is new
           Foreach_Symbol (Write_Symbol);
         procedure Write_All_Strings is new
           Foreach_Symbol (Write_String);
      begin
         Str_Offset := 0;

         Write_All_Symbols;
         Write_All_Strings;
      end;
   end Write;

end Binary_File.Macho;