Add native build and compiler driver

src/main.ml

@@ -0,0 +1,149 @@
+let version = "0.1.0"
+
+let usage =
+  String.concat "\n"
+    [
+      "usage: deltac <command> [options]";
+      "";
+      "commands:";
+      "  check FILE                        report errors in FILE";
+      "  dump --typed|--anf|--delta FILE   print a compiler stage dump";
+      "  emit FILE -o OUTPUT.ml            write generated OCaml source";
+      "  build FILE -o EXECUTABLE          compile FILE to a native executable";
+      "";
+      "options:";
+      "  -o FILE     output path for emit and build";
+      "  --version   print the compiler version";
+      "  --help      print this message";
+      "";
+    ]
+
+type command =
+  | Check of string
+  | Dump of string * string
+  | Emit of string * string
+  | Build of string * string
+  | Version
+  | Help
+
+let usage_error message =
+  prerr_endline ("deltac: " ^ message);
+  prerr_string usage;
+  exit 2
+
+let parse_options args =
+  let rec loop files stage output rest =
+    match rest with
+    | [] -> (List.rev files, stage, output)
+    | "-o" :: value :: rest -> loop files stage (Some value) rest
+    | [ "-o" ] -> usage_error "option -o requires an argument"
+    | flag :: rest when flag = "--typed" || flag = "--anf" || flag = "--delta" ->
+        if stage <> None then usage_error "only one dump stage may be given"
+        else loop files (Some (String.sub flag 2 (String.length flag - 2))) output rest
+    | arg :: _ when String.length arg > 0 && arg.[0] = '-' -> usage_error ("unknown option " ^ arg)
+    | file :: rest -> loop (file :: files) stage output rest
+  in
+  loop [] None None args
+
+let single_file command files =
+  match files with
+  | [ file ] -> file
+  | [] -> usage_error (command ^ " requires a file")
+  | _ -> usage_error (command ^ " accepts exactly one file")
+
+let parse_command () =
+  let argv = Array.to_list Sys.argv in
+  match argv with
+  | _ :: "check" :: rest ->
+      let files, _, _ = parse_options rest in
+      Check (single_file "check" files)
+  | _ :: "dump" :: rest ->
+      let files, stage, _ = parse_options rest in
+      let stage =
+        match stage with
+        | Some stage -> stage
+        | None -> usage_error "dump requires --typed, --anf or --delta"
+      in
+      Dump (stage, single_file "dump" files)
+  | _ :: "emit" :: rest ->
+      let files, _, output = parse_options rest in
+      let file = single_file "emit" files in
+      let output = match output with Some output -> output | None -> usage_error "emit requires -o OUTPUT.ml" in
+      Emit (file, output)
+  | _ :: "build" :: rest ->
+      let files, _, output = parse_options rest in
+      let file = single_file "build" files in
+      let output = match output with Some output -> output | None -> usage_error "build requires -o EXECUTABLE" in
+      Build (file, output)
+  | _ :: ("--version" | "-version") :: _ -> Version
+  | _ :: ("--help" | "-help" | "help") :: _ -> Help
+  | [ _ ] -> usage_error "a command is required"
+  | _ :: unknown :: _ -> usage_error ("unknown command " ^ unknown)
+  | [] -> usage_error "a command is required"
+
+let load_source path =
+  Diagnostic.set_file path;
+  Native.read_file path
+
+let frontend_unavailable () =
+  Diagnostic.error Location.none "the delta source frontend is not implemented in this revision"
+
+let check path =
+  ignore (load_source path);
+  frontend_unavailable ()
+
+let dump stage path =
+  ignore (load_source path);
+  ignore stage;
+  frontend_unavailable ()
+
+let emit path output =
+  ignore (load_source path);
+  ignore output;
+  frontend_unavailable ()
+
+let build path output =
+  ignore (load_source path);
+  ignore output;
+  frontend_unavailable ()
+
+let source_of file = try Some (Native.read_file file) with _ -> None
+
+let report diagnostic =
+  prerr_endline (Diagnostic.render (source_of diagnostic.Diagnostic.file) diagnostic)
+
+let execute () =
+  match parse_command () with
+  | Help ->
+      print_string usage;
+      0
+  | Version ->
+      print_endline version;
+      0
+  | Check path ->
+      check path;
+      0
+  | Dump (stage, path) ->
+      dump stage path;
+      0
+  | Emit (path, output) ->
+      emit path output;
+      0
+  | Build (path, output) ->
+      build path output;
+      0
+
+let () =
+  let status =
+    try execute () with
+    | Diagnostic.Error diagnostic ->
+        report diagnostic;
+        1
+    | Sys_error message ->
+        prerr_endline ("deltac: " ^ message);
+        1
+    | Unix.Unix_error (error, fn, arg) ->
+        prerr_endline (Printf.sprintf "deltac: %s failed on %s: %s" fn arg (Unix.error_message error));
+        1
+  in
+  exit status