Driver

1 files changed, 209 insertions, 35 deletions

diff --git a/driver.fun b/driver.fun
index 19adcaa..ebb3dfd 100644
--- a/driver.fun
+++ b/driver.fun
@@ -2,33 +2,95 @@ functor Driver(E: EMIT): DRIVER = struct
   structure I = E.I
   structure P = E.I.P
 
-  datatype execMode = Normal | DebugE | DebugT
+  datatype execMode = EmAsm | EmObj | EmExe
 
   type config = {
     file: string option,
+    outFile: string option,
     includeDirs: string list,
-    mode: execMode
+    libDir: string option,
+    mode: execMode,
+    verbose: bool,
+    debugParser: bool,
+    debugIl: bool,
+    debugEmit: bool
   }
 
+  fun mod2int m =
+    case m of
+      EmAsm => 0
+    | EmObj => 1
+    | EmExe => 2
+
+  fun modCmp (m1, m2) = compare (mod2int m1) (mod2int m2)
+
   val updateC = fn z =>
   let
-    fun from file includeDirs mode = { file, includeDirs, mode }
-    fun to f { file, includeDirs, mode } = f file includeDirs mode
+    fun from file outFile includeDirs libDir mode verbose
+      debugParser debugIl debugEmit =
+      { file, outFile, includeDirs, libDir, mode, verbose,
+        debugParser, debugIl, debugEmit }
+    fun to f { file, outFile, includeDirs, libDir, mode, verbose,
+      debugParser, debugIl, debugEmit  }
+    =
+      f file outFile includeDirs libDir mode verbose
+        debugParser debugIl debugEmit
   in
-    FRU.makeUpdate3 (from, from, to)
+    FRU.makeUpdate9 (from, from, to)
   end z
 
-  val initConfig: config = { file = NONE, includeDirs = [], mode = Normal }
+  val initConfig: config = { file = NONE, outFile = NONE,
+  includeDirs = [], libDir = NONE, mode = EmExe,
+    verbose = false,
+    debugParser = false, debugIl = false, debugEmit = false }
 
   val die = fn z => die 1 z
 
   fun finish ({ file = NONE, ... }: config) = die `"No file specified" %
-    | finish conf = updateC conf u#includeDirs rev %
+    | finish conf =
+    let
+      val conf = updateC conf u#includeDirs rev %
+    in
+      case #outFile conf of
+        NONE =>
+        let
+          val sfx =
+            case #mode conf of
+              EmAsm => ".s"
+            | EmObj => ".o"
+            | EmExe => ""
+        in
+          updateC conf s#outFile (SOME (valOf (#file conf) ^ sfx)) %
+        end
+      | SOME _ => conf
+    end
 
-  fun parseFlag conf "-dE" tail =
-    parseCmdArgs (updateC conf s#mode DebugE %) tail
-    | parseFlag conf "-dT" tail =
-        parseCmdArgs (updateC conf s#mode DebugT %) tail
+  fun parseFlag conf "-v" tail =
+        parseCmdArgs (updateC conf s#verbose true %) tail
+    | parseFlag conf "-dp" tail =
+        parseCmdArgs (updateC conf s#debugParser true %) tail
+    | parseFlag conf "-di" tail =
+        parseCmdArgs (updateC conf s#debugIl true %) tail
+    | parseFlag conf "-de" tail =
+        parseCmdArgs (updateC conf s#debugEmit true %) tail
+    | parseFlag conf "-c" tail =
+        parseCmdArgs (updateC conf s#mode EmObj %) tail
+    | parseFlag conf "-S" tail =
+        parseCmdArgs (updateC conf s#mode EmAsm %) tail
+    | parseFlag _ "-o" [] =
+        die `"-o: expected file name after argument" %
+    | parseFlag (C as { outFile, ... }) "-o" (file :: tail) = (
+        case outFile of
+          NONE => parseCmdArgs (updateC C s#outFile (SOME file) %) tail
+       | SOME _ => die `file `": output file name is already specified" %
+    )
+    | parseFlag _ "-L" [] =
+        die `"-L: expected directory name after argument" %
+    | parseFlag (C as { libDir, ... }) "-L" ((dir: string) :: tail) = (
+        case libDir of
+          NONE => parseCmdArgs (updateC C s#libDir (SOME dir) %) tail
+       | SOME _ => die `dir `": libdir name is already specified" %
+    )
     | parseFlag _ arg _ = die `arg `": unknown flag" %
 
   and parseCmdArgs conf [] = finish conf
@@ -57,34 +119,146 @@ functor Driver(E: EMIT): DRIVER = struct
             end
         | SOME _ => die `arg `": file already specified" %
 
-  fun exec () =
+  fun callProgram verbose name args clean =
   let
-    val config = parseCmdArgs initConfig (CommandLine.arguments ())
-    val file = valOf $ #file config
+    open Posix.Process
+    fun exec () =
+    let
+      val args = name :: args
+      fun ps s out = Printf out `s %
+      val () =
+        if verbose then
+          printfn Plist ps args (" ", false, 0) %
+        else
+          ()
+    in
+      execp (name, args);
+      die `"canot exec " `name `": exec failed" %
+    end
   in
-    case (#mode config) of
-      Normal =>
+    case fork () of
+      NONE => exec ()
+    | SOME _ =>
         let
-          val parseCtx = P.createCtx file (#includeDirs config) true
-
-          fun collect ctx =
-          let
-            val (continue, ctx) = P.parseDef ctx
-          in
-            if continue then
-              collect ctx
-            else
-              P.finalize ctx
-          end
-
-          val parseCtx = collect parseCtx
-          val progInfo = P.explode parseCtx
-          val ilCtx = I.createCtx progInfo (SOME $ file ^ ".i")
+          val (_, status) = wait ()
         in
-          E.emit (file ^ ".s") ilCtx (SOME $ file ^ ".e")
+          case status of
+            W_EXITED => clean ()
+          | W_EXITSTATUS st =>
+              die `name `": failed with " W (Word8.toLargeWord st) `"code" %
+          | _ => raise Unimplemented
         end
-    | DebugT => P.P.T.debugPrint file
-    | DebugE => P.P.debugPrint file (#includeDirs config)
   end
-end
 
+  fun linkArgs _ _ NONE = die `"libdir: is not specified" %
+    | linkArgs input output (SOME d) =
+    let
+      open OS
+      val crt = Path.joinDirFile { dir = d, file = "crt1.o" }
+      val libc = Path.joinDirFile { dir = d, file =  "libc.a" }
+    in
+      ["-o", output, input, crt, libc]
+    end
+
+  fun assemble { mode, outFile, verbose, ... } asmFile =
+  let
+    val outputFile =
+      case mode of
+        EmObj => valOf outFile
+      | _ => String.substring (asmFile, 0, size asmFile - 2) ^ ".o"
+
+    val args = ["-f", "elf64", "-o", outputFile, asmFile]
+    val clean =
+      fn () =>
+        let
+          val () = if verbose then printfn `"removing " `asmFile % else ()
+        in
+          Posix.FileSys.unlink asmFile
+        end
+  in
+    callProgram verbose "nasm" args clean;
+    outputFile
+  end
+
+  fun link { libDir, outFile, verbose, ... } objFile =
+  let
+    val args = linkArgs objFile (valOf outFile) libDir
+    val clean =
+      fn () =>
+        let
+          val () = if verbose then printfn `"removing " `objFile % else ()
+        in
+          Posix.FileSys.unlink objFile
+        end
+  in
+    callProgram verbose "ld" args clean
+  end
+
+  fun parse { file, includeDirs, debugParser, ... } =
+  let
+    val file = valOf file
+    val debugFile = if debugParser then SOME (file ^ ".p") else NONE
+    val parseCtx = P.createCtx file includeDirs debugFile
+
+    fun collect ctx =
+    let
+      val (continue, ctx) = P.parseDef ctx
+    in
+      if continue then
+        collect ctx
+      else
+        P.finalize ctx
+    end
+  in
+    collect parseCtx
+  end
+
+  fun ilConv parseCtx config =
+  let
+    val debugFile =
+      if #debugIl config then
+        SOME (valOf (#file config) ^ ".i")
+      else
+        NONE
+    val progInfo = P.explode parseCtx
+  in
+    I.createCtx progInfo debugFile
+  end
+
+  fun emit ilCtx { debugEmit, file, outFile, mode, ... }=
+  let
+    val debugFile =
+      if debugEmit then
+        SOME (valOf file ^ ".e")
+      else
+        NONE
+    val out =
+      case mode of
+        EmAsm => valOf $ outFile
+      | _ => OS.FileSys.tmpName () ^ ".s"
+  in
+    E.emit out ilCtx debugFile;
+    out
+  end
+
+  fun exec () =
+  let
+    val config = parseCmdArgs initConfig (CommandLine.arguments ())
+
+    val parseCtx = parse config
+    val ilCtx = ilConv parseCtx config
+    val asmFile = emit ilCtx config
+  in
+    if modCmp (#mode config, EmAsm) = GREATER then
+      let
+        val objFile = assemble config asmFile
+      in
+        if modCmp (#mode config, EmObj) = GREATER then
+          link config objFile
+        else
+          ()
+      end
+    else
+      ()
+  end
+end