mcode code generator added

1 files changed, 203 insertions, 0 deletions

diff --git a/ortho/mcode/ortho_code_main.adb b/ortho/mcode/ortho_code_main.adb
new file mode 100644
index 0000000..7744b88
--- /dev/null
+++ b/ortho/mcode/ortho_code_main.adb
@@ -0,0 +1,203 @@
+--  Mcode back-end for ortho - Main subprogram.
+--  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.Unchecked_Conversion;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Unchecked_Deallocation;
+with Ada.Text_IO; use Ada.Text_IO;
+with Binary_File; use Binary_File;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ortho_Code.Debug;
+with Ortho_Mcode; use Ortho_Mcode;
+with Ortho_Front; use Ortho_Front;
+with Ortho_Code.Flags; use Ortho_Code.Flags;
+with Binary_File;
+with Binary_File.Elf;
+with Binary_File.Coff;
+with Binary_File.Memory;
+with Interfaces;
+
+procedure Ortho_Code_Main
+is
+   Output : String_Acc := null;
+   type Format_Type is (Format_Coff, Format_Elf);
+   Format : Format_Type := Format_Elf;
+   Fd : File_Descriptor;
+
+   First_File : Natural;
+   Opt : String_Acc;
+   Opt_Arg : String_Acc;
+   Filename : String_Acc;
+   Exec_Func : String_Acc;
+   Res : Natural;
+   I : Natural;
+   Argc : Natural;
+   procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+     (Name => String_Acc, Object => String);
+begin
+   First_File := Natural'Last;
+   Exec_Func := null;
+
+   Ortho_Front.Init;
+
+   Argc := Argument_Count;
+   I := 1;
+   while I <= Argc loop
+      declare
+         Arg : String := Argument (I);
+      begin
+         if Arg (1) = '-' then
+            if Arg'Length > 5 and then Arg (1 .. 5) = "--be-" then
+               Ortho_Code.Debug.Set_Be_Flag (Arg);
+               I := I + 1;
+            elsif Arg = "-o" then
+               if I = Argc then
+                  Put_Line (Standard_Error, "error: missing filename to '-o'");
+                  return;
+               end if;
+               Output := new String'(Argument (I + 1));
+               I := I + 2;
+            elsif Arg = "-quiet" then
+               --  Skip silently.
+               I := I + 1;
+            elsif Arg = "--exec" then
+               if I = Argc then
+                  Put_Line (Standard_Error,
+                            "error: missing function name to '--exec'");
+                  return;
+               end if;
+               Exec_Func := new String'(Argument (I + 1));
+               I := I + 2;
+            elsif Arg = "-g" then
+               Flag_Debug := Debug_Dwarf;
+               I := I + 1;
+            elsif Arg = "-p" or Arg = "-pg" then
+               Flag_Profile := True;
+               I := I + 1;
+            else
+               --  This is really an argument.
+               Opt := new String'(Arg);
+               if I < Argument_Count then
+                  Opt_Arg := new String'(Argument (I + 1));
+               else
+                  Opt_Arg := null;
+               end if;
+               Res := Ortho_Front.Decode_Option (Opt, Opt_Arg);
+               case Res is
+                  when 0 =>
+                     Put_Line (Standard_Error, "unknown option '" & Arg & "'");
+                     return;
+                  when 1 =>
+                     I := I + 1;
+                  when 2 =>
+                     I := I + 2;
+                  when others =>
+                     raise Program_Error;
+               end case;
+               Unchecked_Deallocation (Opt);
+               Unchecked_Deallocation (Opt_Arg);
+            end if;
+         else
+            First_File := I;
+            exit;
+         end if;
+      end;
+   end loop;
+
+   Ortho_Mcode.Init;
+
+   Set_Exit_Status (Failure);
+
+   if First_File > Argument_Count then
+      begin
+         if not Parse (null) then
+            return;
+         end if;
+      exception
+         when others =>
+            return;
+      end;
+   else
+      for I in First_File .. Argument_Count loop
+         Filename := new String'(Argument (First_File));
+         begin
+            if not Parse (Filename) then
+               return;
+            end if;
+         exception
+            when others =>
+               return;
+         end;
+      end loop;
+   end if;
+
+   Ortho_Mcode.Finish;
+
+   if Ortho_Code.Debug.Flag_Debug_Hli then
+      Set_Exit_Status (Success);
+      return;
+   end if;
+
+   if Output /= null then
+      Fd := Create_File (Output.all, Binary);
+      if Fd /= Invalid_FD then
+         case Format is
+            when Format_Elf =>
+               Binary_File.Elf.Write_Elf (Fd);
+            when Format_Coff =>
+               Binary_File.Coff.Write_Coff (Fd);
+         end case;
+         Close (Fd);
+      end if;
+   elsif Exec_Func /= null then
+      declare
+         use Binary_File;
+         use Interfaces;
+         use Ada.Text_IO;
+         Sym : Symbol;
+
+         type Func_Acc is access function return Integer;
+         function Conv is new Ada.Unchecked_Conversion
+           (Source => Unsigned_32, Target => Func_Acc);
+         F : Func_Acc;
+         V : Integer;
+         Err : Boolean;
+      begin
+         Binary_File.Memory.Write_Memory_Init;
+         Binary_File.Memory.Write_Memory_Relocate (Err);
+         if Err then
+            return;
+         end if;
+         Sym := Binary_File.Get_Symbol (Exec_Func.all);
+         if Sym = Null_Symbol then
+            Put_Line (Standard_Error, "no '" & Exec_Func.all & "' symbol");
+         else
+            F := Conv (Get_Symbol_Vaddr (Sym));
+            V := F.all;
+            Put_Line ("Result is " & Integer'Image (V));
+         end if;
+      end;
+   end if;
+
+   Set_Exit_Status (Success);
+exception
+   when others =>
+      Set_Exit_Status (2);
+      raise;
+end Ortho_Code_Main;
+
+