Add native build and compiler driver

src/diagnostic.ml

@@ -0,0 +1,58 @@
+type t = {
+  file : string;
+  span : Location.span;
+  message : string;
+}
+
+exception Error of t
+
+let current_file = ref ""
+
+let set_file file = current_file := file
+
+let file_label () = if !current_file = "" then "<none>" else !current_file
+
+let file () = file_label ()
+
+let error span fmt =
+  Printf.ksprintf
+    (fun message -> raise (Error { file = file_label (); span = span; message = message }))
+    fmt
+
+let make span message = { file = file_label (); span = span; message = message }
+
+let header d =
+  if Location.is_none d.span then Printf.sprintf "%s: error: %s" d.file d.message
+  else Printf.sprintf "%s:%d:%d: error: %s" d.file d.span.Location.start.Location.line
+      d.span.Location.start.Location.col d.message
+
+let to_string d = header d
+
+let source_line text line =
+  if line <= 0 then None
+  else
+    let lines = String.split_on_char '\n' text in
+    let rec nth items index =
+      match items with
+      | [] -> None
+      | head :: tail -> if index = 1 then Some head else nth tail (index - 1)
+    in
+    nth lines line
+
+let render source d =
+  let head = header d in
+  match source with
+  | None -> head
+  | Some text -> (
+      match source_line text d.span.Location.start.Location.line with
+      | None -> head
+      | Some line ->
+          let col = max 1 d.span.Location.start.Location.col in
+          let width =
+            if d.span.Location.stop.Location.line = d.span.Location.start.Location.line then
+              max 1 (d.span.Location.stop.Location.col - col)
+            else max 1 (String.length line - col + 1)
+          in
+          let padding = String.make (col - 1) ' ' in
+          let carets = String.make width '^' in
+          Printf.sprintf "%s\n  %s\n  %s%s" head line padding carets)

src/diagnostic.mli

@@ -0,0 +1,14 @@
+type t = {
+  file : string;
+  span : Location.span;
+  message : string;
+}
+
+exception Error of t
+
+val set_file : string -> unit
+val file : unit -> string
+val error : Location.span -> ('a, unit, string, 'a) format4 -> 'a
+val make : Location.span -> string -> t
+val to_string : t -> string
+val render : string option -> t -> string

src/ident.ml

@@ -0,0 +1,31 @@
+type t = {
+  name : string;
+  stamp : int;
+  span : Location.span;
+}
+
+let next_stamp = ref 0
+
+let create name span =
+  incr next_stamp;
+  { name = name; stamp = !next_stamp; span = span }
+
+let fresh = create
+
+let name id = id.name
+
+let stamp id = id.stamp
+
+let span id = id.span
+
+let equal a b = a.stamp = b.stamp
+
+let compare a b = compare a.stamp b.stamp
+
+let to_string id = Printf.sprintf "%s#%d" id.name id.stamp
+
+let display id = id.name
+
+let with_name id name = { id with name = name }
+
+let reset () = next_stamp := 0

src/ident.mli

@@ -0,0 +1,13 @@
+type t
+
+val create : string -> Location.span -> t
+val fresh : string -> Location.span -> t
+val name : t -> string
+val stamp : t -> int
+val span : t -> Location.span
+val equal : t -> t -> bool
+val compare : t -> t -> int
+val to_string : t -> string
+val display : t -> string
+val with_name : t -> string -> t
+val reset : unit -> unit

src/location.ml

@@ -0,0 +1,42 @@
+type pos = {
+  line : int;
+  col : int;
+  offset : int;
+}
+
+type span = {
+  start : pos;
+  stop : pos;
+}
+
+let none = {
+  start = { line = 0; col = 0; offset = 0 };
+  stop = { line = 0; col = 0; offset = 0 };
+}
+
+let is_none span =
+  span.start.line = 0 && span.start.col = 0 && span.stop.line = 0 && span.stop.col = 0
+
+let make start stop = { start = start; stop = stop }
+
+let point pos = { start = pos; stop = pos }
+
+let merge a b =
+  if is_none a then b
+  else if is_none b then a
+  else { start = a.start; stop = b.stop }
+
+let pos_of_lexing pos =
+  { line = pos.Lexing.pos_lnum; col = pos.Lexing.pos_cnum - pos.Lexing.pos_bol + 1; offset = pos.Lexing.pos_cnum }
+
+let span_of_lexing start stop = { start = pos_of_lexing start; stop = pos_of_lexing stop }
+
+let pos_to_string pos = Printf.sprintf "%d:%d" pos.line pos.col
+
+let to_string span =
+  if is_none span then "0:0"
+  else Printf.sprintf "%d:%d-%d:%d" span.start.line span.start.col span.stop.line span.stop.col
+
+let size span =
+  if is_none span then 0
+  else (span.stop.offset - span.start.offset)

src/location.mli

@@ -0,0 +1,21 @@
+type pos = {
+  line : int;
+  col : int;
+  offset : int;
+}
+
+type span = {
+  start : pos;
+  stop : pos;
+}
+
+val none : span
+val is_none : span -> bool
+val make : pos -> pos -> span
+val point : pos -> span
+val merge : span -> span -> span
+val pos_of_lexing : Lexing.position -> pos
+val span_of_lexing : Lexing.position -> Lexing.position -> span
+val pos_to_string : pos -> string
+val to_string : span -> string
+val size : span -> int

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

src/native.ml

@@ -0,0 +1,110 @@
+let read_file path =
+  let channel = open_in_bin path in
+  let length = in_channel_length channel in
+  let text = really_input_string channel length in
+  close_in channel;
+  text
+
+let env_opt name = try Some (Sys.getenv name) with Not_found -> None
+
+let file_exists path = Sys.file_exists path
+
+let normalize path =
+  let absolute = if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path else path in
+  let parts = String.split_on_char '/' absolute in
+  let step acc part =
+    match (part, acc) with
+    | "", acc -> acc
+    | ".", acc -> acc
+    | "..", (_ :: rest) -> rest
+    | "..", [] -> []
+    | part, acc -> part :: acc
+  in
+  "/" ^ String.concat "/" (List.rev (List.fold_left step [] parts))
+
+let which name =
+  if String.contains name '/' then (if file_exists name then Some (normalize name) else None)
+  else
+    let path = try Sys.getenv "PATH" with Not_found -> "" in
+    let rec search dirs =
+      match dirs with
+      | [] -> None
+      | dir :: rest ->
+          let candidate = Filename.concat (if dir = "" then "." else dir) name in
+          if file_exists candidate then Some (normalize candidate) else search rest
+    in
+    search (String.split_on_char ':' path)
+
+let executable_dir () =
+  let exe = Sys.executable_name in
+  match which (Filename.basename exe) with
+  | Some resolved -> Filename.dirname resolved
+  | None -> Filename.dirname (normalize exe)
+
+let first_some items =
+  let rec loop = function
+    | [] -> None
+    | item :: rest -> ( match item with Some _ -> item | None -> loop rest)
+  in
+  loop items
+
+let runtime_dir () =
+  match env_opt "DELTA_RUNTIME_DIR" with
+  | Some dir -> dir
+  | None ->
+      let here = executable_dir () in
+      let candidates =
+        [
+          Filename.concat here "_build";
+          normalize (Filename.concat here "../../lib/delta");
+          normalize (Filename.concat here "../lib/delta");
+          Filename.concat here "lib/delta";
+        ]
+      in
+      let marked candidate = file_exists (Filename.concat candidate "delta_runtime.cmxa") in
+      let matches = List.map (fun candidate -> if marked candidate then Some candidate else None) candidates in
+      (match first_some matches with
+      | Some candidate -> candidate
+      | None -> ( match candidates with candidate :: _ -> candidate | [] -> here))
+
+let temp_dir () =
+  let base = Filename.temp_file "deltac" "" in
+  Sys.remove base;
+  Unix.mkdir base 0o700;
+  base
+
+let remove_dir path =
+  let rec remove path =
+    if Sys.is_directory path then (
+      let entries = Sys.readdir path in
+      Array.iter (fun entry -> remove (Filename.concat path entry)) entries;
+      Unix.rmdir path)
+    else Sys.remove path
+  in
+  try remove path with _ -> ()
+
+let run argv =
+  let log = Filename.temp_file "deltac" ".log" in
+  let fd = Unix.openfile log [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
+  let pid =
+    try Unix.create_process argv.(0) argv Unix.stdin fd fd
+    with error ->
+      Unix.close fd;
+      (try Sys.remove log with _ -> ());
+      raise error
+  in
+  let status = snd (Unix.waitpid [] pid) in
+  Unix.close fd;
+  let text = try read_file log with _ -> "" in
+  (try Sys.remove log with _ -> ());
+  (status, text)
+
+let compile ~runtime_dir ~source ~output =
+  let archive = Filename.concat runtime_dir "delta_runtime.cmxa" in
+  let argv = [| "ocamlopt"; "-I"; runtime_dir; "-o"; output; archive; source |] in
+  if file_exists output then Sys.remove output;
+  let status, text = run argv in
+  match status with
+  | Unix.WEXITED 0 when file_exists output -> None
+  | Unix.WEXITED 0 -> Some (text ^ "\nocamlopt did not produce " ^ output)
+  | _ -> Some text

src/native.mli

@@ -0,0 +1,11 @@
+val read_file : string -> string
+val env_opt : string -> string option
+val file_exists : string -> bool
+val normalize : string -> string
+val which : string -> string option
+val executable_dir : unit -> string
+val runtime_dir : unit -> string
+val temp_dir : unit -> string
+val remove_dir : string -> unit
+val run : string array -> Unix.process_status * string
+val compile : runtime_dir:string -> source:string -> output:string -> string option