(**********************************************************************)
(* (c) Greg Morrisett, Neal Glew, Stephanie Weirich,                  *)
(*     June 1998, all rights reserved.                                *)
(**********************************************************************)

open Talout;;
open Gcd;;

let set_no_print_comments() = Scomp.print_comments := false;;

let compile_scheme_file filename basename modname =
  let talfile = basename ^ ".tal" in
  let objectfile = basename ^ ".obj" in
  let executable = basename ^ ".exe" in
  Printf.printf "Compiling file: %s\n" basename; flush stdout;
  try
    let ic = open_in filename in
    let syntaxTree = 
      try 
      	Sparse.prog Slex.token (Lexing.from_channel ic) 
      with 
	Parsing.Parse_error ->
	  Printf.eprintf "%s: syntax error line %d\n" filename !Slex.line;
	  flush stderr; close_in ic; raise Parsing.Parse_error
      | x  ->
	  Printf.eprintf "%s: unknown exception line %d\n" filename !Slex.line;
	  flush stderr; close_in ic; raise x in
    let ilTree = Sil.xprog syntaxTree in
    let tal_imp = Scomp.code_gen ilTree in
    try
      Talout.write_imp modname talfile tal_imp;
      Talout.verify talfile;
      if assemble_p () then begin
      	Talout.asm talfile (Some objectfile);
      	if link_p () then
	  let objfiles =
	    [ objectfile;
	      "sclib"^Talout.object_file_suffix;
	      "stdlib"^Talout.object_file_suffix ] in
      	  Talout.link objfiles executable
      end
    with 
      Sys_error str ->
	Printf.eprintf "System error: %s\n" str; flush stderr
  with
    Sys_error s ->
      Printf.eprintf "%s: %s\n" filename s; flush stderr
;;

let toolname = "scheme";;
set_tooldesc "scheme: JGM's version of scheme compiler";;

let options = std_options @
  ["-C",Arg.Unit set_no_print_comments, "do not print comments in TAL code"]
;;

let file_types = [".s",compile_scheme_file;".ss",compile_scheme_file];;

let do_link _ _ _ = ();;

let main () = driver toolname options file_types do_link;;

Printexc.catch main () ;;

(* EOF: scheme.ml *)
