Add mach-O binary file writer.

1 files changed, 345 insertions, 0 deletions

diff --git a/src/ortho/mcode/binary_file-macho.adb b/src/ortho/mcode/binary_file-macho.adb
new file mode 100644
index 0000000..dbfc882
--- /dev/null
+++ b/src/ortho/mcode/binary_file-macho.adb
@@ -0,0 +1,345 @@
+--  Binary file Mach-O writer.
+--  Copyright (C) 2015 Tristan Gingold
+--
+--  GHDL 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, or (at your option) any later
+--  version.
+--
+--  GHDL 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 GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+with Macho; use Macho;
+
+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_32_Array is array (Natural range <>) of Section_32;
+      Sects_Hdr : Section_32_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_32_Size
+        + Nbr_Sect * Section_32_Size
+        + Lc_Size + Symtab_Command_Size;
+      File_Offset := Header_32_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_32_Size;
+      Strtab_Offset := File_Offset;
+
+      --  Write file header.
+      declare
+         Hdr : Header_32;
+      begin
+         Hdr := (Magic => Magic,
+                 Cputype => Cputype_I386,
+                 Cpusubtype => Cpusubtype_I386_All,
+                 Filetype => Mh_Object,
+                 Ncmds => 2,
+                 Sizeofcmds => Unsigned_32 (Sizeof_Cmds),
+                 Flags => 0);
+         Xwrite (Hdr'Address, Header_32_Size);
+      end;
+
+      --  Write segment and section commands.
+      declare
+         Lc : Load_Command;
+         Seg : Segment_Command_32;
+      begin
+         Lc := (Cmd => Lc_Segment_32,
+                Cmdsize => Unsigned_32 (Lc_Size + Segment_Command_32_Size
+                                          + Nbr_Sect * Section_32_Size));
+         Xwrite (Lc'Address, Lc_Size);
+         Seg := (Segname => (others => ASCII.NUL),
+                 Vmaddr => 0,
+                 Vmsize => 0, --  FIXME
+                 Fileoff => Unsigned_32 (Seg_Offset),
+                 Filesize => Unsigned_32 (Symtab_Offset - Seg_Offset),
+                 Maxprot => 7, --  rwx
+                 Initprot => 7,
+                 Nsects => Unsigned_32 (Nbr_Sect),
+                 Flags => 0);
+         Xwrite (Seg'Address, Segment_Command_32_Size);
+      end;
+
+      --  Write section headers.
+      for I in 1 .. Nbr_Sect loop
+         Sect := Sects_Info (I).Sect;
+         declare
+            Hdr : Section_32 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 := Unsigned_32 (Sect.Vaddr);
+            Hdr.Size := Unsigned_32 (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_32_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_32;
+         begin
+            Sym := (N_Strx => Unsigned_32 (Str_Offset),
+                    N_Type => 0,
+                    N_Sect => 0,
+                    N_Desc => 0,
+                    N_Value => Unsigned_32 (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 + Unsigned_32 (Get_Section (S).Vaddr);
+            end if;
+            Xwrite (Sym'Address, Nlist_32_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;