CristalCaveGem » LustreC

let type_decls env decls =  

  report ~level:1 (fun fmt -> fprintf fmt ".. typing@,@?");

  let new_env = 

    begin

      try

	Typing.type_prog env decls

    (*Typing.uneval_prog_generics prog*)

      with (Types.Error (loc,err)) as exc ->

	Format.eprintf "Typing error at loc %a: %a@]@."

	  Location.pp_loc loc

	  Types.pp_error err;

	raise exc

    end 

  in

  if !Options.print_types then

    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_type decls);

  new_env

let clock_decls env decls = 

  report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@,@?");

  let new_env =

    begin

      try

	Clock_calculus.clock_prog env decls

      with (Clocks.Error (loc,err)) as exc ->

	Location.print loc;

	eprintf "Clock calculus error at loc %a: %a@]@." Location.pp_loc loc Clocks.pp_error err;

	raise exc

    end

  in

  if !Options.print_clocks then

    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_clock decls);

  new_env

(* Loading Lusi file and filing type tables with parsed

   functions/nodes *)

let load_lusi filename =

  Location.input_name := filename;

  let lexbuf = Lexing.from_channel (open_in filename) in

  Location.init lexbuf filename;

  (* Parsing *)

  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing header file %s@,@?" filename);

  let header = 

    try

      Parse.prog Parser_lustre.header Lexer_lustre.token lexbuf

    with (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 

      Parse.report_error err;

      raise exc

  in

  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)

  let new_cenv: Clocks.clock_expr Utils.IMap.t = clock_decls Basic_library.clock_env header in   (* Clock calculus *)

  header, new_tenv, new_cenv

  (* Loading the input file *)

  report ~level:1 

    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);

  (* Extracting dependencies *)

  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");

  let dependencies = 

      (fun d accu -> match d.Corelang.top_decl_desc with 

      | Corelang.Open s -> s::accu 

      | _ -> accu) 

  let type_env, clock_env =

    List.fold_left (fun (type_env, clock_env) s -> 

      try

	let basename = s ^ ".lusi" in 

	report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>Library %s@ " s);

	let _, lusi_type_env, lusi_clock_env = load_lusi basename in 

	report ~level:1 (fun fmt -> fprintf fmt "@]@,@?");

	Env.overwrite type_env lusi_type_env,

	Env.overwrite clock_env lusi_clock_env      

      with Sys_error msg -> (

	Format.eprintf "Failure: impossible to load library %s.@.%s@." s msg;

	exit 1

      )

    )  (Basic_library.type_env, Basic_library.clock_env) dependencies

  in

  let computed_types_env = type_decls type_env prog in

  let computed_clocks_env = clock_decls clock_env prog in

  (*

    if(!Options.delay_calculus)

    then

    report ~level:1 (fun fmt -> fprintf fmt ".. initialisation analysis@?");

    try

    Delay_calculus.delay_prog Basic_library.delay_env prog

    with (Delay.Error (loc,err)) as exc ->

    Location.print loc;

    eprintf "%a" Delay.pp_error err;

    Utils.track_exception ();

    raise exc

  *)

    (* Causality analysis *)

    machine_code);

  (* Checking the existence of a lusi (Lustre Interface file) *)

  let lusi_name = basename ^ ".lusi" in

  let _ = 

    try 

      let _ = open_in lusi_name in

      let _, declared_types_env, declared_clocks_env = load_lusi lusi_name in

      (* checking type compatibilty with computed types*)

      Typing.check_env_compat declared_types_env computed_types_env;

      (* checking clocks compatibilty with computed clocks*)

      Clock_calculus.check_env_compat declared_clocks_env computed_clocks_env;

    with Sys_error _ -> ( 

      (* Printing lusi file is necessary *)

      report ~level:1 

	(fun fmt -> 

	  fprintf fmt 

	    ".. generating lustre interface file %s@,@?" lusi_name);

      let lusi_out = open_out lusi_name in

      let lusi_fmt = formatter_of_out_channel lusi_out in

      Printers.pp_lusi_header lusi_fmt source_name normalized_prog

    )

    | (Types.Error (loc,err)) as exc ->

      Format.eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@]@."

	Types.pp_error err;

      raise exc

  in

      report ~level:1 (fun fmt -> fprintf fmt ".. opening file %s@,@?" source_file);

      let source_out = open_out source_file in

      let source_fmt = formatter_of_out_channel source_out in

      report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");

      Java_backend.translate_to_java source_fmt basename normalized_prog machine_code;*)

    let makefile_file = basename ^ ".makefile" in (* Could be changed *)

    let makefile_out = open_out makefile_file in

    let makefile_fmt = formatter_of_out_channel makefile_out in

    C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename normalized_prog machine_code;