mpri-funcprog-project/src/Main.ml

(* -------------------------------------------------------------------------- *)

(* Parse the command line. *)

let debug =
  ref false

let light_debug =
    ref false

let no_varvarbind = ref false
let no_const_propagation = ref false

let filenames =
  ref []

let record filename =
  filenames := filename :: !filenames

let options =
  Arg.align [
    "--debug", Arg.Set debug, " Enable debugging output";
    "--light-debug", Arg.Set light_debug, " Enable debugging output";
    "--no-var-var-bind", Arg.Set no_varvarbind,
        "Disable var/var bind suppression";
    "--no-const-propagation", Arg.Set no_const_propagation,
        "Disable constants propagation";
  ]

let usage =
  Printf.sprintf "Usage: %s <options> <filename>" Sys.argv.(0)

let () =
  Arg.parse options record usage

let debug =
  !debug
let light_debug =
  !light_debug

let no_varvarbind = !no_varvarbind
let no_const_propagation = !no_const_propagation

let filenames =
  List.rev !filenames

(* -------------------------------------------------------------------------- *)

(* Printing a syntax tree in an intermediate language (for debugging). *)

let print_delimiter () =
  Printf.eprintf "----------------------------------------";
  Printf.eprintf "----------------------------------------\n"

let dump (phase : string) (show : 'term -> string) (light: bool) (t : 'term) =
  if debug || (light_debug && light) then begin
    print_delimiter();
    Printf.eprintf "%s:\n\n%s\n\n%!" phase (show t)
  end;
  t

(* -------------------------------------------------------------------------- *)

(* Reading and parsing a file. *)

let read filename : RawLambda.term =
  try
    let contents = Utils.file_get_contents filename in
    let lexbuf = Lexing.from_string contents in
    Error.set_filename lexbuf filename;
    try
      Parser.entry Lexer.entry lexbuf
    with
    | Parser.Error ->
        Error.error (Error.place lexbuf) "Syntax error."
  with
  | Sys_error msg ->
      prerr_endline msg;
      exit 1

(* -------------------------------------------------------------------------- *)

(* Printing the final C program on the standard output channel. *)

let output (p : C.program) : unit =
  Printf.printf "#include<stdlib.h>\n";
  Printf.printf "#include<stdio.h>\n";
  Printf.printf "#include \"prologue.h\"\n\n";
  let print_program = PrintCommon.print_program PrintC.p_decl_or_function in
  let buf = Buffer.create 1024 in
  PrintCommon.printf_of_pprint_pretty print_program buf p;
  print_endline (Buffer.contents buf)

(* -------------------------------------------------------------------------- *)

(* The complete processing pipeline. Beautiful, isn't it? *)

let skip x = x

let process filename =
  filename
  |> read
  |> dump "RawLambda" RawLambda.show_term false
  |> Cook.cook_term
  |> dump "Lambda" Lambda.show_term false
  |> CPS.cps_term
  |> dump "Tail" Tail.show_term false
  |> dump "PrettyTail" PrettyTail.show true
  |> Defun.defun_term
  |> (if no_varvarbind then skip else VarVarBind.clean_var_var_bind)
  |> (if no_const_propagation then skip else
      ConstantPropag.constant_propagation)
  |> dump "Top" Top.show_program false
  |> dump "PrettyTop" PrettyTop.show true
  |> Finish.finish_program
  |> dump "C" C.show_program false
  |> output

(* -------------------------------------------------------------------------- *)

(* The main program. *)

let () =
  List.iter process filenames