Added first real target; works for Hellos with Put's

src/apps/hac.adb

@@ -82,6 +82,7 @@ procedure HAC is
     BD.Set_Remark_Set (remarks);
     BD.Set_Main_Source_Stream (Text_Streams.Stream (f), Ada_file_name, shebang_offset);
     BD.Set_Message_Feedbacks (trace);
+    BD.Set_Target (target);
     BD.LD.Set_Source_Access
       (Exists_Source'Access,
        Open_Source'Access,
@@ -105,7 +106,9 @@ procedure HAC is
       return;
     end if;
     if verbosity >= 2 then
-      Put_Line (HAC_margin_2 & "Target: " & BD.CD.target.Name);
+      Put_Line (HAC_margin_2 & "Target . : " & BD.CD.target.Name);
+      Put_Line (HAC_margin_2 & "CPU  . . : " & BD.CD.target.CPU);
+      Put_Line (HAC_margin_2 & "OS . . . : " & BD.CD.target.OS);
       --
       if BD.CD.target.Is_HAC_VM then
         Put_Line
@@ -245,6 +248,19 @@ procedure HAC is
             help_level := 2;
           end if;
           quit := True;
+        when 't' =>
+          if opt'Length = 1 then
+            Argument_Error ("Missing target");
+          else
+            declare
+              new_target_name : constant String := opt (opt'First + 1 .. opt'Last);
+            begin
+              Set_Target (new_target_name);
+            exception
+              when Constraint_Error =>
+                Argument_Error ("Unknown target " & new_target_name);
+            end;
+          end if;
         when 'w' =>
           if opt'Length = 1 then
             Argument_Error ("Missing warning / note switch");

src/apps/hac_pkg.adb

@@ -1,4 +1,5 @@
-with HAC_Sys.Librarian;
+with HAC_Sys.Librarian,
+     HAC_Sys.Targets.AMD64_Windows_Console_FASM;
 
 with Show_MIT_License;
 
@@ -128,6 +129,7 @@ package body HAC_Pkg is
     PLCE ("         -h, h1 : this help");
     PLCE ("         -h2    : show more help about options");
     PLCE ("         -I     : specify source files search path (hac -h2 for details)");
+    PLCE ("         -tx    : target machine (default: HAC VM; hac -h2 for details)");
     PLCE ("         -v, v1 : verbose");
     PLCE ("         -v2    : very verbose");
     PLCE ("         -wx    : enable / disable warnings or notes (hac -h2 for details)");
@@ -150,6 +152,10 @@ package body HAC_Pkg is
       PLCE ("    3) Each of the directories listed in the value of the ADA_INCLUDE_PATH");
       PLCE ("         environment variable.");
       NLCE;
+      PLCE ("Option -tx : set target machine to x");
+      PLCE ("             x =");
+      PLCE ("                 amd64_windows_console_fasm");
+      NLCE;
       PLCE ("Option -wx : enable warnings or notes of kind x");
       PLCE ("       -wX : disable warnings or notes of kind x");
       PLCE ("             x =");
@@ -160,4 +166,14 @@ package body HAC_Pkg is
     Ada.Text_IO.Skip_Line;
   end Help;
 
+  procedure Set_Target (name : String) is
+    type Target_List is
+      (amd64_windows_console_fasm);
+  begin
+    case Target_List'Value (name) is
+      when amd64_windows_console_fasm =>
+        target := new HAC_Sys.Targets.AMD64_Windows_Console_FASM.Machine;
+    end case;
+  end Set_Target;
+
 end HAC_Pkg;

src/apps/hac_pkg.ads

@@ -1,7 +1,9 @@
 --  This package contains call-backs for the
 --  HAC command-line application, as well as various helpers.
 
-with HAC_Sys.Co_Defs;
+with HAC_Sys.Co_Defs,
+     HAC_Sys.Targets;
+
 with HAT;
 
 package HAC_Pkg is
@@ -17,6 +19,8 @@ package HAC_Pkg is
 
   command_line_source_path, main_Ada_file_name : HAT.VString;
 
+  target : HAC_Sys.Targets.Abstract_Machine_Reference := null;
+
   procedure Compilation_Feedback (message : String);
 
   function Exists_Source (simple_file_name : String) return Boolean;
@@ -31,4 +35,6 @@ package HAC_Pkg is
 
   procedure Help (level : Positive);
 
+  procedure Set_Target (name : String);
+
 end HAC_Pkg;

src/compile/emit/hac_sys-targets-amd64_windows_console_fasm.adb

@@ -0,0 +1,136 @@
+package body HAC_Sys.Targets.AMD64_Windows_Console_FASM is
+
+  use Defs, HAT;
+
+  asm_name : constant String := "hac_generated.asm";
+
+  procedure Instruction
+    (m        : Machine;
+     instr    : String;
+     operands : String)
+  is
+  begin
+    Put_Line
+      (m.asm_file, "         " & instr & (20 - instr'Length) * ' ' & operands);
+  end Instruction;
+
+  overriding procedure Initialize_Code_Emission (m : in out Machine) is
+  begin
+    Create (m.asm_file, asm_name);
+    Put_Line (m.asm_file, "format PE64 console");
+    Put_Line (m.asm_file, "entry _start");
+    Put_Line (m.asm_file, "include 'include\win64a.inc'");
+    New_Line (m.asm_file);
+    Put_Line (m.asm_file, "section '.code' code readable executable");
+    New_Line (m.asm_file);
+    Put_Line (m.asm_file, "_start:");
+  end Initialize_Code_Emission;
+
+  overriding procedure Finalize_Code_Emission
+    (m       : in out Machine;
+     strings :        String)
+  is
+    procedure Dump_Strings is
+      printable : Boolean := True;
+      col : Integer;
+      function Needs_New_Line return Boolean is (col mod 60 = 10);
+      procedure Separate_with_Comma is
+      begin
+        if col > strings'First then
+          Put (m.asm_file, ", ");
+        end if;
+        if Needs_New_Line then
+          Put_Line (m.asm_file, "\ ");
+          Put (m.asm_file, "    ");
+        end if;
+      end Separate_with_Comma;
+    begin
+      Put (m.asm_file, "_hac_strings_pool db ""X");
+      for i in strings'Range loop
+        col := i;
+        if Character'Pos (strings (i)) in 32 .. 127 then
+          if printable then
+            if Needs_New_Line then
+              Put_Line (m.asm_file, """, \");
+              Put (m.asm_file, "    """);
+            end if;
+          else
+            Separate_with_Comma;
+            Put (m.asm_file, '"');
+            printable := True;
+          end if;
+          Put (m.asm_file, strings (i));
+        else
+          if printable then
+            Put (m.asm_file, '"');
+            printable := False;
+          end if;
+          Separate_with_Comma;
+          Put (m.asm_file, Character'Pos (strings (i)), 0);
+        end if;
+      end loop;
+      if printable then
+        Put (m.asm_file, '"');
+      end if;
+      New_Line (m.asm_file);
+    end Dump_Strings;
+  begin
+    if strings'Length > 0 then
+      Put_Line (m.asm_file, "section '.data' data readable writeable");
+      Dump_Strings;
+      New_Line (m.asm_file);
+    end if;
+    Put_Line (m.asm_file, "section '.idata' import data readable");
+    Put_Line (m.asm_file, "library kernel,'kernel32.dll',\");
+    Put_Line (m.asm_file, "        msvcrt,'msvcrt.dll'");
+    Put_Line (m.asm_file, "import  kernel,\");
+    Put_Line (m.asm_file, "        ExitProcess,'ExitProcess'");
+    Put_Line (m.asm_file, "import  msvcrt,\");
+    Put_Line (m.asm_file, "        printf,'printf'");
+    Close (m.asm_file);
+  end Finalize_Code_Emission;
+
+  overriding procedure Emit_Halt (m : in out Machine) is
+  begin
+    Instruction (m, "stdcall", "[ExitProcess],0");
+    New_Line (m.asm_file);
+  end Emit_Halt;
+
+  overriding procedure Emit_Push_Discrete_Literal
+    (m : in out Machine; x : Defs.HAC_Integer) is
+  begin
+    Instruction (m, "pushq", HAC_Image (x));
+  end Emit_Push_Discrete_Literal;
+
+  overriding procedure Emit_Push_Discrete_Literals
+    (m : in out Machine; x, y : Defs.HAC_Integer) is
+  begin
+    Instruction (m, "pushq", HAC_Image (x));
+    Instruction (m, "pushq", HAC_Image (y));
+  end Emit_Push_Discrete_Literals;
+
+  overriding procedure Emit_HAT_Builtin_Procedure
+    (m            : in out Machine;
+     builtin_proc :        Defs.SP_Code;
+     parameter    :        Defs.HAC_Integer)
+  is
+  begin
+    case builtin_proc is
+      when SP_Put =>
+        case Defs.Typen'Val (parameter) is
+          when String_Literals =>
+            Instruction (m, "pop", "r13");
+            Instruction (m, "pop", "r12");
+            Instruction (m, "pop", "r11");
+            Instruction (m, "pop", "r10");
+            Instruction (m, "add", "r11, _hac_strings_pool");
+            Instruction (m, "ccall", "[printf], r11");
+          when others =>
+            raise combination_not_supported;
+        end case;
+      when others =>
+        raise combination_not_supported;
+    end case;
+  end Emit_HAT_Builtin_Procedure;
+
+end HAC_Sys.Targets.AMD64_Windows_Console_FASM;

src/compile/emit/hac_sys-targets-amd64_windows_console_fasm.ads

@@ -0,0 +1,59 @@
+-------------------------------------------------------------------------------------
+--
+--  HAC - HAC Ada Compiler
+--
+--  A compiler in Ada for an Ada subset
+--
+--  Copyright, license, etc. : see top package.
+--
+-------------------------------------------------------------------------------------
+
+with HAT;
+
+package HAC_Sys.Targets.AMD64_Windows_Console_FASM is
+
+  type Machine is limited new Abstract_Machine with record
+    asm_file : HAT.File_Type;
+  end record;
+
+  --------------------
+  --  Informations  --
+  --------------------
+
+  overriding function Name (m : Machine) return String is ("Windows 64 Console");
+  overriding function Is_HAC_VM (m : Machine) return Boolean is (False);
+  overriding function CPU (m : Machine) return String is ("AMD64");
+  overriding function OS (m : Machine) return String is ("Windows");
+  overriding function Null_Terminated_String_Literals (m : Machine) return Boolean is (True);
+
+  -------------------------------------------
+  --  Initialize & Finalize Code Emission  --
+  -------------------------------------------
+
+  overriding procedure Initialize_Code_Emission (m : in out Machine);
+  overriding procedure Finalize_Code_Emission
+    (m       : in out Machine;
+     strings :        String);
+
+  ----------------------------
+  --  Machine Instructions  --
+  ----------------------------
+
+  overriding procedure Emit_Halt (m : in out Machine);
+
+  overriding procedure Emit_Push_Discrete_Literal
+    (m : in out Machine; x : Defs.HAC_Integer);
+
+  overriding procedure Emit_Push_Discrete_Literals
+    (m : in out Machine; x, y : Defs.HAC_Integer);
+
+  ----------------------------
+  --  Built-In Subprograms  --
+  ----------------------------
+
+  overriding procedure Emit_HAT_Builtin_Procedure
+    (m            : in out Machine;
+     builtin_proc :        Defs.SP_Code;
+     parameter    :        Defs.HAC_Integer);
+
+end HAC_Sys.Targets.AMD64_Windows_Console_FASM;

src/compile/emit/hac_sys-targets-hac_virtual_machine.adb

@@ -5,8 +5,27 @@ package body HAC_Sys.Targets.HAC_Virtual_Machine is
 
   use Compiler.PCode_Emit, PCode;
 
+  overriding procedure Emit_Halt (m : in out Machine) is
+  begin
+    Emit (m.CD.all, k_Halt_Interpreter);
+  end Emit_Halt;
+
+  overriding procedure Emit_Push_Discrete_Literal
+    (m : in out Machine; x : Defs.HAC_Integer)
+  is
+  begin
+    Emit_1 (m.CD.all, k_Push_Discrete_Literal, x);
+  end Emit_Push_Discrete_Literal;
+
+  overriding procedure Emit_Push_Discrete_Literals
+    (m : in out Machine; x, y : Defs.HAC_Integer)
+  is
+  begin
+    Emit_2 (m.CD.all, k_Push_Two_Discrete_Literals, x, y);
+  end Emit_Push_Discrete_Literals;
+
   overriding procedure Emit_HAT_Builtin_Procedure
-    (m            : in out HAC_VM;
+    (m            : in out Machine;
      builtin_proc :        Defs.SP_Code;
      parameter    :        Defs.HAC_Integer)
   is

src/compile/emit/hac_sys-targets-hac_virtual_machine.ads

@@ -14,17 +14,40 @@ with HAC_Sys.Co_Defs;
 
 package HAC_Sys.Targets.HAC_Virtual_Machine is
 
-  type HAC_VM is new Abstract_Machine with record
+  type Machine is new Abstract_Machine with record
     CD : Co_Defs.Compiler_Data_Access;
     --  ^ In the future the instruction table and other items
     --    will be stored here and we can remove CD.
   end record;
 
-  overriding function Name (m : HAC_VM) return String is ("HAC Virtual Machine");
-  overriding function Is_HAC_VM (m : HAC_VM) return Boolean is (True);
+  --------------------
+  --  Informations  --
+  --------------------
+
+  overriding function Name (m : Machine) return String is ("HAC Virtual Machine");
+  overriding function Is_HAC_VM (m : Machine) return Boolean is (True);
+  overriding function CPU (m : Machine) return String is ("HAC VM");
+  overriding function OS (m : Machine) return String is ("Any");
+  overriding function Null_Terminated_String_Literals (m : Machine) return Boolean is (False);
+
+  ----------------------------
+  --  Machine Instructions  --
+  ----------------------------
+
+  overriding procedure Emit_Halt (m : in out Machine);
+
+  overriding procedure Emit_Push_Discrete_Literal
+    (m : in out Machine; x : Defs.HAC_Integer);
+
+  overriding procedure Emit_Push_Discrete_Literals
+    (m : in out Machine; x, y : Defs.HAC_Integer);
+
+  ----------------------------
+  --  Built-In Subprograms  --
+  ----------------------------
 
   overriding procedure Emit_HAT_Builtin_Procedure
-    (m            : in out HAC_VM;
+    (m            : in out Machine;
      builtin_proc :        Defs.SP_Code;
      parameter    :        Defs.HAC_Integer);