some rewriting in C backend pretty-printer

src/backends/C/c_backend.ml

@@ -9,7 +9,7 @@
 (*                                                                  *)
 (********************************************************************)
 
-open Format
+open Utils.Format
 open C_backend_mauve
 (******************************************************************************)
 (*                        Translation function                                *)
@@ -26,12 +26,6 @@ let makefile_opt print basename dependencies makefile_fmt machines =
   )
 *)
 
-let with_out_file file f =
-  let oc = open_out file in
-  let fmt = formatter_of_out_channel oc in
-  f fmt;
-  close_out oc
-
 let c_or_cpp f =
   if !Options.cpp then f ^ ".cpp" else f ^ ".c" (* Could be changed *)
 

src/backends/C/c_backend_lusic.ml

 open Lusic
+open Utils.Format
 
 let print_lusic_to_h basename extension =
-let module HeaderMod = C_backend_header.EmptyMod in
-let module Header = C_backend_header.Main (HeaderMod) in
+  let module HeaderMod = C_backend_header.EmptyMod in
+  let module Header = C_backend_header.Main (HeaderMod) in
   let lusic = read_lusic basename extension in
   let header_name = basename ^ ".h" in
-  let h_out = open_out header_name in
-  let h_fmt = Format.formatter_of_out_channel h_out in
-  begin
-    assert (not lusic.obsolete);
-    (*Format.eprintf "lusic to h: %i items.@." (List.length lusic.contents);*)
-    (* Typing.uneval_prog_generics lusic.contents;
+  with_out_file header_name @@ fun h_fmt ->
+  assert (not lusic.obsolete);
+  (*Format.eprintf "lusic to h: %i items.@." (List.length lusic.contents);*)
+  (* Typing.uneval_prog_generics lusic.contents;
      * Clock_calculus.uneval_prog_generics lusic.contents; *)
-    Header.print_header_from_header h_fmt (Filename.basename basename) lusic.contents;
-    close_out h_out
-  end
-
+  Header.print_header_from_header
+    h_fmt
+    (Filename.basename basename)
+    lusic.contents

src/backends/C/c_backend_main.ml

@@ -12,209 +12,375 @@
 open Lustre_types
 open Machine_code_types
 open Machine_code_common
-open Format
+open Utils.Format
 open C_backend_common
 open Utils
 
-module type MODIFIERS_MAINSRC =
-sig
+module type MODIFIERS_MAINSRC = sig
 end
 
-module EmptyMod =
-struct
+module EmptyMod = struct
 end
 
-module Main = functor (Mod: MODIFIERS_MAINSRC) -> 
-struct
+module Main = functor (Mod: MODIFIERS_MAINSRC) -> struct
 
-(********************************************************************************************)
-(*                         Main related functions                                           *)
-(********************************************************************************************)
+  (********************************************************************************************)
+  (*                         Main related functions                                           *)
+  (********************************************************************************************)
 
+  let pp_c_main_var_input fmt id =
+    fprintf fmt "%s" id.var_id
 
-let print_put_outputs fmt m = 
-  let po fmt (id, o', o) =
-    let suff = string_of_int id in
+  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 print_put_output fmt id o' o =
+    let suff = string_of_int (id + 1) in
     print_put_var fmt suff o'.var_id o.var_type o.var_id
-  in
-  List.iteri2 (fun idx v' v -> fprintf fmt "@ %a;" po ((idx+1), v', v)) m.mname.node_outputs m.mstep.step_outputs
-
-  
-let print_main_inout_declaration m fmt =
-  fprintf fmt "/* Declaration of inputs/outputs variables */@ ";
-  List.iteri (fun idx v ->
-      fprintf fmt "%a;@ " (pp_c_type v.var_id) v.var_type;
-      ignore (pp_file_decl fmt "in" idx) 
-    ) m.mstep.step_inputs;
-  List.iteri (fun idx v ->
-      fprintf fmt "%a;@ " (pp_c_type v.var_id) v.var_type;
-      ignore (pp_file_decl fmt "out" idx)
-    ) m.mstep.step_outputs;
-  fprintf fmt "@[<v 2>if (traces) {@ ";
-  List.iteri (fun idx _ ->
-      ignore (pp_file_open fmt "in" idx) 
-    ) m.mstep.step_inputs;
-  List.iteri (fun idx _ ->
-      ignore (pp_file_open fmt "out" idx)
-    ) m.mstep.step_outputs;
-  fprintf fmt "@]}@ "
-
-  
-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))
+  let print_main_inout_declaration fmt m =
+    fprintf fmt
+      "/* Declaration of inputs/outputs variables */@,\
+       %a%a\
+       @[<v 2>if (traces) {@,\
+       %a%a@]@,\
+       }"
+      (pp_print_list_i
+         ~pp_open_box:pp_open_vbox0
+         ~pp_epilogue:pp_print_cut
+         (fun fmt idx v ->
+            fprintf fmt "%a; %a"
+              (pp_c_type v.var_id) v.var_type
+              (fun fmt () -> pp_file_decl fmt "in" idx) ())) m.mstep.step_inputs
+      (pp_print_list_i
+         ~pp_open_box:pp_open_vbox0
+         ~pp_epilogue:pp_print_cut
+         (fun fmt idx v ->
+            fprintf fmt "%a; %a"
+              (pp_c_type v.var_id) v.var_type
+              (fun fmt () -> pp_file_decl fmt "out" idx) ())) m.mstep.step_outputs
+      (pp_print_list_i
+         ~pp_epilogue:pp_print_cut
+         (fun fmt idx _ ->
+            ignore (pp_file_open fmt "in" idx))) m.mstep.step_inputs
+      (pp_print_list_i
+         (fun fmt idx _ ->
+            ignore (pp_file_open fmt "out" idx))) m.mstep.step_outputs
+
+  let print_main_memory_allocation mname main_mem fmt m =
+    if not (fst (get_stateless_status m)) then
+      fprintf fmt
+        "@[<v>/* Main memory allocation */@,\
+         %a@,\
+         @,\
+         /* Initialize the main memory */@,\
+         %a(%s);@]"
+        (fun fmt () ->
+           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) ()
+        pp_machine_reset_name mname
+        main_mem
+
+  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 =
+    let inputs = mpfr_vars m.mstep.step_inputs in
+    let outputs = mpfr_vars m.mstep.step_outputs in
+    if not (fst (get_stateless_status m))
+    then
+      fprintf fmt
+        "/* Initialize inputs, outputs and memories */@,\
+         %a%a%a(%s);"
+        (pp_print_list
+           ~pp_open_box:pp_open_vbox0
+           ~pp_eol:pp_print_cut
+           (pp_initialize m main_mem (pp_c_var_read m))) inputs
+        (pp_print_list
+           ~pp_open_box:pp_open_vbox0
+           ~pp_eol:pp_print_cut
+           (pp_initialize m main_mem (pp_c_var_read m))) outputs
+        pp_machine_init_name mname
+        main_mem
+    else
+      fprintf fmt
+        "/* Initialize inputs and outputs */@,\
+         %a%a@ "
+        (pp_print_list
+           ~pp_open_box:pp_open_vbox0
+           ~pp_eol:pp_print_cut
+           (pp_initialize m main_mem (pp_c_var_read m))) inputs
+        (pp_print_list
+           ~pp_open_box:pp_open_vbox0
+           (pp_initialize m main_mem (pp_c_var_read m))) outputs
+
+  let print_main_clear mname main_mem fmt m =
+    let inputs = mpfr_vars m.mstep.step_inputs in
+    let outputs = mpfr_vars m.mstep.step_outputs in
+    if not (fst (get_stateless_status m))
+    then
+      fprintf fmt
+        "@[<v>/* Clear inputs, outputs and memories */@,\
+         %a%a%a(%s);@]"
+        (pp_print_list
+           ~pp_open_box:pp_open_vbox0
+           ~pp_eol:pp_print_cut
+           (pp_clear m main_mem (pp_c_var_read m))) inputs
+        (pp_print_list
+           ~pp_open_box:pp_open_vbox0
+           ~pp_eol:pp_print_cut
+           (pp_clear m main_mem (pp_c_var_read m))) outputs
+        pp_machine_clear_name mname
+        main_mem
+    else
+      fprintf fmt
+        "@[<v>/* Clear inputs and outputs */@,\
+         %a%a@]"
+        (pp_print_list
+           ~pp_open_box:pp_open_vbox0
+           ~pp_eol:pp_print_cut
+           (pp_clear m main_mem (pp_c_var_read m))) inputs
+        (pp_print_list
+           ~pp_open_box:pp_open_vbox0
+           (pp_clear m main_mem (pp_c_var_read m))) outputs
+
+let print_get_input fmt id v' v =
+  let pp_file = pp_print_file ("in" ^ string_of_int (id + 1)) in
+  let unclocked_t = Types.unclock_type v.var_type in
+  fprintf fmt "@[<v>%a@]"
+    (fun fmt () ->
+       if Types.is_int_type unclocked_t then
+         fprintf fmt "%s = _get_int(\"%s\");@,%a"
+           v.var_id v'.var_id
+           pp_file ("d", v.var_id)
+       else if Types.is_bool_type unclocked_t then
+         fprintf fmt "%s = _get_bool(\"%s\");@,%a"
+           v.var_id v'.var_id
+           pp_file ("i", v.var_id)
+       else if Types.is_real_type unclocked_t then
+         if !Options.mpfr then
+           fprintf fmt "double %s_tmp = _get_double(\"%s\");@,\
+                        %a@,\
+                        mpfr_set_d(%s, %s_tmp, %i);"
+             v.var_id v'.var_id
+             pp_file ("f", v.var_id ^ "_tmp")
+             v.var_id v.var_id (Mpfr.mpfr_prec ())
+         else
+           fprintf fmt "%s = _get_double(\"%s\");@,%a"
+             v.var_id v'.var_id
+             pp_file ("f", v.var_id)
+       else begin
+         Global.main_node := !Options.main_node;
+         eprintf "Code generation error: %a%a@."
+           Error.pp_error_msg Error.Main_wrong_kind
+           Location.pp_loc v'.var_loc;
+         raise (Error.Error (v'.var_loc, Error.Main_wrong_kind))
+       end) ()
+
+let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
+  if fst (Machine_code_common.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
+    fprintf fmt "%a (%a%a);"
+      pp_machine_step_name mname
+      (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+         (pp_c_val m self pp_c_main_var_input)) inputs
+      (pp_print_list ~pp_sep:pp_print_comma pp_c_main_var_output) outputs
   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 (Var 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 "@[<v 2>if (traces) {@ ";
-    List.iteri (fun idx _ -> fprintf fmt "fflush(f_in%i);@ " (idx+1)) m.mstep.step_inputs;
-    List.iteri (fun idx _ -> fprintf fmt "fflush(f_out%i);@ " (idx+1)) m.mstep.step_outputs;
-    fprintf fmt "@]}@ ";
-    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_usage fmt =
-  fprintf fmt "@[<v 2>void usage(char *argv[]) {@ ";
-  fprintf fmt "printf(\"Usage: %%s\\n\", argv[0]);@ ";
-  fprintf fmt "printf(\" -t: produce trace files for input/output flows\\n\");@ ";
-  fprintf fmt "printf(\" -d<dir>: directory containing traces (default: _traces)\\n\");@ ";
-  fprintf fmt "printf(\" -p<prefix>: prefix_simu.scope<id> (default: file_node)\\n\");@ ";
-  fprintf fmt "exit (8);@ ";
-  fprintf fmt "@]}@ "
-
-let print_options fmt name =
-  fprintf fmt "int traces = 0;@ ";
-  fprintf fmt "char* prefix = \"%s\";@ " name;
-  fprintf fmt "char* dir = \".\";@ ";
-  fprintf fmt "@[<v 2>while ((argc > 1) && (argv[1][0] == '-')) {@ ";
-  fprintf fmt "@[<v 2>switch (argv[1][1]) {@ ";
-  fprintf fmt "@[<v 2>case 't':@ ";
-  fprintf fmt "traces = 1;@ ";
-  fprintf fmt "break;@ ";
-  fprintf fmt "@]@ ";
-  fprintf fmt "@[<v 2>case 'd':@ ";
-  fprintf fmt "dir = &argv[1][2];@ ";
-  fprintf fmt "break;@ ";
-  fprintf fmt "@]@ ";
-  fprintf fmt "@[<v 2>case 'p':@ ";
-  fprintf fmt "prefix = &argv[1][2];@ ";
-  fprintf fmt "break;@ ";
-  fprintf fmt "@]@ ";
-  fprintf fmt "@[<v 2>default:@ ";
-  fprintf fmt "printf(\"Wrong Argument: %%s\\n\", argv[1]);@ ";
-  fprintf fmt "usage(argv);@ ";
-  fprintf fmt "@]@ ";
-  fprintf fmt "@]}@ ";
-  fprintf fmt "++argv;@ ";
-  fprintf fmt "--argc;@ ";
-  fprintf fmt "@]}@ "
-  
-let print_main_code fmt basename m =
-  let mname = m.mname.node_id in
-  (* TODO: find a proper way to shorthen long names. This causes segfault in the binary when trying to fprintf in them *)
-  let mname = if String.length mname > 50 then string_of_int (Hashtbl.hash mname) else mname in
-  
-  let main_mem =
-    if (!Options.static_mem && !Options.main_node <> "")
-    then "&main_mem"
-    else "main_mem" in
-  print_usage fmt;
-  
-  fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ ";
-  print_options fmt (basename ^ "_" ^ mname);
-  print_main_inout_declaration m fmt;
-  Plugins.c_backend_main_loop_body_prefix basename mname fmt ();
-  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;
-
-  Plugins.c_backend_main_loop_body_suffix fmt ();
-  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;";
-  fprintf fmt "@]@ }@."       
-
-let print_main_header fmt =
-  fprintf fmt (if !Options.cpp then "#include <stdio.h>@.#include <unistd.h>@.#include \"%s/io_frontend.hpp\"@." else "#include <stdio.h>@.#include <unistd.h>@.#include <string.h>@.#include \"%s/io_frontend.h\"@.")
-    (Options_management.core_dependency "io_frontend")
-
-let print_main_c main_fmt main_machine basename _prog _machines _dependencies =
-  print_main_header main_fmt;
-  fprintf main_fmt "#include <stdlib.h>@.#include <assert.h>@.";
-  print_import_alloc_prototype main_fmt {local=true; name=basename; content=[]; is_stateful=true} (* assuming it is stateful*) ;
-  pp_print_newline main_fmt ();
-
-  (* Print the svn version number and the supported C standard (C90 or C99) *)
-  print_version main_fmt;
-  print_main_code main_fmt basename main_machine
-end  
+    fprintf fmt "%a (%a%a%s);"
+      pp_machine_step_name mname
+      (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+         (pp_c_val m self pp_c_main_var_input)) inputs
+      (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+         pp_c_main_var_output) outputs
+      self
+
+  let print_main_loop mname main_mem fmt m =
+    let input_values = List.map (fun v ->
+        mk_val (Var v) v.var_type) m.mstep.step_inputs in
+    fprintf fmt
+      "ISATTY = isatty(0);@,\
+       @,\
+       /* Infinite loop */@,\
+       @[<v 2>while(1){@,\
+       fflush(stdout);@,\
+       @[<v 2>if (traces) {@,\
+       %a%a\
+       @]@,\
+       }@,\
+       %a%a%a"
+
+      (pp_print_list_i
+        ~pp_open_box:pp_open_vbox0
+        ~pp_epilogue:pp_print_cut
+         (fun fmt idx _ -> fprintf fmt "fflush(f_in%i);" (idx + 1)))
+      m.mstep.step_inputs
+
+      (pp_print_list_i
+        ~pp_open_box:pp_open_vbox0
+         (fun fmt idx _ -> fprintf fmt "fflush(f_out%i);" (idx + 1)))
+      m.mstep.step_outputs
+
+      (pp_print_list_i2
+        ~pp_open_box:pp_open_vbox0
+        ~pp_epilogue:pp_print_cut
+         print_get_input)
+      (m.mname.node_inputs, m.mstep.step_inputs)
+
+      (fun fmt () ->
+         pp_main_call mname main_mem fmt m input_values m.mstep.step_outputs) ()
+
+      (pp_print_list_i2
+         ~pp_open_box:pp_open_vbox0
+         ~pp_prologue:pp_print_cut
+         print_put_output)
+      (m.mname.node_outputs, m.mstep.step_outputs)
+
+  let print_usage fmt () =
+    fprintf fmt
+      "@[<v 2>\
+       void usage(char *argv[]) {@,\
+       printf(\"Usage: %%s\\n\", argv[0]);@,\
+       printf(\" -t: produce trace files for input/output flows\\n\");@,\
+       printf(\" -d<dir>: directory containing traces (default: _traces)\\n\");@,\
+       printf(\" -p<prefix>: prefix_simu.scope<id> (default: file_node)\\n\");@,\
+       exit (8);@]@,\
+       }"
+
+  let print_options fmt name =
+    fprintf fmt
+      "@[<v>int traces = 0;@,\
+       char* prefix = \"%s\";@,\
+       char* dir = \".\";@,\
+       @[<v 2>while ((argc > 1) && (argv[1][0] == '-')) {@,\
+       @[<v 2>switch (argv[1][1]) {@,\
+       @[<v 2>case 't':@,\
+       traces = 1;@,\
+       break;@,\
+       @]@,\
+       @[<v 2>case 'd':@,\
+       dir = &argv[1][2];@,\
+       break;@,\
+       @]@,\
+       @[<v 2>case 'p':@,\
+       prefix = &argv[1][2];@,\
+       break;@,\
+       @]@,\
+       @[<v 2>default:@,\
+       printf(\"Wrong Argument: %%s\\n\", argv[1]);@,\
+       usage(argv);@]@]@,\
+       }@,\
+       ++argv;@,\
+       --argc;@]@,\
+       }@]"
+      name
+
+  let print_main_code fmt (basename, m) =
+    let mname = m.mname.node_id in
+    (* TODO: find a proper way to shorthen long names. This causes segfault in the binary when trying to fprintf in them *)
+    let mname = if String.length mname > 50
+      then string_of_int (Hashtbl.hash mname) else mname in
+    let main_mem =
+      if !Options.static_mem && !Options.main_node <> ""
+      then "&main_mem"
+      else "main_mem" in
+
+    fprintf fmt
+      "@[<v>\
+       %a@,\
+       @,\
+       @[<v 2>int main (int argc, char *argv[]) {@,\
+       %a@,\
+       @,\
+       %a@,\
+       %a@,\
+       %a@,\
+       %a@,\
+       %a@,\
+       %a@]@,\
+       }@,\
+       %areturn 1;@]@,}@]@."
+
+      print_usage ()
+
+      print_options (basename ^ "_" ^ mname)
+
+      print_main_inout_declaration m
+
+      (Plugins.c_backend_main_loop_body_prefix basename mname) ()
+
+      (print_main_memory_allocation mname main_mem) m
+
+      (fun fmt () ->
+         if !Options.mpfr then
+           fprintf fmt "@[<v>%a@,%a@]@,"
+             print_global_initialize basename
+             (print_main_initialize mname main_mem) m) ()
+
+      (print_main_loop mname main_mem) m
+
+      Plugins.c_backend_main_loop_body_suffix ()
+
+      (fun fmt () ->
+         if !Options.mpfr then
+           fprintf fmt "@[<v>%a@,%a@]@,"
+             (print_main_clear mname main_mem) m
+             print_global_clear basename) ()
+
+  let print_main_header fmt () =
+    fprintf fmt
+      "@[<v>#include <stdio.h>@,\
+       #include <unistd.h>@,\
+       %a@]"
+      (fun fmt () -> fprintf fmt
+          (if !Options.cpp then
+             "#include \"%s/io_frontend.hpp\""
+           else
+             "#include <string.h>@,\
+              #include \"%s/io_frontend.h\"")
+          (Options_management.core_dependency "io_frontend")) ()
+
+  let print_main_c main_fmt main_machine basename _prog _machines _dependencies =
+    fprintf main_fmt
+      "@[<v>\
+       %a@,\
+       #include <stdlib.h>@,\
+       #include <assert.h>@,\
+       %a@,\
+       @,\
+       %a@,\
+       %a
+       @]@."
+      print_main_header ()
+      print_import_alloc_prototype
+      {
+        local = true;
+        name = basename;
+        content = [];
+        is_stateful = true (* assuming it is stateful*)
+      }
+
+      (* Print the svn version number and the supported C standard (C90 or C99) *)
+      pp_print_version ()
+
+      print_main_code (basename, main_machine)
+
+end
 
 (* Local Variables: *)
 (* compile-command:"make -C ../../.." *)

src/lusic.ml

@@ -84,18 +84,16 @@ let read_lusic basename extension =
       }
     end
 
-let print_lusic_to_h basename extension =
-  let lusic = read_lusic basename extension in
-  let header_name = basename ^ ".h" in
-  let h_out = open_out header_name in
-  let h_fmt = formatter_of_out_channel h_out in
-  begin
-    assert (not lusic.obsolete);
-    (*Format.eprintf "lusic to h: %i items.@." (List.length lusic.contents);*)
-    Typing.uneval_prog_generics lusic.contents;
-    Clock_calculus.uneval_prog_generics lusic.contents;
-    Header.print_header_from_header h_fmt (Filename.basename basename) lusic.contents;
-    close_out h_out
-  end
-
-
+(* let print_lusic_to_h basename extension =
+ *   let lusic = read_lusic basename extension in
+ *   let header_name = basename ^ ".h" in
+ *   let h_out = open_out header_name in
+ *   let h_fmt = formatter_of_out_channel h_out in
+ *   begin
+ *     assert (not lusic.obsolete);
+ *     (\*Format.eprintf "lusic to h: %i items.@." (List.length lusic.contents);*\)
+ *     Typing.uneval_prog_generics lusic.contents;
+ *     Clock_calculus.uneval_prog_generics lusic.contents;
+ *     Header.print_header_from_header h_fmt (Filename.basename basename) lusic.contents;
+ *     close_out h_out
+ *   end *)

src/options_management.ml

@@ -11,15 +11,16 @@
 open Options
 
 let print_version () =
-  Format.printf
+  let open Utils.Format in
+  printf
     "@[<v>\
-     Lustrec compiler, version %s (%s)@;\
-     Standard lib: %s@;\
+     Lustrec compiler, version %s (%s)@,\
+     Standard lib: %s@,\
      User provided include directory: @[<h>%a@]\
      @]@."
     version codename
     Version.include_path
-    (Utils.fprintf_list ~sep:"@ " Format.pp_print_string) !include_dirs
+    (pp_print_list ~pp_sep:pp_print_space pp_print_string) !include_dirs
 
 let add_include_dir dir =
   let removed_slash_suffix =

src/plugins/mpfr/lustrec_mpfr.ml

@@ -47,7 +47,7 @@ let inject_id_id expr =
     expr_clock = expr.expr_clock;
   }
 
-let pp_inject_real pp_var pp_val fmt var value =
+let pp_inject_real pp_var pp_val fmt (var, value) =
   Format.fprintf fmt "%s(%a, %a, %s);"
     inject_real_id
     pp_var var
@@ -61,19 +61,19 @@ let inject_assign expr =
     expr_clock = expr.expr_clock;
   }
 
-let pp_inject_copy pp_var fmt var value =
+let pp_inject_copy pp_var fmt (var, value) =
   Format.fprintf fmt "%s(%a, %a, %s);"
     inject_copy_id
     pp_var var
     pp_var value
     (mpfr_rnd ())
 
-let pp_inject_assign pp_var fmt var value =
+let pp_inject_assign pp_var fmt (_, value as vv) =
   if is_const_value value
   then
-    pp_inject_real pp_var pp_var fmt var value
+    pp_inject_real pp_var pp_var fmt vv
   else
-    pp_inject_copy pp_var fmt var value
+    pp_inject_copy pp_var fmt vv
 
 let pp_inject_init pp_var fmt var =
   Format.fprintf fmt "%s(%a, %i);"

src/utils/utils.ml

@@ -67,7 +67,7 @@ let position pred l =
 
 (* TODO: Lélio: why n+1? cf former def below *)
 (* if n < 0 then [] else x :: duplicate x (n - 1) *)
-let duplicate x n = List.init (n+1) (fun i -> x)
+let duplicate x n = List.init (n+1) (fun _ -> x)
 
 let enumerate n = List.init n (fun i -> i)
 
@@ -251,12 +251,91 @@ let print_rat fmt (a,b) =
 
 (* Generic pretty printing *)
 
+
 let pp_final_char_if_non_empty c l =
   (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
 
 let pp_newline_if_non_empty l =
   (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
 
+module Format = struct
+  include Format
+  open Format
+
+  let with_out_file file f =
+    let oc = open_out file in
+    let fmt = formatter_of_out_channel oc in
+    f fmt;
+    close_out oc
+
+  let pp_print_nothing _fmt _ = ()
+
+  let pp_print_cutcut fmt () = fprintf fmt "@,@,"
+
+  let pp_print_endcut s fmt () = fprintf fmt "%s@," s
+
+  let pp_print_opar fmt () = pp_print_string fmt "("
+  let pp_print_cpar fmt () = pp_print_string fmt ")"
+  let pp_print_obrace fmt () = pp_print_string fmt "{"
+  let pp_print_cbrace fmt () = pp_print_string fmt "}"
+
+  let pp_print_comma fmt () = fprintf fmt ",@ "
+  let pp_print_semicolon fmt () = fprintf fmt ";@ "
+  let pp_print_comma' fmt () = fprintf fmt ","
+  let pp_print_semicolon' fmt () = fprintf fmt ";"
+
+  let pp_open_vbox0 fmt () = pp_open_vbox fmt 0
+
+  let pp_print_list
+      ?(pp_prologue=pp_print_nothing) ?(pp_epilogue=pp_print_nothing)
+      ?(pp_op=pp_print_nothing) ?(pp_cl=pp_print_nothing)
+      ?(pp_open_box=fun fmt () -> pp_open_box fmt 0)
+      ?(pp_eol=pp_print_nothing) ?pp_sep pp_v fmt l =
+    fprintf fmt "%a%a%a%a%a@]%a%a"
+      (fun fmt l -> if l <> [] then pp_prologue fmt ()) l
+      pp_op ()
+      pp_open_box ()
+      (pp_print_list ?pp_sep pp_v) l
+      (fun fmt l -> if l <> [] then pp_eol fmt ()) l
+      pp_cl ()
+      (fun fmt l -> if l <> [] then pp_epilogue fmt ()) l
+
+  let pp_print_list_i
+      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
+      pp_v =
+    let i = ref 0 in
+    pp_print_list
+      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
+      (fun fmt x -> pp_v fmt !i x; incr i)
+
+  let pp_print_list2
+      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
+      pp_v fmt (l1, l2) =
+    pp_print_list
+      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
+      pp_v fmt (List.combine l1 l2)
+
+  let pp_print_list_i2
+      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
+      pp_v fmt (l1, l2) =
+    pp_print_list_i
+      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
+      (fun fmt i (x1, x2) -> pp_v fmt i x1 x2) fmt (List.combine l1 l2)
+
+  let pp_print_parenthesized ?(pp_sep=pp_print_comma) =
+    pp_print_list
+      ~pp_op:pp_print_opar
+      ~pp_cl:pp_print_cpar
+      ~pp_sep
+
+  let pp_print_braced ?(pp_sep=pp_print_comma) =
+    pp_print_list
+      ~pp_op:pp_print_obrace
+      ~pp_cl:pp_print_cbrace
+      ~pp_sep
+
+end
+
 let fprintf_list ?(eol:('a, formatter, unit) format = "") ~sep:sep f fmt l =
   Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "%(%)" sep) f fmt l);
   if l <> [] then Format.fprintf fmt "%(%)" eol