Move sources to src/ subdirectory.

1 files changed, 407 insertions, 0 deletions

diff --git a/src/ortho/mcode/binary_file-coff.adb b/src/ortho/mcode/binary_file-coff.adb
new file mode 100644
index 000000000..cf3cba3f4
--- /dev/null
+++ b/src/ortho/mcode/binary_file-coff.adb
@@ -0,0 +1,407 @@
+--  Binary file COFF writer.
+--  Copyright (C) 2006 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 Ada.Characters.Latin_1;
+with Coff; use Coff;
+
+package body Binary_File.Coff is
+   NUL : Character renames Ada.Characters.Latin_1.NUL;
+
+   procedure Write_Coff (Fd : GNAT.OS_Lib.File_Descriptor)
+   is
+      use GNAT.OS_Lib;
+
+      procedure Xwrite (Data : System.Address; Len : Natural) is
+      begin
+         if Write (Fd, Data, Len) /= Len then
+            raise Write_Error;
+         end if;
+      end Xwrite;
+
+      type Section_Info_Type is record
+         Sect : Section_Acc;
+         --  File offset for the data.
+         Data_Offset : Natural;
+         --  File offset for the relocs.
+         Reloc_Offset : Natural;
+         --  Number of relocs to write.
+         Nbr_Relocs : Natural;
+      end record;
+      type Section_Info_Array is array (Natural range <>) of Section_Info_Type;
+      Sections : Section_Info_Array (1 .. Nbr_Sections + 3);
+      Nbr_Sect : Natural;
+      Sect_Text : constant Natural := 1;
+      Sect_Data : constant Natural := 2;
+      Sect_Bss : constant Natural := 3;
+      Sect : Section_Acc;
+
+      --Section_Align : constant Natural := 2;
+
+      Offset : Natural;
+      Symtab_Offset : Natural;
+      --  Number of symtab entries.
+      Nbr_Symbols : Natural;
+      Strtab_Offset : Natural;
+
+      function Gen_String (Str : String) return Sym_Name
+      is
+         Res : Sym_Name;
+      begin
+         if Str'Length <= 8 then
+            Res.E_Name := (others => NUL);
+            Res.E_Name (1 .. Str'Length) := Str;
+         else
+            Res.E := (E_Zeroes => 0, E_Offset => Unsigned_32 (Offset));
+            Offset := Offset + Str'Length + 1;
+         end if;
+         return Res;
+      end Gen_String;
+
+      --  Well known sections name.
+      type String_Array is array (Sect_Text .. Sect_Bss) of String (1 .. 8);
+      Sect_Name : constant String_Array :=
+        (Sect_Text => ".text" & NUL & NUL & NUL,
+         Sect_Data => ".data" & NUL & NUL & NUL,
+         Sect_Bss => ".bss" & NUL & NUL & NUL & NUL);
+      type Unsigned32_Array is array (Sect_Text .. Sect_Bss) of Unsigned_32;
+      Sect_Flags : constant Unsigned32_Array :=
+        (Sect_Text => STYP_TEXT,
+         Sect_Data => STYP_DATA,
+         Sect_Bss => STYP_BSS);
+
+      --  If true, do local relocs.
+      Flag_Reloc : constant Boolean := True;
+      --  If true, discard local symbols;
+      Flag_Discard_Local : 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;
+
+      --  Fill sections.
+      Sect := Section_Chain;
+      Nbr_Sect := 3;
+      declare
+         N : Natural;
+      begin
+         while Sect /= null loop
+            if Sect.Name.all = ".text" then
+               N := Sect_Text;
+            elsif Sect.Name.all = ".data" then
+               N := Sect_Data;
+            elsif Sect.Name.all = ".bss" then
+               N := Sect_Bss;
+            else
+               Nbr_Sect := Nbr_Sect + 1;
+               N := Nbr_Sect;
+            end if;
+            Sections (N).Sect := Sect;
+            Sect.Number := N;
+            Sect := Sect.Next;
+         end loop;
+      end;
+
+      --  Set data offset.
+      Offset := Filehdr_Size + Nbr_Sect * Scnhdr_Size;
+      for I in 1 .. Nbr_Sect loop
+         if Sections (I).Sect /= null
+           and then Sections (I).Sect.Data /= null
+         then
+            Sections (I).Data_Offset := Offset;
+            Offset := Offset + Natural (Sections (I).Sect.Pc);
+         else
+            Sections (I).Data_Offset := 0;
+         end if;
+      end loop;
+
+      --  Set relocs offset.
+      declare
+         Rel : Reloc_Acc;
+      begin
+         for I in 1 .. Nbr_Sect loop
+            Sections (I).Nbr_Relocs := 0;
+            if Sections (I).Sect /= null then
+               Sections (I).Reloc_Offset := Offset;
+               if not Flag_Reloc then
+                  --  Do local relocations.
+                  Rel := Sections (I).Sect.First_Reloc;
+                  while Rel /= null loop
+                     if S_Local (Rel.Sym) then
+                        if Get_Section (Rel.Sym) = Sections (I).Sect
+                        then
+                           --  Intra section local reloc.
+                           Apply_Reloc (Sections (I).Sect, Rel);
+                        else
+                           --  Inter section local reloc.
+                           --  A relocation is still required.
+                           Sections (I).Nbr_Relocs :=
+                             Sections (I).Nbr_Relocs + 1;
+                           --  FIXME: todo.
+                           raise Program_Error;
+                        end if;
+                     else
+                        Sections (I).Nbr_Relocs := Sections (I).Nbr_Relocs + 1;
+                     end if;
+                     Rel := Rel.Sect_Next;
+                  end loop;
+               else
+                  Sections (I).Nbr_Relocs := Sections (I).Sect.Nbr_Relocs;
+               end if;
+               Offset := Offset + Sections (I).Nbr_Relocs * Relsz;
+            else
+               Sections (I).Reloc_Offset := 0;
+            end if;
+         end loop;
+      end;
+
+      Symtab_Offset := Offset;
+      Nbr_Symbols := 2 + Nbr_Sect * 2; --  2 for file.
+      for I in Symbols.First .. Symbols.Last loop
+         Set_Number (I, Nbr_Symbols);
+         Nbr_Symbols := Nbr_Symbols + 1;
+      end loop;
+      Offset := Offset + Nbr_Symbols * Symesz;
+      Strtab_Offset := Offset;
+      Offset := Offset + 4;
+
+      --  Write file header.
+      declare
+         Hdr : Filehdr;
+      begin
+         Hdr.F_Magic := I386magic;
+         Hdr.F_Nscns := Unsigned_16 (Nbr_Sect);
+         Hdr.F_Timdat := 0;
+         Hdr.F_Symptr := Unsigned_32 (Symtab_Offset);
+         Hdr.F_Nsyms := Unsigned_32 (Nbr_Symbols);
+         Hdr.F_Opthdr := 0;
+         Hdr.F_Flags := F_Lnno;
+         Xwrite (Hdr'Address, Filehdr_Size);
+      end;
+
+      --  Write sections header.
+      for I in 1 .. Nbr_Sect loop
+         declare
+            Hdr : Scnhdr;
+            L : Natural;
+         begin
+            case I is
+               when Sect_Text
+                 | Sect_Data
+                 | Sect_Bss =>
+                  Hdr.S_Name := Sect_Name (I);
+                  Hdr.S_Flags := Sect_Flags (I);
+               when others =>
+                  Hdr.S_Flags := 0;
+                  L := Sections (I).Sect.Name'Length;
+                  if L > Hdr.S_Name'Length then
+                     Hdr.S_Name := Sections (I).Sect.Name
+                       (Sections (I).Sect.Name'First ..
+                        Sections (I).Sect.Name'First + Hdr.S_Name'Length - 1);
+                  else
+                     Hdr.S_Name (1 .. L) := Sections (I).Sect.Name.all;
+                     Hdr.S_Name (L + 1 .. Hdr.S_Name'Last) := (others => NUL);
+                  end if;
+            end case;
+            Hdr.S_Paddr := 0;
+            Hdr.S_Vaddr := 0;
+            Hdr.S_Scnptr := Unsigned_32 (Sections (I).Data_Offset);
+            Hdr.S_Relptr := Unsigned_32 (Sections (I).Reloc_Offset);
+            Hdr.S_Lnnoptr := 0;
+            Hdr.S_Nreloc := Unsigned_16 (Sections (I).Nbr_Relocs);
+            if Sections (I).Sect /= null then
+               Hdr.S_Size := Unsigned_32 (Sections (I).Sect.Pc);
+            else
+               Hdr.S_Size := 0;
+            end if;
+            Hdr.S_Nlnno := 0;
+            Xwrite (Hdr'Address, Scnhdr_Size);
+         end;
+      end loop;
+
+      --  Write sections content.
+      for I in 1 .. Nbr_Sect loop
+         if Sections (I).Sect /= null
+           and then Sections (I).Sect.Data /= null
+         then
+            Xwrite (Sections (I).Sect.Data (0)'Address,
+                    Natural (Sections (I).Sect.Pc));
+         end if;
+      end loop;
+
+      --  Write sections reloc.
+      for I in 1 .. Nbr_Sect loop
+         if Sections (I).Sect /= null then
+            declare
+               R : Reloc_Acc;
+               Rel : Reloc;
+            begin
+               R := Sections (I).Sect.First_Reloc;
+               while R /= null loop
+                  case R.Kind is
+                     when Reloc_32 =>
+                        Rel.R_Type := Reloc_Addr32;
+                     when Reloc_Pc32 =>
+                        Rel.R_Type := Reloc_Rel32;
+                     when others =>
+                        raise Program_Error;
+                  end case;
+                  Rel.R_Vaddr := Unsigned_32 (R.Addr);
+                  Rel.R_Symndx := Unsigned_32 (Get_Number (R.Sym));
+                  Xwrite (Rel'Address, Relsz);
+                  R := R.Sect_Next;
+               end loop;
+            end;
+         end if;
+      end loop;
+
+      --  Write symtab.
+      --   Write file symbol + aux
+      declare
+         Sym : Syment;
+         A_File : Auxent_File;
+      begin
+         Sym := (E => (Inline => True,
+                       E_Name => ".file" & NUL & NUL & NUL),
+                 E_Value => 0,
+                 E_Scnum => N_DEBUG,
+                 E_Type => 0,
+                 E_Sclass => C_FILE,
+                 E_Numaux => 1);
+         Xwrite (Sym'Address, Symesz);
+         A_File := (Inline => True,
+                    X_Fname => "testfile.xxxxx");
+         Xwrite (A_File'Address, Symesz);
+      end;
+      --   Write sections symbol + aux
+      for I in 1 .. Nbr_Sect loop
+         declare
+            A_Scn : Auxent_Scn;
+            Sym : Syment;
+         begin
+            Sym := (E => (Inline => True, E_Name => (others => NUL)),
+                    E_Value => 0,
+                    E_Scnum => Unsigned_16 (I),
+                    E_Type => 0,
+                    E_Sclass => C_STAT,
+                    E_Numaux => 1);
+            if I <= Sect_Bss then
+               Sym.E.E_Name := Sect_Name (I);
+            else
+               Sym.E := Gen_String (Sections (I).Sect.Name.all);
+            end if;
+            Xwrite (Sym'Address, Symesz);
+            if Sections (I).Sect /= null
+              and then Sections (I).Sect.Data /= null
+            then
+               A_Scn :=
+                 (X_Scnlen => Unsigned_32 (Sections (I).Sect.Pc),
+                  X_Nreloc => Unsigned_16 (Sections (I).Nbr_Relocs),
+                  X_Nlinno => 0);
+            else
+               A_Scn := (X_Scnlen => 0, X_Nreloc => 0, X_Nlinno => 0);
+            end if;
+            Xwrite (A_Scn'Address, Symesz);
+         end;
+      end loop;
+
+      --   Write symbols.
+      declare
+         procedure Write_Symbol (S : Symbol)
+         is
+            Sym : Syment;
+         begin
+            Sym := (E => Gen_String (Get_Symbol_Name (S)),
+                    E_Value => Unsigned_32 (Get_Symbol_Value (S)),
+                    E_Scnum => 0,
+                    E_Type => 0,
+                    E_Sclass => C_EXT,
+                    E_Numaux => 0);
+            case Get_Scope (S) is
+               when Sym_Local
+                 | Sym_Private =>
+                  Sym.E_Sclass := C_STAT;
+               when Sym_Undef
+                 | Sym_Global =>
+                  Sym.E_Sclass := C_EXT;
+            end case;
+            if Get_Section (S) /= null then
+               Sym.E_Scnum := Unsigned_16 (Get_Section (S).Number);
+            end if;
+            Xwrite (Sym'Address, Symesz);
+         end Write_Symbol;
+      begin
+         --  First the non-local symbols (1).
+         for I in Symbols.First .. Symbols.Last loop
+            if Get_Scope (I) in Symbol_Scope_External then
+               Write_Symbol (I);
+            end if;
+         end loop;
+         --  Then the local symbols (2).
+         if not Flag_Discard_Local then
+            for I in Symbols.First .. Symbols.Last loop
+               if Get_Scope (I) not in Symbol_Scope_External then
+                  Write_Symbol (I);
+               end if;
+            end loop;
+         end if;
+      end;
+
+      --  Write strtab.
+      --    Write strtab length.
+      declare
+         L : Unsigned_32;
+
+         procedure Write_String (Str : String) is
+         begin
+            if Str (Str'Last) /= NUL then
+               raise Program_Error;
+            end if;
+            if Str'Length <= 9 then
+               return;
+            end if;
+            Xwrite (Str'Address, Str'Length);
+            Strtab_Offset := Strtab_Offset + Str'Length;
+         end Write_String;
+      begin
+         L := Unsigned_32 (Offset - Strtab_Offset);
+         Xwrite (L'Address, 4);
+
+         --  Write section name string.
+         for I in Sect_Bss + 1 .. Nbr_Sect loop
+            if Sections (I).Sect /= null
+              and then Sections (I).Sect.Name'Length > 8
+            then
+               Write_String (Sections (I).Sect.Name.all & NUL);
+            end if;
+         end loop;
+
+         for I in Symbols.First .. Symbols.Last loop
+            declare
+               Str : constant String := Get_Symbol_Name (I);
+            begin
+               Write_String (Str & NUL);
+            end;
+         end loop;
+         if Strtab_Offset + 4 /= Offset then
+            raise Program_Error;
+         end if;
+      end;
+   end Write_Coff;
+
+end Binary_File.Coff;