main.ml

(** Time-stamp: <modified the 28/08/2008 (at 10:28) by Erwan Jahier> *)

(** Here follows a description of the different modules used by this lus2lic compiler.

(1) First of all, the Lustre files are parsed,

   lexer.mll  
   parser.mly
   parserUtils.ml
   lxm.mli/ml

which results into a parse tree containing raw source expressions.

   syntaxTree.ml  -> should rather be called rawSyntaxTab.ml ?
   syntaxTreedump.ml

(2) Then, we perform reference checking at module level + model expansion.

   syntaxTab.mli/ml
      syntaxTabUtil.ml/mli
      expandPack.mli/ml
      symbolTab.mli/ml (type/const/node)

syntaxTab is a kind of layer above syntaxTree to make things easier afterwards.


(3) Finally, the compilation (type checking+const/type evaluation) is performed.

   compile.ml
      lazyCompiler.mli/ml
        evalConst.mli/ml
        evalType.mli/ml
   compiledData.ml
    

Some misc (eponymous) modules are used along the way.
   errors.ml 
   verbose.mli/ml
   version.ml
   ident.ml
*)


open Verbose
open SyntaxTree
open SyntaxTreeCore
open Lxm
open Errors
open Parsing
open Format


(*---------------------------------------------------------
Les args sont des variables GLOBALES
---------------------------------------------------------*)

let print_version = function (x: unit) -> (
  print_string (Version.str ^ "\n")
)

let usage_msg =  
  "usage: "^(Version.tool)^" [options] <lustre files> | "^(Version.tool)^" -help" 
   
let rec arg_list = [
  ( "--version", Arg.Unit(fun x -> print_version () ; exit 0),
    "\tPrint the current version then exit"
  );
  ( "--output-file", Arg.String(fun x -> Global.outfile := x), "<file>"
  );
  ( "-o", Arg.String(fun x -> Global.outfile := x),
    "<file>\tSet the output file name"
  );
  ( "--node", Arg.String(fun x -> Global.main_node := x),
    "<node>"
  );
  ( "-n", Arg.String(fun x -> Global.main_node := x),
    "<node>\tSet the main node (all items are compiled if unset)"
  );
  ( "--compile-all-items", Arg.Unit
      (function x -> Global.compile_all_items := true),
    "\t"
  );
  ( "-all", Arg.Unit
      (function x -> Global.compile_all_items := true),
    "\t\tCompile all items of the program"
  );
  ( "-unit", Arg.Unit (fun x -> Global.run_unit_test := true),
    "\tRun some (internal) unit tests"
  );
  ( "--verbose", Arg.Unit (fun vl -> Verbose.set_level 1 ),
    ""
  );
  ( "-v", Arg.Unit (fun vl -> Verbose.set_level 1 ),
    "\t\tSet verbose mode on (i.e., verbose level = 1)"
  );
  ( "--verbose-level", Arg.Int(fun vl -> Verbose.set_level vl ), "<int>"
  );
  ( "-vl", Arg.Int(fun vl -> Verbose.set_level vl ),
    "<int>\tSet verbose level"
  );

  ( "--keep-nested-calls", Arg.Unit (fun _ -> Global.one_op_per_equation := false),
    "\tKeep nested calls"
  );


  ("-h", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)), "" );
  ("-help", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)),"" );
  ("--help", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)),
   "\tDisplay this list of options" )
]
and
    parse_args () = (
      Arg.parse arg_list  (* liste des options *)
        Global.add_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 = (
  SolveIdent.recognize_predef_op 
    (Parser.sxLusFile Lexer.lexer lexbuf)
) 

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

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

  (*
    Lance le parser et renvoie la liste name-spaces d'entre.   
    Dans le cas d'un fichier sans package, on lui donne
    comme nom le basename de infile.
  *)
type maybe_packed = 
  | Packed of SyntaxTree.pack_or_model list
  | Unpacked of SyntaxTree.pack_or_model

let (get_source_list : string list -> SyntaxTree.pack_or_model list) =
  fun infile_list -> 
    let (get_one_source : string -> string list * maybe_packed) = 
      fun infile -> 
        let lexbuf = Global.lexbuf_of_file_name infile in
          match (lus_load lexbuf) with
            | PRPackBody(incl_files, pbdy) ->
                let nme = 
                  try Filename.chop_extension (Filename.basename infile) 
                  with _ -> print_string ("*** '"^infile^"': bad file name.\n"); exit 1
                in
                let pi = 
                  SyntaxTree.give_pack_this_name (Ident.pack_name_of_string nme) pbdy 
                in
                  incl_files, Unpacked (NSPack (Lxm.flagit pi (Lxm.dummy nme)))
            | PRPack_or_models(incl_files, nsl) -> incl_files, Packed nsl
    in
    let rec (get_remaining_source_list : maybe_packed * string list * string list -> 
           maybe_packed * string list * string list) =
      fun (maybe_pack, compiled, to_be_compiled) -> 
        match to_be_compiled with
          | [] -> (maybe_pack, compiled, [])
          | infile::tail ->
              if List.mem infile compiled then
                get_remaining_source_list (maybe_pack, compiled, tail)
              else
                let included_files, pack = get_one_source infile in
                let new_maybe_pack =
                  match maybe_pack, pack with
                    | Unpacked _, _ 
                    | _, Unpacked _ -> 
                        print_string ("old-style (un-packaged) lustre files can " ^
                                        " not be mixed with packages, nor be " ^
                                        " defined in more than 1 file.");
                        exit 1
                    | Packed l1, Packed l2 -> Packed (l1@l2)
                in
                  get_remaining_source_list(
                    new_maybe_pack, 
                    infile::compiled, 
                    tail@included_files)
    in
    let first_file = assert (infile_list <> []); List.hd infile_list in
    let included_files, first_pack = get_one_source first_file in
    let (pack_list,_,_) = get_remaining_source_list 
      (first_pack, [first_file], (List.tl infile_list) @ included_files)
    in
      match pack_list with 
        | Packed l -> l
        | Unpacked pack -> [pack]
    


let my_exit i =
  close_out !Global.oc;
  if Sys.file_exists !Global.outfile then Sys.remove !Global.outfile;
  exit i

let main = (
  (* Compile.init_appli () ; *)
  parse_args ();
  if !Global.run_unit_test then (
    UnifyType.unit_test ()
  );
  if (!Global.infiles = []) then (
    Arg.usage arg_list usage_msg ;
    exit 1
  );
  try (
    let nsl = get_source_list !Global.infiles in
    let main_node = 
      if !Global.main_node = "" then None else 
        Some (Ident.idref_of_string !Global.main_node)
    in
      if !Global.outfile <> "" then Global.oc := open_out !Global.outfile;
      Compile.doit nsl main_node;
      LicDump.dump_type_alias !Global.oc;
      LicDump.dump_node_alias !Global.oc;
      close_out !Global.oc
  ) with
      Sys_error(s) ->
        prerr_string (s^"\n");
        my_exit 1
    | Global_error s ->
        print_global_error s ;
        my_exit 1
    | Parse_error ->
        print_compile_error (Lxm.last_made ()) "syntax error";
        my_exit 1
    | Compile_error(lxm,msg) -> 
        print_compile_error lxm msg ;
        my_exit 1
    | Assert_failure (file, line, col)  -> 
        prerr_string (
          "\n*** oops: an internal error occurred in file "^ file ^ ", line " ^ 
            (string_of_int line) ^ ", column " ^
            (string_of_int col) ^ "\n*** when compiling lustre program" ^
            (if List.length !Global.infiles > 1 then "s " else " ") ^
            (String.concat ", " !Global.infiles) ^ "\n") ;
        my_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 *)
        (* ) *)

)