Source

olfend / main.ml

open Opcode
open Vm

(** Execute one toplevel phrase, and print the result *)
let exec_one tyEnv0 existing_codes venv ienv top =
  let tyEnv, d = Typed.Top.of_olf tyEnv0 top in

  Format.eprintf "ast=%a@." Typed.Top.format d;
  
  let d = 
    match Interm.Top.of_globals tyEnv @ [ Interm.Top.of_typed d ] with
    | [d; Interm.Top.NOP] -> d
    | [d] -> d
    | _ -> assert false
  in

  let codes, nresults, _postproc, blocks, ienv = Opcode.Top.compile ienv d in 
  
  let pc, codes = Code.link existing_codes (codes 
                                            @ [Code.ReturnAt nresults] 
                                            @ List.flatten blocks) 
  in
  
  let vstack, venv = Eval.run codes pc venv in

  (* It's silly but discard the top dummy return *)
  begin match compare nresults (List.length vstack) with
  | 0 -> ()
  | 1 -> failwith "short stack at exec_one"
  | -1 -> failwith "long stack at exec_one"
  | _ -> assert false
  end;
  
  (* CR jfuruse: postproc should be used *)
  let venv = Interm.Top.( match d, vstack with
    | Let ([id,_], _), [v] -> VMEnv.push venv id v 
    | Let ([_,_], _), _ -> assert false
    | Let (ident_ptyps, _), vs -> 
        List.fold_left (fun venv (ident, v) -> VMEnv.push venv ident v) venv (List.combine (List.map fst ident_ptyps) vs)
    | (Expr _ | Load _ | NOP), _ -> venv  
    )
  in

  tyEnv, codes, venv, ienv

let version = "no-version"

let interp () = 
  Format.printf "Olfend version %s@." version;
  let lexbuf = Lexing.from_channel stdin in
  let rec loop tyEnv codes venv ienv = 
    print_string "> "; flush stdout;
    try
      let str = Parse.toplevel_phrase lexbuf in
      let tops = Ocamlolf.Conv.toplevel_phrase str in
      let tyEnv, codes', venv', ienv' = List.fold_left (fun (tyEnv, codes, venv, ienv) top ->
        exec_one tyEnv codes venv ienv top) (tyEnv, codes, venv, ienv) tops
      in
      loop tyEnv codes' venv' ienv' 
    with
    | Failure s ->
        prerr_endline s;
        loop tyEnv codes venv ienv
  in
  loop Typed.TyEnv.initial [||] VMEnv.empty []

let _ =
  let files, compile = 
    let compile = ref false in
    let rev_files = ref [] in
    Arg.parse [ "-print-step", Arg.Set Eval.print_step, "print execution states"
              ; "-c", Arg.Set compile, "compile and save"
              ] 
      (fun s -> rev_files := s :: !rev_files) 
      "lambda <scripts>";
    List.rev !rev_files, !compile
  in

  let top_load = function
    | ".olf" -> Olf.Top.load (* CR jfuruse: deprecated *)
    | ".ml" -> Ocamlolf.load
    | _ -> assert false
  in

  let do_file path =
    Types.reset ();
    Ident.reset ();
    Opcode.Label.reset ();
    let dir, body, ext = Filepath.parse_path path in
    let modname = String.capitalize body in
    match ext with
    | ".olf" | ".ml" -> (* compile a source file *) 
        let dest = dir ^ "/" ^ body ^ Filepath.ext_object in
        Format.eprintf "Compiling %s => %s@." path dest;
        let tops = top_load ext path in
        let module_ =  Module.compile Typed.TyEnv.initial tops modname in
        let checksum = Sig.save (dir ^ "/" ^ body ^ Filepath.ext_signature) module_.Module.signature in
        let module_ = { module_ with Module.sigdigest = Some checksum } in
        Module.save_file (dir ^ "/" ^ body ^ Filepath.ext_object) module_;
        Format.eprintf "Done compiling %s => %s@." path dest;
        module_
    | ".obj" -> (* load an object *)
        Format.eprintf "Loading %s@." path;
        let module_ = Module.load_file path in 
        Format.eprintf "Done loading %s@." path;
        module_
    | _ -> assert false
  in

  match files with
  | [] -> interp ()
  | fs -> 
      let ms = List.map do_file fs in
      Types.reset ();
      Ident.reset ();
      Opcode.Label.reset ();
      if compile then () (* No final linking yet *)
      else
        let code, pc = Module.link ms in (* CR jfuruse: code/codes arbitrary use in the whole program! *)
        ignore (Eval.run code pc VMEnv.empty)