CristalCaveGem » LustreC

LUSI_MPFR_LIB=include/mpfr_lustre.lusi

$(LOCAL_BINDIR)/lustrec: configure Makefile

	@$(OCAMLBUILD) -cflags -I,@OCAMLGRAPH_PATH@ -lflag @OCAMLGRAPH_PATH@/graph.cmxa -lflag nums.cmxa -I src -I src/backends/C -I src/plugins/scopes src/main_lustre_compiler.native

configure: configure.ac

	@echo configure.ac has changed relaunching autoconf

	@autoconf

Makefile: Makefile.in config.status configure

	@echo Makefile.in has changed relaunching autoconf

	@./config.status --recheck

dist-src-clean: clean

	@rm -f config.log config.status include/*.lusic include/math.h include/conv.h include/mpfr_lustre.h

DIST_ARCHIVE_NAME=lustrec-$(shell $(LOCAL_BINDIR)/lustrec -version | grep version | cut -d, -f 2 | sed -e "s/ version //" -e "s/ (/-/" -e "s/ /-/" -e "s/\//-/" -e "s/)//")-src.tar.gz

dist-gzip: $(LOCAL_BINDIR)/lustrec dist-src-clean

	@rm -f $(shell ls ../*lustrec*src*tar.gz)

	@tar zcvf ../$(DIST_ARCHIVE_NAME) -C .. --exclude-vcs --exclude=Makefile  --exclude=$(LOCAL_BINDIR) $(shell basename $(PWD))

	@echo "Source distribution built: ../$(DIST_ARCHIVE_NAME)"

dist-clean: dist-src-clean

	@rm -f myocamlbuild.ml configure Makefile

	@rm -f $(LUSI_MPFR_LIB:%.lusi=%.lusic)

compile-mpfr-lusi: $(LUSI_MPFR_LIB)

	@echo Compiling $<

	@$(LOCAL_BINDIR)/lustrec -verbose 0 -mpfr 1 -d include $<

install: clean-lusic compile-lusi compile-mpfr-lusi

define([gitversion], esyscmd([sh -c "git log --oneline | wc -l | tr -d '\n'"]))

AC_INIT([lustrec], [1.3-gitversion], [ploc@garoche.net])

AC_SUBST(VERSION_CODENAME, "Xia/Zhong-Kang-dev")

# Next release will be

#AC_INIT([lustrec], [1.3], [ploc@garoche.net])

#AC_SUBST(VERSION_CODENAME, "Xia/Zhong-Kang")

#AC_DEFINE(SVN_REVISION, "svnversion", [SVN Revision])

#AC_SUBST(SVN_REVISION)

AC_SUBST(SRC_PATH, esyscmd([sh -c "pwd" | tr -d '\n']))

if (test "$major" -lt 4 -a "$minor" -lt 0 ); then

  AC_MSG_ERROR([Ocaml version must be at least 4.0. You have version $ocamlc_version])

	ocamlgraph_lib_full=`find $OCAMLGRAPH_PATH -iname graph.cmxa | grep -m 1 "graph.cmxa"`

AC_CHECK_LIB(gmp, __gmpz_init, 

      [gmp=yes],

      [AC_MSG_RESULT([GNU MP not found])

      gmp=no])

AC_CHECK_LIB(mpfr, mpfr_add, [mpfr=yes], 

		   [AC_MSG_RESULT(

[MPFR not found])

mpfr=no])

		 src/version.ml

		 test/test-compile.sh

		 ])

AC_MSG_NOTICE(******** Configuration ********)

AC_MSG_NOTICE(bin path:     $prefix/bin)

AC_MSG_NOTICE(include path: $prefix/include)

AC_MSG_NOTICE(********    Plugins    ********)

  if (test "x$gmp" = xyes -a "x$mpfr" = xyes ); then

       AC_MSG_NOTICE([-mpfr option enable])

   else 

       AC_MSG_WARN([MPFR option cannot be activated. Requires GMP and MPFR libs])

   fi

AC_MSG_NOTICE

AC_MSG_NOTICE(******** Configuration ********)

#define _arrow_init(self) {}

#define _arrow_clear(self) {}

OCAMLBUILD=/opt/local/bin/ocamlbuild -classic-display -use-ocamlfind -no-links 

prefix=/Users/Teme/Documents/GitHub/lustrec/cocosim

OCAMLBUILD=@OCAMLBUILD@ -classic-display -use-ocamlfind -no-links 

  let var_inputs = aut_state.incoming_r (*:: aut_state.incoming_s*) :: (node_vars_of_idents node inputs) in

  let init_expr = mkpair handler.hand_loc (mkident handler.hand_loc aut_state.incoming_r.var_id) (mkconst handler.hand_loc handler.hand_state) in

(*  let init_expr = mkidentpair handler.hand_loc aut_state.incoming_r.var_id aut_state.incoming_s.var_id in *)

  let expr_outputs = List.fold_right add_branch handler.hand_unless init_expr in

  let var_inputs = aut_state.actual_r (*:: aut_state.actual_s*) :: node_vars_of_idents node inputs in

  let init_until = mkpair handler.hand_loc (mkconst handler.hand_loc tag_false) (mkconst handler.hand_loc handler.hand_state) in

  let until_expr = List.fold_right add_branch handler.hand_until init_until in

let gen_files funs basename prog machines dependencies =

  let destname = !Options.dest_dir ^ "/" ^ basename in

  let source_main_file = destname ^ "_main.c" in (* Could be changed *)

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

  let alloc_header_file = destname ^ "_alloc.h" in (* Could be changed *)

  let header_out = open_out alloc_header_file in

  let header_fmt = formatter_of_out_channel header_out in

  close_out header_out;

  let source_lib_file = destname ^ ".c" in (* Could be changed *)

  let source_lib_out = open_out source_lib_file in

  let source_lib_fmt = formatter_of_out_channel source_lib_out in

  | "" ->  () (* No main node: we do not generate main nor makefile *)

    | None -> begin

      Global.main_node := main_node;

      Format.eprintf "Code generation error: %a@." Corelang.pp_error LustreSpec.Main_not_found;

      raise (Corelang.Error (Location.dummy_loc, LustreSpec.Main_not_found))

    end

      print_makefile basename main_node dependencies makefile_fmt;

let translate_to_c basename prog machines dependencies =

    gen_files funs basename prog machines dependencies 

    gen_files funs basename prog machines dependencies 

    "/* @[<v>C code generated by %s@,Version number %s@,Code is %s compliant@,Using %s numbers */@,@]@."

    (if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")

let file_to_module_name basename =

  let baseNAME = String.uppercase basename in

  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in

  baseNAME

let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id

let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id

let pp_machine_init_name fmt id = fprintf fmt "%s_init" id

let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id

  | Types.Tbool                    -> fprintf fmt "_Bool"

  | Types.Treal when !Options.mpfr -> fprintf fmt "%s" Mpfr.mpfr_t

  | Types.Treal                    -> fprintf fmt "double"

  | Types.Tint                     -> fprintf fmt "int"

    | Types.Tbool | Types.Tint | Types.Treal

(*

  | Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."

 *)

    | Const_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*)

    (* | Const_float r   -> pp_print_float fmt r *)

  match v.value_desc with

    if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr)

  (* mpfr_t is a static array, not treated as general arrays *)

    if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr)

    fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "

      (Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory

      fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."

	(Utils.pp_final_char_if_non_empty "@ " m.mmemory)

	(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances

	(Utils.pp_final_char_if_non_empty ";@ " m.minstances)

let print_global_init_prototype fmt baseNAME =

  fprintf fmt "void %a ()"

    pp_global_init_name baseNAME

let print_global_clear_prototype fmt baseNAME =

  fprintf fmt "void %a ()"

    pp_global_clear_name baseNAME

let print_init_prototype self fmt (name, static) =

  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"

    pp_machine_init_name name

    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static

    (Utils.pp_final_char_if_non_empty ",@," static) 

    pp_machine_memtype_name name

    self

let print_clear_prototype self fmt (name, static) =

  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"

    pp_machine_clear_name name

    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static

    (Utils.pp_final_char_if_non_empty ",@," static) 

    pp_machine_memtype_name name

    self

let print_import_init fmt (Dep (local, basename, _, _)) =

  if local then

    let baseNAME = file_to_module_name basename in

    fprintf fmt "%a();" pp_global_init_name baseNAME

  else ()

let print_import_clear fmt (Dep (local, basename, _, _)) =

  if local then

    let baseNAME = file_to_module_name basename in

    fprintf fmt "%a();" pp_global_clear_name baseNAME

  else ()

let pp_c_main_var_input fmt id =  

  fprintf fmt "%s" id.var_id

let pp_c_main_var_output fmt id =

  if Types.is_address_type id.var_type

  then

    fprintf fmt "%s" id.var_id

  else

    fprintf fmt "&%s" id.var_id

let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =

  if fst (get_stateless_status m)

  then

    fprintf fmt "%a (%a%t%a);"

      pp_machine_step_name mname

      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs

      (Utils.pp_final_char_if_non_empty ", " inputs) 

      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs

  else

    fprintf fmt "%a (%a%t%a%t%s);"

      pp_machine_step_name mname

      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs

      (Utils.pp_final_char_if_non_empty ", " inputs) 

      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs

      (Utils.pp_final_char_if_non_empty ", " outputs)

      self

let pp_c_var m self pp_var fmt var =

  if is_memory m var

  then

    pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)

  else

    pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)

let pp_array_suffix fmt loop_vars =

  Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars

(* type directed initialization: useless wrt the lustre compilation model,

   except for MPFR injection, where values are dynamically allocated

*)

let pp_initialize m self pp_var fmt var =

  let rec aux indices fmt typ =

    if Types.is_array_type typ

    then

      let dim = Types.array_type_dimension typ in

      let idx = mk_loop_var m () in

      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"

	idx idx idx pp_c_dimension dim idx

	(aux (idx::indices)) (Types.array_element_type typ)

    else

      let indices = List.rev indices in

      let pp_var_suffix fmt var =

	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in

      Mpfr.pp_inject_init pp_var_suffix fmt var

  in

  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)

  then

    begin

      reset_loop_counter ();

      aux [] fmt var.var_type

    end

let pp_const_initialize pp_var fmt const =

  let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in

  let rec aux indices value fmt typ =

    if Types.is_array_type typ

    then

      let dim = Types.array_type_dimension typ in

      let szl = Utils.enumerate (Dimension.size_const_dimension dim) in

      let typ' = Types.array_element_type typ in

      let value = match value with

	| Const_array ca -> List.nth ca

	| _                      -> assert false in

      fprintf fmt "%a"

	(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl

    else

      let indices = List.rev indices in

      let pp_var_suffix fmt var =

	fprintf fmt "%a%a" (pp_c_val "" pp_var) var pp_array_suffix indices in

      begin

	Mpfr.pp_inject_init pp_var_suffix fmt var;

	fprintf fmt "@,";

	Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value

      end

  in

  if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type)

  then

    begin

      reset_loop_counter ();

      aux [] const.const_value fmt const.const_type

    end

(* type directed clear: useless wrt the lustre compilation model,

   except for MPFR injection, where values are dynamically allocated

*)

let pp_clear m self pp_var fmt var =

  let rec aux indices fmt typ =

    if Types.is_array_type typ

    then

      let dim = Types.array_type_dimension typ in

      let idx = mk_loop_var m () in

      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"

	idx idx idx pp_c_dimension dim idx

	(aux (idx::indices)) (Types.array_element_type typ)

    else

      let indices = List.rev indices in

      let pp_var_suffix fmt var =

	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in

      Mpfr.pp_inject_clear pp_var_suffix fmt var

  in

  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)

  then

    begin

      reset_loop_counter ();

      aux [] fmt var.var_type

    end

let pp_const_clear pp_var fmt const =

  let m = Machine_code.empty_machine in

  let var = Corelang.var_decl_of_const const in

  let rec aux indices fmt typ =

    if Types.is_array_type typ

    then

      let dim = Types.array_type_dimension typ in

      let idx = mk_loop_var m () in

      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"

	idx idx idx pp_c_dimension dim idx

	(aux (idx::indices)) (Types.array_element_type typ)

    else

      let indices = List.rev indices in

      let pp_var_suffix fmt var =

	fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in

      Mpfr.pp_inject_clear pp_var_suffix fmt var 

  in

  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)

  then

    begin

      reset_loop_counter ();

      aux [] fmt var.var_type

    end

let pp_call m self pp_read pp_write fmt i (inputs: value_t list) (outputs: var_decl list) =

 try (* stateful node instance *)

   let (n,_) = List.assoc i m.minstances in

   fprintf fmt "%a (%a%t%a%t%s->%s);"

     pp_machine_step_name (node_name n)

     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs

     (Utils.pp_final_char_if_non_empty ", " inputs) 

     (Utils.fprintf_list ~sep:", " pp_write) outputs

     (Utils.pp_final_char_if_non_empty ", " outputs)

     self

     i

 with Not_found -> (* stateless node instance *)

   let (n,_) = List.assoc i m.mcalls in

   fprintf fmt "%a (%a%t%a);"

     pp_machine_step_name (node_name n)

     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs

     (Utils.pp_final_char_if_non_empty ", " inputs) 

     (Utils.fprintf_list ~sep:", " pp_write) outputs 

let pp_basic_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =

  pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs

(*

 try (* stateful node instance *)

   let (n,_) = List.assoc i m.minstances in

   fprintf fmt "%a (%a%t%a%t%s->%s);"

     pp_machine_step_name (node_name n)

     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs

     (Utils.pp_final_char_if_non_empty ", " inputs) 

     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs

     (Utils.pp_final_char_if_non_empty ", " outputs)

     self

     i

 with Not_found -> (* stateless node instance *)

   let (n,_) = List.assoc i m.mcalls in

   fprintf fmt "%a (%a%t%a);"

     pp_machine_step_name (node_name n)

     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs

     (Utils.pp_final_char_if_non_empty ", " inputs) 

     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 

*)

let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =

  let pp_offset pp_var indices fmt var =

    match indices with

    | [] -> fprintf fmt "%a" pp_var var

    | _  -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in

  let rec aux indices fmt typ =

    if Types.is_array_type typ

    then

      let dim = Types.array_type_dimension typ in

      let idx = mk_loop_var m () in

      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"

	idx idx idx pp_c_dimension dim idx

	(aux (idx::indices)) (Types.array_element_type typ)

    else

      let pp_read  = pp_offset (pp_c_var_read  m) indices in

      let pp_write = pp_offset (pp_c_var_write m) indices in

      pp_call m self pp_read pp_write fmt i inputs outputs

  in

  begin

    reset_loop_counter ();

    aux [] fmt (List.hd inputs).value_type

  end

  begin

    if !Options.mpfr then

      begin

	fprintf fmt "#include <mpfr.h>@."

      end;

    fprintf fmt "#include \"%s/arrow.h\"@.@." Version.include_path

  end

  match v.value_desc with

  begin

    Mod.print_machine_decl_prefix fmt m;

    if fst (get_stateless_status m) then

      begin

	fprintf fmt "extern %a;@.@."

	  print_stateless_prototype

	  (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)

      end

    else

      begin

        (* Static allocation *)

	if !Options.static_mem

	then

	  begin

	    let inst = mk_instance m in

	    let attr = mk_attribute m in

	    fprintf fmt "%a@.%a@.%a@."

	      print_static_declare_macro (m, attr, inst)

	      print_static_link_macro (m, attr, inst)

	      print_static_alloc_macro (m, attr, inst)

	  end

	else

	  begin 

            (* Dynamic allocation *)

	    fprintf fmt "extern %a;@.@."

	      print_alloc_prototype (m.mname.node_id, m.mstatic)

	  end;

	let self = mk_self m in

	fprintf fmt "extern %a;@.@."

	  (print_reset_prototype self) (m.mname.node_id, m.mstatic);

	fprintf fmt "extern %a;@.@."

	  (print_step_prototype self)

	  (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs);

	if !Options.mpfr then

	  begin

	    fprintf fmt "extern %a;@.@."

	      (print_init_prototype self) (m.mname.node_id, m.mstatic);

	    fprintf fmt "extern %a;@.@."

	      (print_clear_prototype self) (m.mname.node_id, m.mstatic);

	  end

      end

  end

    else (Format.eprintf "internal error: print_machine_decl_from_header"; assert false)

	fprintf fmt "extern %a;@.@."

	  (print_init_prototype self) (inode.nodei_id, static_inputs);

	fprintf fmt "extern %a;@.@."

	  (print_clear_prototype self) (inode.nodei_id, static_inputs);

  if !Options.mpfr &&  Types.is_real_type (Types.array_base_type cdecl.const_type)

  then

    fprintf fmt "extern %a;@." 

      (pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) 

  else

    fprintf fmt "extern %a;@." 

      (pp_c_type cdecl.const_id) cdecl.const_type

  | Tydec_real when !Options.mpfr

                        -> fprintf fmt "%s %s" Mpfr.mpfr_t var

  (* | Tydec_float         -> fprintf fmt "float %s" var *)

  let baseNAME = file_to_module_name basename in

    (* Print the version number and the supported C standard (C90 or C99) *)

    fprintf header_fmt "/* Import dependencies */@.";

    if !Options.mpfr then

      begin

	fprintf header_fmt "/* Global initialization declaration */@.";

	fprintf header_fmt "extern %a;@.@."

	  print_global_init_prototype baseNAME;

	fprintf header_fmt "/* Global clear declaration */@.";

	fprintf header_fmt "extern %a;@.@."

	  print_global_clear_prototype baseNAME;

      end;

    fprintf header_fmt "/* Structs declarations */@.";

  let baseNAME = file_to_module_name basename in

  let baseNAME = file_to_module_name basename in

    (* Print the version number and the supported C standard (C90 or C99) *)

    if !Options.mpfr then

      begin

	fprintf header_fmt "/* Global initialization declaration */@.";

	fprintf header_fmt "extern %a;@.@."

	  print_global_init_prototype baseNAME;

	fprintf header_fmt "/* Global clear declaration */@.";

	fprintf header_fmt "extern %a;@.@."

	  print_global_clear_prototype baseNAME;

      end;

    fprintf header_fmt "/* Structs declarations */@.";

let print_get_inputs fmt m =

  let pi fmt (v', v) =

  match (Types.unclock_type v.var_type).Types.tdesc with

    | Types.Tint -> fprintf fmt "%s = _get_int(\"%s\")" v.var_id v'.var_id

    | Types.Tbool -> fprintf fmt "%s = _get_bool(\"%s\")" v.var_id v'.var_id

    | Types.Treal when !Options.mpfr -> fprintf fmt "mpfr_set_d(%s, _get_double(\"%s\"), %i)" v.var_id v'.var_id (Mpfr.mpfr_prec ())

    | Types.Treal -> fprintf fmt "%s = _get_double(\"%s\")" v.var_id v'.var_id

    | _ ->

      begin

	Global.main_node := !Options.main_node;

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

	  pp_error Main_wrong_kind

	  Location.pp_loc v'.var_loc;

	raise (Error (v'.var_loc, Main_wrong_kind))

      end

  in

  List.iter2 (fun v' v -> fprintf fmt "@ %a;" pi (v', v)) m.mname.node_inputs m.mstep.step_inputs

let print_put_outputs fmt m = 

  let po fmt (o', o) =

    match (Types.unclock_type o.var_type).Types.tdesc with

    | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o'.var_id o.var_id

    | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o'.var_id o.var_id

    | Types.Treal when !Options.mpfr -> fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s))" o'.var_id o.var_id (Mpfr.mpfr_rnd ())

    | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o'.var_id o.var_id

  List.iter2 (fun v' v -> fprintf fmt "@ %a;" po (v', v)) m.mname.node_outputs m.mstep.step_outputs

let print_main_inout_declaration fmt m =

  begin

    fprintf fmt "/* Declaration of inputs/outputs variables */@ ";

    List.iter 

      (fun v -> fprintf fmt "%a;@ " (pp_c_type v.var_id) v.var_type

      ) m.mstep.step_inputs;

    List.iter 

      (fun v -> fprintf fmt "%a;@ " (pp_c_type v.var_id) v.var_type

      ) m.mstep.step_outputs

  end

let print_main_memory_allocation mname main_mem fmt m =

  if not (fst (get_stateless_status m)) then

  begin  

    fprintf fmt "@ /* Main memory allocation */@ ";

    if (!Options.static_mem && !Options.main_node <> "")

    then (fprintf fmt "%a(static,main_mem);@ " pp_machine_static_alloc_name mname)

    else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname);

    fprintf fmt "@ /* Initialize the main memory */@ ";

    fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;

  end

let print_global_initialize fmt basename =

  let mNAME = file_to_module_name basename in

  fprintf fmt "@ /* Initialize global constants */@ %a();@ "

    pp_global_init_name mNAME

let print_global_clear fmt basename =

  let mNAME = file_to_module_name basename in

  fprintf fmt "@ /* Clear global constants */@ %a();@ "

    pp_global_clear_name mNAME

let print_main_initialize mname main_mem fmt m =

  if not (fst (get_stateless_status m))

  then

    fprintf fmt "@ /* Initialize inputs, outputs and memories */@ %a%t%a%t%a(%s);@ "

      (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_inputs

      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)

      (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_outputs

      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)

      pp_machine_init_name mname

      main_mem

  else

    fprintf fmt "@ /* Initialize inputs and outputs */@ %a%t%a@ "

      (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_inputs

      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)

      (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_outputs

let print_main_clear mname main_mem fmt m =

  if not (fst (get_stateless_status m))

  then

    fprintf fmt "@ /* Clear inputs, outputs and memories */@ %a%t%a%t%a(%s);@ "

      (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_inputs

      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)

      (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_outputs

      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)

      pp_machine_clear_name mname

      main_mem

  else

    fprintf fmt "@ /* Clear inputs and outputs */@ %a%t%a@ "

      (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_inputs

      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)

      (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_outputs

let print_main_loop mname main_mem fmt m =

  let input_values =

    List.map (fun v -> mk_val (LocalVar v) v.var_type)

      m.mstep.step_inputs in

  begin

    fprintf fmt "@ ISATTY = isatty(0);@ ";

    fprintf fmt "@ /* Infinite loop */@ ";

    fprintf fmt "@[<v 2>while(1){@ ";

    fprintf fmt  "fflush(stdout);@ ";

    fprintf fmt "%a@ %t%a"

      print_get_inputs m

      (fun fmt -> pp_main_call mname main_mem fmt m input_values m.mstep.step_outputs)

      print_put_outputs m

  end

let print_main_code fmt basename m =

  print_main_inout_declaration fmt m;

  print_main_memory_allocation mname main_mem fmt m;

  if !Options.mpfr then

    begin

      print_global_initialize fmt basename;

      print_main_initialize mname main_mem fmt m;

    end;

  print_main_loop mname main_mem fmt m;

  if Scopes.Plugin.is_active () then

    begin

      fprintf fmt "@ %t" Scopes.Plugin.pp 

    end;    

  fprintf fmt "@]@ }@ @ ";

  if !Options.mpfr then

    begin

      print_main_clear mname main_mem fmt m;

      print_global_clear fmt basename;

    end;

  fprintf fmt "@ return 1;";

  print_main_code main_fmt basename main_machine

      | ImportedNode nd -> nd.nodei_in_lib = []

      | ImportedNode nd -> Utils.list_union nd.nodei_in_lib accu

  fprintf fmt "%s_%s: %s.c %s_main.c@." basename nodename basename basename;

  fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s.c@." basename;  

  fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s_main.c@." basename;   

  fprintf fmt "\t${GCC} -O0 -o %s_%s io_frontend.o %a %s.o %s_main.o %a@." basename nodename 

 fprintf fmt ".PHONY: %s_%s@." basename nodename;

 fprintf fmt "@.";

  let rec expansion_depth v =

    match v.value_desc with

    | Cst cst -> expansion_depth_cst cst

    | LocalVar _

    | StateVar _  -> 0

    | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0

    | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0

    | Access (v, i) -> max 0 (expansion_depth v - 1)

    | Power (v, n)  -> 0 (*1 + expansion_depth v*)

  and expansion_depth_cst c = 

    match c with

      Const_array cl -> 1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0

    | _ -> 0

  let rec merge_static_loop_profiles lp1 lp2 =

    match lp1, lp2 with

    | []      , _        -> lp2

    | _       , []       -> lp1

    | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2

  let rec static_loop_profile v =

    match v.value_desc with

    | Cst cst  -> static_loop_profile_cst cst

    | LocalVar _

    | StateVar _  -> []

    | Fun (_, vl) -> List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []

    | Array vl    -> true :: List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []

    | Access (v, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q)

    | Power (v, n)  -> false :: static_loop_profile v

  and static_loop_profile_cst cst =

    match cst with

      Const_array cl -> List.fold_right 

	(fun c lp -> merge_static_loop_profiles lp (static_loop_profile_cst c))

	cl 

	[]

    | _ -> [] 

  match v.value_desc with

 | LAcc i -> fprintf fmt "[%a]" pp_val i

    | Const_int i          -> pp_print_int fmt i

    | Const_real (_, _, s) -> pp_print_string fmt s

    | Const_tag t          -> pp_c_tag fmt t

    | Const_array ca       -> let var_type = Types.array_element_type var_type in

                              fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca

    | Const_struct fl       -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)) fl

    | Const_string _        -> assert false (* string occurs in annotations not in C *)

 (*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)

 match loop_vars, value.value_desc with

   pp_value_suffix self var_type q pp_value fmt (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)

let pp_c_val self pp_var fmt v =

  pp_value_suffix self v.value_type [] pp_var fmt v

let pp_basic_assign pp_var fmt typ var_name value =

  if Types.is_real_type typ && !Options.mpfr

  then

    Mpfr.pp_inject_assign pp_var fmt var_name value

  else

    fprintf fmt "%a = %a;" 

      pp_var var_name

      pp_var value

  (*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)

  let rec aux typ fmt vars =

       pp_basic_assign (pp_value_suffix self var_type loop_vars pp_var) fmt typ var_name value

       let typ' = Types.array_element_type typ in

      (*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)

	i i i pp_c_dimension d i

	(aux typ') q

       (*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)

       let typ' = Types.array_element_type typ in

       let szl = Utils.enumerate (Dimension.size_const_dimension d) in

       fprintf fmt "@[<v 2>{@,%a@]@,}"

	       (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl

    aux var_type fmt reordered_loop_vars;

    (*Format.eprintf "end pp_assign@.";*)

let pp_machine_reset (m: machine_t) self fmt inst =

  let (node, static) =

    try

      List.assoc inst m.minstances

    with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in

  fprintf fmt "%a(%a%t%s->%s);"

    pp_machine_reset_name (node_name node)