CristalCaveGem » LustreC

    match Machine_code.get_machine_opt main_node machines with

    | None -> begin

      Global.main_node := main_node;

    end

    | Some m -> begin

      let source_main_file = (if !Options.cpp then destname ^ "_main.cpp" else destname ^ "_main.c") in (* Could be changed *)

    match Machine_code.get_machine_opt mauve machines with

    | None -> begin

      Global.main_node := mauve;

    end

    | Some m -> begin

      let source_mauve_file = destname ^ "_mauve.hpp" in

      begin

	Global.main_node := !Options.main_node;

	Format.eprintf "Code generation error: %a%a@."

	  Location.pp_loc v'.var_loc;

      end

  in

  List.iteri2 (fun idx v' v ->

open LustreSpec

open Corelang

open Graph

type error =

  | NodeCycle of ident list

exception Error of error

   but used to compute useless inputs/mems.

   a mem read var represents a mem at the beginning of a cycle  *)

  let mk_read_var id =

(* instance vars represent node instance calls,

   they are not part of the program/schedule,

   but used to simplify causality analysis

*)

  let mk_instance_var id =

  let is_read_var v = v.[0] = '#'

    (* Add mashup dependencies for a user-defined node instance [lhs] = [f]([e]) *)

    (* i.e every input is connected to every output, through a ghost var *)

      let mashup_appl_dependencies f e g =

	List.fold_right (fun rhs -> add_dep lhs_is_mem (adjust_tuple f_var rhs) rhs)

	  (expr_list_of_expr e) (add_var lhs_is_mem lhs f_var g) 

      in

end

module CycleDetection = struct

  (* ---- Look for cycles in a dependency graph *)

     [Cycle partition] if the succession of dependencies [partition] forms a cycle *)

  let check_cycles g =

    let scc_l = Cycles.scc_list g in

  (* Creates the sub-graph of [g] restricted to vertices and edges in partition *)

  let copy_partition g partition =

    end

end

let pp_dep_graph fmt g =

  begin

    Format.fprintf fmt "{ /* graph */@.";

let pp_error fmt err =

  match err with

  | NodeCycle trace ->

(* Merges elements of graph [g2] into graph [g1] *)

let merge_with g1 g2 =

  begin

  let (g_non_mems, g_mems) = ExprDep.dependence_graph mems inputs node_vars node in

  (*Format.eprintf "g_non_mems: %a" pp_dep_graph g_non_mems;

    Format.eprintf "g_mems: %a" pp_dep_graph g_mems;*)

(* Local Variables: *)

(* compile-command:"make -C .." *)

let check_main () =

  if !Options.main_node = "" then

    begin

    end

let create_dest_dir () =

      raise exc

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

      eprintf "Parsing error: %a%a@."

	Location.pp_loc loc;

      raise exc

    )

    raise exc

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

    eprintf "Parsing error: %a%a@."

      Location.pp_loc loc;

    raise exc

    Automata.expand_decls decls

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

    eprintf "Automata error: %a%a@."

      Location.pp_loc loc;

    raise exc

	raise exc

    end 

  in

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

  new_env

	raise exc

    end

  in

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

  new_env

let import_dependencies prog =

  let dependencies = Corelang.get_dependencies prog in

  let deps =

  List.fold_left

    (fun (compilation_dep, type_env, clock_env) dep ->

      let (local, s) = Corelang.dependency_of_top dep in

      let basename = Options_management.name_dependency (local, s) in

      let lusic = Modules.import_dependency dep.top_decl_loc (local, s) in

      (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "");*)

      let (lusi_type_env, lusi_clock_env) = get_envs_from_top_decls lusic.Lusic.contents in

(*open Dimension*)

module VDeclModule =

struct (* Node module *)

let pp_prog_clock fmt prog =

  Utils.fprintf_list ~sep:"" pp_decl_clock fmt prog

(* filling node table with internal functions *)

let vdecls_of_typ_ck cpt ty =

let copy_prog top_list =

  List.map copy_top top_list

(* Local Variables: *)

(* compile-command:"make -C .." *)

(* End: *)

open LustreSpec

val dummy_type_dec: type_dec

val dummy_clock_dec: clock_dec

val is_eq_expr: expr -> expr -> bool

(* Caution, returns an untyped, unclocked, etc, expression *)

val is_tuple_expr : expr -> bool

val update_expr_annot: ident -> expr -> expr_annot -> expr

(* val mkpredef_call: Location.t -> ident -> eexpr list -> eexpr*)

(* Local Variables: *)

(* compile-command:"make -C .." *)

(* End: *)

    prog []

let check_obsolete lusic basename =

(* encode and write a header in a file *)

let write_lusic lusi (header : top_decl list) basename extension =

  | MComment of string

(* Local Variables: *)

(* compile-command:"make -C .." *)

(* End: *)

  (* Computation of node equation scheduling. It also breaks dependency cycles

     and warns about unused input or memory variables *)

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

  Log.report ~level:1 (fun fmt -> fprintf fmt "%a"              Scheduling.pp_warning_unused node_schs);

  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_schedule node_schs);

  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_fanin_table node_schs);

    Arg.parse options anonymous usage

  with

  | Parse.Error _

  | Sys_error msg -> (eprintf "Failure: %s@." msg)

(* Local Variables: *)

(* compile-command:"make -C .." *)

let add_symbol loc msg hashtbl name value =

 if Hashtbl.mem hashtbl name

 else Hashtbl.add hashtbl name value

let check_symbol loc msg hashtbl name =

 if not (Hashtbl.mem hashtbl name)

 else ()

let add_imported_node name value =

    let itf = value.top_decl_itf in

    match value'.top_decl_desc, value.top_decl_desc with

    | Node _        , ImportedNode _  when owner = owner' && itf' && (not itf) -> Hashtbl.add node_table name value

    | _                                         -> assert false

  with

    Not_found                                   -> Hashtbl.add node_table name value

    let itf = value.top_decl_itf in

    match value'.top_decl_desc, value.top_decl_desc with

    | ImportedNode _, Node _          when owner = owner' && itf' && (not itf) -> ()

    | _                                         -> assert false

  with

    Not_found                                   -> Hashtbl.add node_table name value

let add_tag loc name typ =

  if Hashtbl.mem tag_table name then

  else Hashtbl.add tag_table name typ

let add_field loc name typ =

  if Hashtbl.mem field_table name then

  else Hashtbl.add field_table name typ

let import_typedef name tydef =

    | Tydec_clock ty      -> import ty

    | Tydec_const c       ->

       if not (Hashtbl.mem type_table (Tydec_const c))

       else ()

    | Tydec_array (c, ty) -> import ty

    | _                   -> ()

    let itf = value.top_decl_itf in

    match value'.top_decl_desc, value.top_decl_desc with

    | TypeDef ty', TypeDef ty when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf' && (not itf) -> ()

    | _       -> assert false

  with Not_found -> (import_typedef name value; Hashtbl.add type_table (Tydec_const name) value)

let check_type loc name =

 if not (Hashtbl.mem type_table (Tydec_const name))

 else ()

let add_const itf name value =

    let itf = value.top_decl_itf in

    match value'.top_decl_desc, value.top_decl_desc with

    | Const c', Const c when c.const_value = c'.const_value && owner' = owner && itf' && (not itf) -> ()

    | _       -> assert false

  with Not_found -> Hashtbl.add consts_table name value

  | Sys_error msg ->

    begin

      (*Format.eprintf "Error: %s@." msg;*)

    end

  | Corelang.Error (_, msg) -> raise (Corelang.Error (loc, msg))

  with

  | Corelang.Error (_, err) as exc -> (

    Format.eprintf "Import error: %a%a@."

      Location.pp_loc loc;

    raise exc

  )

  with

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

    Format.eprintf "Import error: %a%a@."

      Location.pp_loc loc;

    raise exc

  )

  with

    Corelang.Error (loc, err) as exc -> (

      Format.eprintf "Import error: %a%a@."

	Location.pp_loc loc;

      raise exc

    );;

  with

    Corelang.Error (loc, err) as exc -> (

      Format.eprintf "Import error: %a%a@."

	Location.pp_loc loc;

      raise exc

    );;

let main_node = ref ""

let static_mem = ref true

let delay_calculus = ref true

let track_exceptions = ref true

let ansi = ref false

let gen_mcdc = ref false

let no_mutation_suffix = ref false

(* Local Variables: *)

(* compile-command:"make -C .." *)

let schedule_node n =

  (* let node_vars = get_node_vars n in *)

     compute: coi predecessors of outputs

     warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output)

let compute_node_reuse_table report =

  let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in