(** Time-stamp: <modified the 14/12/2007 (at 16:57) by Erwan Jahier> *)

(**

   compUtils.ml    
   compUtils.mli


   expandPack.mli
   expandPack.ml

   syntaxe.ml


   compile.ml   

- 
   compileData.ml



   lazyCompiler.mli
   lazyCompiler.ml

- source tables: tabulated version of the parse tree 
   srcTab.mli
   srcTab.ml
   
- Symbol table
   symbolTab.mli
   symbolTab.ml


- Lexing and Parsing stuff
   lexer.mll  
   parser.mly
   parserUtils.ml

   lxm.mli
   lxm.ml


- Static evaluation of parameters
   evalConst.mli
   evalConst.ml

   evalType.mli      
   evalType.ml

- Misc modules
   dump.ml
   
   errors.ml

   verbose.mli
   verbose.ml

   version.ml
*)


open Verbose
open Syntaxe
open Lxm
open Errors
open Parsing
open Format


let usage_msg =  
  "usage: "^(Version.tool)^" [options] <file> | "^(Version.tool)^" -help"

(*---------------------------------------------------------
Les args sont des variables GLOBALES
---------------------------------------------------------*)
type lpp_args = {
  mutable infile : string ;
  mutable main_node : string ;
  mutable runmode : string ;
}
let rec _LPP_ARGS = {
  infile = "" ;   (* FICHIER D'ENTREE *)
  main_node = "main"; (* MAIN NODE *)
  runmode = "" ;  (* MODE TEST *)
}
  (* RECUPERATION DU FICHIER D'ENTREE *)
and set_infile = function (x:string) -> (
  if ( _LPP_ARGS.infile = "" ) then (
    _LPP_ARGS.infile <- x
  ) else (
    Arg.usage
      arg_list 
      ("unexpected argument \""^x^"\"\n"^usage_msg) ;
    exit 1
  )
)
  (* RECUPERATION DU MAIN NODE *)
and set_run_mode = function (x:string) -> (
  _LPP_ARGS.runmode <- x	
)
and print_version = function (x: unit) -> (
  print_string (Version.str ^ "\n")
)
and arg_list = [
  ( "-version", Arg.Unit(function x -> print_version () ; exit 0),
    "  print the current version then exit"
  );
  ( "-n", Arg.String(function x -> _LPP_ARGS.main_node <- x ; ()),
    "  <node> specify the main node"
  );
  ( "-tlex", Arg.Unit(function x -> _LPP_ARGS.runmode <- "tlex" ; ()),
    "  test lexical analysis"
  );
  ( "-tcheck", Arg.Unit(function x -> _LPP_ARGS.runmode <- "tcheck" ; ()),
    "  test static analysis"
  );
  ( "-dump", Arg.Unit(function x -> _LPP_ARGS.runmode <- "dump" ; ()),
    "  parse and dump the internal data"
  );
  ( "-v", Arg.Unit(function x -> Verbose.on () ),
    "  set verbose mode"
  )
]
and
    parse_args () = (
      Arg.parse arg_list (* liste des options *)
	set_infile       (* arg par defaut = fichier d'entree *)
	usage_msg        (* message d'erreur *)
      ;
      ()
    )

let test_lex ( lexbuf ) = (
  let tk = ref (Lexer.lexer lexbuf) in (
      while !tk <> Parser.TK_EOF do
	match (Lexer.token_code !tk) with 
	    ( co , lxm ) ->
	      printf "%s : %15s = \"%s\"\n"
		(Lxm.position lxm) co (Lxm.str lxm) ;
	      tk := (Lexer.lexer lexbuf)
      done
    )	
)

(* Retourne un parse_tree *)
let lus_load lexbuf = (
  (Parser.sxLusFile Lexer.lexer lexbuf)
) 

(* Dump d'un packbody *)
let dump_body (pkg: Syntaxe.packbody) = (
  let os = Format.formatter_of_out_channel stdout in
    Dump.dump_packbody os pkg	
)

(* Dump d'un name-space, pack ou modele ...  *)
let dump_ns (ns: Syntaxe.pack_or_model) = (
  let os = Format.formatter_of_out_channel stdout in
    match ns with
	NSPack pf -> (
	  (* Verbose.put (lazy ("DUMP PACKDEF\n")); *)
	  Dump.dump_packinfo os pf
	) 
      | NSModel mf -> (
	  (* Verbose.put (lazy ("DUMP MODDEF\n")); *)
	  Dump.dump_modelinfo os mf
	) 
)

  (*
    Lance le parser et renvoie la liste name-spaces d'entr�e.	
    Dans le cas d'un fichier sans package, on lui donne
    comme nom le basename de infile.
  *)
let get_source_list infile lexbuf = (
  match (lus_load lexbuf) with
      PRPackBody pbdy -> 
	(
	  let nme = Filename.chop_extension (Filename.basename infile) in
	  let pi = Syntaxe.give_pack_this_name (Ident.pack_name_of_string nme) pbdy in
	    [
	      NSPack (Lxm.flagit pi Lxm.dummy)
	    ]
	) 
    | PRPack_or_models nsl -> nsl
)

let main = (
  (* Compile.init_appli () ; *)
  parse_args () ;
  if (_LPP_ARGS.infile = "") then (
    Arg.usage arg_list usage_msg ;
    exit 1
  ) ;
  try (
    let inchannel = open_in _LPP_ARGS.infile in
    let lexbuf = Lexing.from_channel inchannel in
      match _LPP_ARGS.runmode with
	| "tlex"   -> (
	    test_lex lexbuf
	  ) 
	    (* "tcheck"  -> (
	       Compile.test_check (pkg_load lexbuf) _LPP_ARGS.main_node
	       ) |
	    *)
	| "dump" -> (
	    let nsl = get_source_list _LPP_ARGS.infile lexbuf in
	      List.iter dump_ns nsl ;
	  ) 
	|  _ -> (
	     (* Compile.compile (pkg_load lexbuf) _LPP_ARGS.main_node  *)
	     let nsl = get_source_list _LPP_ARGS.infile lexbuf in
	     let nodidf = Ident.idref_of_string _LPP_ARGS.main_node in
	       Compile.doit nsl nodidf 
	   )
  ) with
      Sys_error(s) ->
	prerr_string (s^"\n") ;
	exit 1 
    | Global_error s ->
       print_global_error s ;
	  exit 1
    | Parse_error ->
	print_compile_error (Lxm.last_made ()) "syntax error";
	exit 1
    | Compile_error(lxm,msg) -> 
	print_compile_error lxm msg ;
	exit 1
    | Assert_failure (file, line, col)  -> 
	prerr_string (
	  "\n*** An internal error occured in file "^ file ^ ", line " ^ 
	    (string_of_int line) ^ ", column " ^
	    (string_of_int col) ^ "\n") ;
	exit 2

	(* | Compile_node_error(nkey,lxm,msg) -> ( *)
	(* print_compile_node_error nkey lxm msg ; *)
	(* exit 1 *)
	(* ) *)
	(* | Global_node_error(nkey,msg) -> ( *)
	(* print_global_node_error nkey msg ; *)
	(* exit 1 *)
	(* ) *)

)