main.ml

(* Time-stamp: <modified the 19/08/2014 (at 15:36) by Erwan Jahier> *)

open Verbose
open AstV6
open AstCore
open Lxm
open Lv6errors
open Parsing
open Format
open Lv6MainArgs

let my_exit opt i =
  if opt.rif || opt.print_interface then (output_string opt.oc "\nq\n"; flush opt.oc);
  close_out opt.oc;
  if Sys.file_exists opt.outfile then Sys.remove opt.outfile;
  exit i

let rec first_pack_in =
  function
    | (AstV6.NSPack pi)::_ -> pi.it.pa_name
    | (AstV6.NSModel _)::tail -> first_pack_in tail
    | [] -> raise (Global_error "No package has been provided")

(* try to use the filenale to guess the dft node *)
let find_a_node opt =
  let first_file = List.hd opt.infiles in
  let name = 
    try Filename.chop_extension (Filename.basename first_file) 
    with _ -> 
		print_string ("*** '"^first_file^"': bad file name.\n"); exit 1
  in
  name


let (gen_rif_interface : LicPrg.t -> Ident.idref option -> Lv6MainArgs.t -> unit) =
  fun lic_prg main_node opt -> 
    let msk, zesoc, main_node = 
      match main_node with
        | None -> (
          let name = find_a_node opt in
          let main_node = Ident.to_idref name in
          let nk = (Lic.node_key_of_idref main_node) in
          if LicPrg.node_exists lic_prg nk then (
            output_string stdout ("WARNING: No main node is specified. I'll try with " 
                                  ^ name ^"\n");
            flush stdout;
            let msk, zesoc = Lic2soc.f lic_prg nk in
            msk, zesoc, main_node
          ) else (
            print_string ("Error: no node is specified.\n");
            flush stdout;
            exit 1
          )
        )
        | Some main_node -> 
          let msk, zesoc = Lic2soc.f lic_prg (Lic.node_key_of_idref main_node) in
          msk, zesoc, main_node
    in
    let my_type_to_string t =
      let str = Data.type_to_string t in
      let idref = Ident.idref_of_string str in
      (idref.Ident.id_id)
    in
    let soc = try Soc.SocMap.find msk zesoc with Not_found -> assert false in
    let invars,outvars=soc.Soc.profile in
    let invars = SocVar.expand_profile false false invars in
    let outvars = SocVar.expand_profile true false outvars in
    let invars_str  = List.map (fun (n,t) -> n^":"^(my_type_to_string t)) invars in
    let outvars_str = List.map (fun (n,t) -> n^":"^(my_type_to_string t)) outvars in
    print_string ("#inputs "^ (String.concat " " invars_str) ^"\n");
    print_string ("#outputs "^ (String.concat " " outvars_str) ^"\n");
    flush stdout


(* Generates a lutin env and a lustre oracle for the node *)
let (gen_autotest_files : LicPrg.t -> Ident.idref option -> Lv6MainArgs.t -> unit) =
  fun lic_prg main_node opt -> 
    let msk, zesoc, main_node = 
      match main_node with
        | None -> (
          let name = find_a_node opt in
          let main_node = Ident.to_idref name in
          let nk = (Lic.node_key_of_idref main_node) in
          if LicPrg.node_exists lic_prg nk then (
            output_string stdout ("WARNING: No main node is specified. I'll try with " ^ name ^"\n");
            flush stdout;
            let msk, zesoc = Lic2soc.f lic_prg nk in
            msk, zesoc, main_node
          ) else (
            print_string ("Error: no node is specified, cannot exec.\n");
            flush stdout;
            exit 1
          )
        )
        | Some main_node -> 
          let msk, zesoc = Lic2soc.f lic_prg (Lic.node_key_of_idref main_node) in
          msk, zesoc, main_node
    in
    let my_type_to_string range_flag t =
      (* Remove the module name to have correct Lutin and lv4 type decl *)
      let str = Data.type_to_string t in
      let idref = Ident.idref_of_string str in
      (if range_flag then (
        match t with
          | Data.Real -> " real [-10000.0;10000.0]"
          | Data.Int ->  " int [-10000;10000]"
          | Data.Enum(_, idl) -> " int [0;"^(string_of_int (List.length idl - 1)) ^"]" 
          | _ -> idref.Ident.id_id
       ) else idref.Ident.id_id)
    in
    let soc = try Soc.SocMap.find msk zesoc with Not_found -> assert false in
    let invars,outvars=soc.Soc.profile in
    let invars = SocVar.expand_profile false false invars in
    let outvars = SocVar.expand_profile true false outvars in
    let invars_str  = List.map (fun (n,t) -> n^":"^(my_type_to_string true t)) invars in
    let outvars_str = List.map (fun (n,t) -> n^":"^(my_type_to_string false t)) outvars in
    let name = main_node.Ident.id_id in
    let lutin_file_name = ("_"^name^"_env.lut") in
    let oc = open_out lutin_file_name in
    Lv6util.dump_entete oc; 
    output_string oc ("node " ^ (name) ^ "_env("^ (String.concat ";" outvars_str) ^ 
                         ") returns(" ^ (String.concat ";" invars_str) ^ ") =\n   loop true \n");
    flush oc; 
    close_out oc;
    output_string stdout (lutin_file_name ^" generated.\n"); 
    let oracle_file_name = ("_"^name^"_oracle.lus") in
    let oc = open_out oracle_file_name in
    let invars,outvars=soc.Soc.profile in
    let locals = List.map (fun (n,t) -> n^"_bis",t) outvars in
    let invars_str  = List.map (fun (n,t) -> n^":"^(my_type_to_string false t)) invars in
    let outvars_str = List.map (fun (n,t) -> n^":"^(my_type_to_string false t)) outvars in
    let prg = "node "^name^"_oracle("^(String.concat ";" (invars_str@outvars_str)) in
    let locals_str = List.map (fun (n,t) -> n^":"^(my_type_to_string false t)) locals in
    let ok = (* avoid name clash*)
      let all_vars = List.map fst (List.rev_append (List.rev_append locals invars) outvars) in
      let rec gen_ok str = if List.mem str all_vars then gen_ok ("_"^str) else str in
      gen_ok "ok" 
    in 
    let prg = prg ^") returns("^ok^":bool;"^(String.concat ";" locals_str)^");\nlet\n" in
    let locals_name  = List.map fst locals in
    let invars_name  = List.map fst invars in
    let prg = prg^"  ("^(String.concat "," locals_name)^") = "^name in
    let prg = prg^"("^(String.concat "," invars_name)^");\n  "^ok^" = (" in
    let (var_to_equals : Soc.var -> Soc.var -> string list) =
      fun (x,t) (y,_) -> 
        let rec aux x y t =
          match t with 
            | Data.Real -> ["r_equal("^x^","^y^")"]
            | Data.Array(t,n) -> 
              let res = ref [] in
              for i = 0 to n-1 do
                let istr = string_of_int i in
                res := !res @ aux (x^"["^istr^"]") (y^"["^istr^"]") t
              done;
              !res
            | Data.Struct(n,fl) ->
              let do_field (fn,ft) = aux (x^"."^fn) (y^"."^fn) ft in
              List.flatten (List.map do_field fl)
            | _ ->  [x^"="^y]
        in
        aux x y t
    in
    let prg = try prg^(String.concat " and\n \t\t  " 
                       (List.flatten (List.map2 var_to_equals locals outvars)))^");\ntel;\n"
      with _ -> assert false
    in
    let prg = prg ^ "
node r_abs(x:real) returns (res:real);
let
  res = if x > 0.0 then x else -x;
tel

const seuil = 0.0001;
node r_equal(x,y:real) returns (res:bool);
let
   res = if r_abs(x)>1.0 then r_abs(1.0-(y/x)) < seuil else r_abs(x-y) < seuil;
tel
" in 
    Lv6util.dump_entete oc; 
    output_string oc prg;
    flush oc; 
    close_out oc;
    output_string stdout (oracle_file_name ^" generated.\n"); 
    flush stdout

let info msg =
  let t = Sys.time() in
  Verbose.exe ~level:1 (fun () -> Printf.eprintf "%4.4f: %s%!" t msg; flush stderr)


let main () = (
  (* Compile.init_appli () ; *)
  (* parse_args (); *)
  let opt = Lv6MainArgs.parse Sys.argv in
  Verbose.exe ~level:3 (fun () ->
    Gc.set { (Gc.get ()) with Gc.verbose = 0x01 }
  );
  if opt.run_unit_test  then (UnifyType.unit_test (); exit 0);
  if (opt.infiles = []) then (Lv6MainArgs.usage stderr opt; exit 1);
  let new_dft_pack = Filename.basename (Filename.chop_extension (List.hd opt.infiles)) in
  Ident.set_dft_pack_name new_dft_pack;

  let main_node = 
    if opt.main_node = "" then None else Some (Ident.idref_of_string opt.main_node)
  in
  if opt.outfile <> "" then opt.oc <- open_out opt.outfile;
  (try (
    let nsl = Compile.get_source_list opt opt.infiles in
    let lic_prg = Compile.doit opt nsl main_node in
    if opt.print_interface then (
      gen_rif_interface lic_prg main_node opt;
      info "bye!";
      exit 0
    );
    if opt.Lv6MainArgs.gen_autotest then 
      gen_autotest_files lic_prg main_node opt
    else if opt.gen_ocaml then
      GenOcamlGlue.f Sys.argv opt
    else if (opt.exec || opt.gen_c) then
      (match main_node with
        | None -> (
          let name = find_a_node opt in
          let nk = (Lic.node_key_of_idref (Ident.to_idref name)) in
          if LicPrg.node_exists lic_prg nk then (
            print_string ("WARNING: No main node is specified. I'll try with " ^ name ^"\n");
            flush stdout;
            info "Start compiling to soc...\n";
            let msk,zesoc  = Lic2soc.f lic_prg nk in
            info "Soc Compilation done.\n";
            if opt.gen_c then (
              info "Start generating C code...\n";
              Soc2c.f opt msk zesoc lic_prg);
            if opt.exec then (
              info "Start interpreting soc...\n";
              SocExec.f opt zesoc msk)          
          ) else (
            print_string ("Error: no node is specified, cannot exec.\n");
            flush stdout;
            exit 1
          )
        )
        | Some main_node -> 
          info "Start compiling to soc...\n";
          let msk, zesoc = Lic2soc.f lic_prg (Lic.node_key_of_idref main_node) in

          info "Soc Compilation done. \n";
          if opt.gen_c then (
            info "Start generating C code...\n";
            Soc2c.f opt msk zesoc lic_prg);

          if opt.exec then (
            info "Start interpreting soc...\n";
            SocExec.f opt zesoc msk)
      ) else (
        LicPrg.to_file opt lic_prg main_node
       );

    Verbose.exe ~level:3 (fun () -> Gc.print_stat stdout);
   ) with 
      Sys_error(s) -> prerr_string (s^"\n");  my_exit opt 1
    | Global_error s -> print_global_error s; my_exit opt 1
    | Parse_error -> print_compile_error (Lxm.last_made ()) "syntax error"; my_exit opt 1
    | Unknown_var(lxm,id) -> 
      print_compile_error lxm ("unknown variable (" ^ (Ident.to_string id) ^")");
      my_exit opt 1
    | Unknown_constant(lxm,str) -> 
      print_compile_error lxm ("unknown constant (" ^ str ^")");
      my_exit opt 1
    | Compile_error(lxm,msg) -> print_compile_error lxm msg;  my_exit opt 1
    | L2lCheckLoops.Error(lxm,msg,lic_prg) -> 
      (* Sometime it helps to see the current state of the faulty program *)
      LicPrg.to_file opt lic_prg main_node;
      flush  opt.oc;
      print_compile_error lxm msg;
      my_exit opt 1
    | Assert_failure (file, line, col)  -> 
      prerr_string (
        "\n*** oops: lus2lic internal error\n\tFile \""^ file ^
          "\", line " ^ (string_of_int line) ^ ", column " ^
          (string_of_int col) ^ "\n*** when compiling lustre program" ^
          (if List.length opt.infiles > 1 then "s " else " ") ^
          (String.concat ", " opt.infiles) ^ "\n"^
          "\n*** You migth want to sent a bug report to "^Lv6version.maintainer ^"\n") ; 
      flush stderr;
      my_exit opt 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 *)
  (* ) *)

  close_out opt.oc
    
);;
main();