From d978c46ea4cdd21e5b54f791dfed882f64e8fcb2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?L=C3=A9lio=20Brun?= <lelio.brun@isae-supaero.fr>
Date: Wed, 30 Jun 2021 18:10:51 +0200
Subject: [PATCH] start instrumenting the main C function
---
.ocamlformat | 1 +
include/arrow_spec.h | 7 +
src/automata.ml | 126 ++-
src/backends/Ada/ada_backend.ml | 22 +-
src/backends/Ada/ada_backend_adb.ml | 40 +-
src/backends/Ada/ada_backend_ads.ml | 78 +-
src/backends/Ada/ada_backend_common.ml | 52 +-
src/backends/Ada/ada_backend_wrapper.ml | 85 +-
src/backends/Ada/ada_printer.ml | 105 ++-
src/backends/C/c_backend.ml | 12 +-
src/backends/C/c_backend_cmake.ml | 20 +-
src/backends/C/c_backend_common.ml | 591 +++++++++++---
src/backends/C/c_backend_common.mli | 28 +-
src/backends/C/c_backend_header.ml | 322 ++++----
src/backends/C/c_backend_header.mli | 10 +-
src/backends/C/c_backend_main.ml | 736 +++++++++++-------
src/backends/C/c_backend_main.mli | 11 +-
src/backends/C/c_backend_makefile.ml | 26 +-
src/backends/C/c_backend_makefile.mli | 2 +-
src/backends/C/c_backend_mauve.ml | 44 +-
src/backends/C/c_backend_spec.ml | 372 +++++++--
src/backends/C/c_backend_spec.mli | 2 +
src/backends/C/c_backend_src.ml | 556 +++++++++----
src/backends/C/c_backend_src.mli | 2 +-
src/backends/EMF/EMF_backend.ml | 12 +-
src/backends/EMF/EMF_common.ml | 155 +++-
src/backends/EMF/EMF_common.mli | 2 +-
src/backends/EMF/EMF_library_calls.ml | 17 +-
src/backends/Horn/horn_backend.ml | 8 +-
.../Horn/horn_backend_collecting_sem.ml | 79 +-
src/backends/Horn/horn_backend_common.ml | 17 +-
src/backends/Horn/horn_backend_printers.ml | 304 ++++++--
src/backends/Horn/horn_backend_traces.ml | 53 +-
src/backends/Java/java_backend.ml | 109 ++-
src/backends/VHDL/vhdl_ast.ml | 131 +++-
src/basic_library.ml | 9 +-
src/causality.ml | 87 ++-
src/checks/access.ml | 6 +-
src/checks/algebraicLoop.ml | 28 +-
src/checks/liveness.ml | 77 +-
src/checks/stateless.ml | 25 +-
src/clock_calculus.ml | 24 +-
src/clocks.ml | 39 +-
src/compiler_common.ml | 48 +-
src/compiler_stages.ml | 53 +-
src/corelang.ml | 119 ++-
src/corelang.mli | 6 +-
src/error.ml | 14 +-
src/features/machine_types/machine_types.ml | 69 +-
src/features/machine_types/machine_types.mli | 28 +
src/inliner.ml | 29 +-
src/lusic.ml | 3 +-
src/lustre_live.ml | 8 +-
src/machine_code.ml | 48 +-
src/machine_code_common.ml | 137 +++-
src/main_lustre_compiler.ml | 10 +-
src/main_lustre_testgen.ml | 35 +-
src/main_lustre_verifier.ml | 8 +-
src/modules.ml | 14 +-
src/mutation.ml | 49 +-
src/normalization.ml | 24 +-
src/optimize_machine.ml | 115 ++-
src/options.ml | 6 +-
src/options.mli | 2 +
src/options_management.ml | 16 +-
src/pathConditions.ml | 54 +-
src/plugins/mpfr/lustrec_mpfr.ml | 35 +-
src/plugins/plugins.ml | 9 +-
src/plugins/salsa/machine_salsa_opt.ml | 247 ++++--
src/plugins/salsa/salsaDatatypes.ml | 27 +-
src/plugins/salsa/salsa_plugin.ml | 3 +-
src/plugins/scopes/scopes.ml | 44 +-
src/printers.ml | 251 ++++--
src/real.ml | 5 +-
src/scheduling.ml | 48 +-
src/sortProg.ml | 7 +-
src/splitting.ml | 6 +-
src/tools/importer/main_lustre_importer.ml | 3 +-
src/tools/seal/seal_export.ml | 22 +-
src/tools/seal/seal_extract.ml | 186 +++--
src/tools/seal/seal_slice.ml | 12 +-
src/tools/seal/seal_utils.ml | 33 +-
src/tools/seal/seal_verifier.ml | 49 +-
src/tools/stateflow/common/basetypes.ml | 17 +-
src/tools/stateflow/common/datatype.ml | 33 +-
.../stateflow/json-parser/json_parser.ml | 7 +-
.../json-parser/main_parse_json_file.ml | 18 +-
.../json-parser/test_json_parser_variables.ml | 44 +-
src/tools/stateflow/models/model_medium.ml | 3 +-
src/tools/stateflow/models/model_simple.ml | 3 +-
src/tools/stateflow/models/model_stopwatch.ml | 9 +-
.../stateflow/semantics/cPS_evaluator.ml | 49 +-
.../stateflow/semantics/cPS_interpreter.ml | 67 +-
.../semantics/cPS_lustre_generator.ml | 65 +-
src/tools/tiny/tiny_utils.ml | 3 +-
src/tools/tiny/tiny_verifier.ml | 7 +-
src/tools/zustre/zustre_analyze.ml | 57 +-
src/tools/zustre/zustre_cex.ml | 18 +-
src/tools/zustre/zustre_common.ml | 159 ++--
src/tools/zustre/zustre_test.ml | 50 +-
src/types.ml | 95 ++-
src/types.mli | 6 +-
src/typing.ml | 139 +++-
src/utils/dimension.ml | 7 +-
src/utils/env.ml | 3 +-
src/utils/utils.ml | 54 +-
src/verifiers.ml | 9 +-
unused/checks/init_calculus.ml | 6 +-
unused/expand.ml | 9 +-
unused/init_predef.ml | 6 +-
unused/lustre_utils.ml | 4 +-
111 files changed, 5201 insertions(+), 2060 deletions(-)
create mode 100644 src/features/machine_types/machine_types.mli
diff --git a/.ocamlformat b/.ocamlformat
index fe6b478e..3130eeb6 100644
--- a/.ocamlformat
+++ b/.ocamlformat
@@ -4,3 +4,4 @@ wrap-comments=true
cases-exp-indent=2
break-cases=nested
break-fun-decl=wrap
+wrap-fun-args=false
diff --git a/include/arrow_spec.h b/include/arrow_spec.h
index 99acd138..65e45401 100644
--- a/include/arrow_spec.h
+++ b/include/arrow_spec.h
@@ -29,6 +29,13 @@ extern void _arrow_dealloc (struct _arrow_mem *);
/* ACSL arrow spec */
//@ ghost struct _arrow_mem_ghost {struct _arrow_reg _reg;};
+#define _arrow_DECLARE_GHOST(attr, inst)\
+ attr struct _arrow_mem_ghost inst;
+
+#define _arrow_LINK_GHOST(inst) do {\
+ ;\
+} while (0)
+
#define _arrow_reset_ghost(mem) (mem)._reg._first = 1
#define _arrow_step_ghost(mem) (mem)._reg._first = 0
diff --git a/src/automata.ml b/src/automata.ml
index bf570f7a..67477d48 100644
--- a/src/automata.ml
+++ b/src/automata.ml
@@ -47,7 +47,8 @@ let mkidentpair loc restart state =
mkexpr loc (Expr_tuple [ mkident loc restart; mkident loc state ])
let add_branch (loc, expr, restart, st) cont =
- mkexpr loc
+ mkexpr
+ loc
(Expr_ite
( expr,
mkexpr loc (Expr_tuple [ mkbool loc restart; mkident loc st ]),
@@ -81,7 +82,8 @@ let unless_read reads handler =
let res =
List.fold_left
(fun read (_, c, _, _) -> Utils.ISet.union read (get_expr_vars c))
- reads handler.hand_unless
+ reads
+ handler.hand_unless
in
(* Format.eprintf "unless_reads %s = %a@." handler.hand_state (fprintf_list
~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) (ISet.elements reads);
@@ -92,13 +94,15 @@ let unless_read reads handler =
let until_read reads handler =
List.fold_left
(fun read (_, c, _, _) -> Utils.ISet.union read (get_expr_vars c))
- reads handler.hand_until
+ reads
+ handler.hand_until
let rec handler_read reads handler =
let locals =
List.fold_left
(fun locals v -> ISet.add v.var_id locals)
- ISet.empty handler.hand_locals
+ ISet.empty
+ handler.hand_locals
in
let allvars =
List.fold_left
@@ -108,7 +112,8 @@ let rec handler_read reads handler =
Utils.ISet.union read (get_expr_vars eq.eq_rhs)
| Aut aut ->
automata_read read aut)
- reads handler.hand_stmts
+ reads
+ handler.hand_stmts
in
let res = ISet.diff allvars locals in
(* Format.eprintf "handler_allvars %s = %a@." handler.hand_state (fprintf_list
@@ -122,13 +127,15 @@ and automata_read reads aut =
List.fold_left
(fun read handler ->
until_read (handler_read (unless_read read handler) handler) handler)
- reads aut.aut_handlers
+ reads
+ aut.aut_handlers
let rec handler_write writes handler =
let locals =
List.fold_left
(fun locals v -> ISet.add v.var_id locals)
- ISet.empty handler.hand_locals
+ ISet.empty
+ handler.hand_locals
in
let allvars =
List.fold_left
@@ -138,14 +145,16 @@ let rec handler_write writes handler =
List.fold_left (fun write v -> ISet.add v write) write eq.eq_lhs
| Aut aut ->
List.fold_left handler_write write aut.aut_handlers)
- writes handler.hand_stmts
+ writes
+ handler.hand_stmts
in
ISet.diff allvars locals
let node_vars_of_idents node iset =
List.fold_right
(fun v res -> if ISet.mem v.var_id iset then v :: res else res)
- (get_node_vars node) []
+ (get_node_vars node)
+ []
let mkautomata_state nodeid used typedef loc id =
let tydec_bool = { ty_dec_desc = Tydec_bool; ty_dec_loc = loc } in
@@ -159,10 +168,12 @@ let mkautomata_state nodeid used typedef loc id =
let actual_s = mk_new_name used (id ^ "__state_act") in
{
incoming_r' =
- mkvar_decl loc
+ mkvar_decl
+ loc
(incoming_r', tydec_bool, ckdec_any, false, None, Some nodeid);
incoming_s' =
- mkvar_decl loc
+ mkvar_decl
+ loc
( incoming_s',
tydec_state typedef.tydef_id,
ckdec_any,
@@ -170,10 +181,12 @@ let mkautomata_state nodeid used typedef loc id =
None,
Some nodeid );
incoming_r =
- mkvar_decl loc
+ mkvar_decl
+ loc
(incoming_r, tydec_bool, ckdec_any, false, None, Some nodeid);
incoming_s =
- mkvar_decl loc
+ mkvar_decl
+ loc
( incoming_s,
tydec_state typedef.tydef_id,
ckdec_any,
@@ -183,7 +196,8 @@ let mkautomata_state nodeid used typedef loc id =
actual_r =
mkvar_decl loc (actual_r, tydec_bool, ckdec_any, false, None, Some nodeid);
actual_s =
- mkvar_decl loc
+ mkvar_decl
+ loc
( actual_s,
tydec_state typedef.tydef_id,
ckdec_any,
@@ -212,7 +226,8 @@ let node_of_unless nused node aut_id aut_state handler =
in
let var_outputs = [ aut_state.actual_r; aut_state.actual_s ] in
let init_expr =
- mkpair handler.hand_loc
+ mkpair
+ handler.hand_loc
(mkident handler.hand_loc aut_state.incoming_r.var_id)
(mkconst handler.hand_loc handler.hand_state)
in
@@ -221,7 +236,8 @@ let node_of_unless nused node aut_id aut_state handler =
let expr_outputs = List.fold_right add_branch handler.hand_unless init_expr in
let eq_outputs =
Eq
- (mkeq handler.hand_loc
+ (mkeq
+ handler.hand_loc
([ aut_state.actual_r.var_id; aut_state.actual_s.var_id ], expr_outputs))
in
let node_id =
@@ -230,7 +246,8 @@ let node_of_unless nused node aut_id aut_state handler =
let args =
List.map
(fun v ->
- mkexpr handler.hand_loc
+ mkexpr
+ handler.hand_loc
(Expr_when
( mkident handler.hand_loc v.var_id,
aut_state.incoming_s.var_id,
@@ -255,7 +272,8 @@ let node_of_unless nused node aut_id aut_state handler =
node_annot = [];
node_iscontract = false;
},
- mkexpr handler.hand_loc
+ mkexpr
+ handler.hand_loc
(Expr_appl (node_id, mkexpr handler.hand_loc (Expr_tuple args), reset)) )
let rename_output used name = mk_new_name used (Format.sprintf "%s_out" name)
@@ -282,7 +300,8 @@ let mk_frename used outputs =
let table =
ISet.fold
(fun name table -> IMap.add name (rename_output used name) table)
- outputs IMap.empty
+ outputs
+ IMap.empty
in
fun name -> try IMap.find name table with Not_found -> name
@@ -311,30 +330,36 @@ let node_of_assign_until nused used node aut_id aut_state handler =
List.map2
(fun o o' ->
Eq
- (mkeq handler.hand_loc
+ (mkeq
+ handler.hand_loc
([ o'.var_id ], mkident handler.hand_loc o.var_id)))
- var_outputs new_var_outputs
+ var_outputs
+ new_var_outputs
in
let init_until =
- mkpair handler.hand_loc
+ 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 until_eq =
Eq
- (mkeq handler.hand_loc
+ (mkeq
+ handler.hand_loc
( [ aut_state.incoming_r.var_id; aut_state.incoming_s.var_id ],
until_expr ))
in
let node_id =
- mk_new_name nused
+ mk_new_name
+ nused
(Format.sprintf "%s__%s_handler_until" aut_id handler.hand_state)
in
let args =
List.map
(fun v ->
- mkexpr handler.hand_loc
+ mkexpr
+ handler.hand_loc
(Expr_when
( mkident handler.hand_loc v.var_id,
aut_state.actual_s.var_id,
@@ -349,7 +374,8 @@ let node_of_assign_until nused used node aut_id aut_state handler =
node_clock = Clocks.new_var true;
node_inputs = List.map copy_var_decl var_inputs;
node_outputs =
- List.map copy_var_decl
+ List.map
+ copy_var_decl
(aut_state.incoming_r :: aut_state.incoming_s :: new_var_outputs);
node_locals = List.map copy_var_decl (new_var_locals @ handler.hand_locals);
node_gencalls = [];
@@ -362,7 +388,8 @@ let node_of_assign_until nused used node aut_id aut_state handler =
node_annot = handler.hand_annots;
node_iscontract = false;
},
- mkexpr handler.hand_loc
+ mkexpr
+ handler.hand_loc
(Expr_appl (node_id, mkexpr handler.hand_loc (Expr_tuple args), reset)) )
let typedef_of_automata aut =
@@ -390,24 +417,28 @@ let expand_automata nused used owner typedef node aut =
let all_outputs =
List.fold_left
(fun all (outputs, _, _) -> ISet.union outputs all)
- ISet.empty aunodes
+ ISet.empty
+ aunodes
in
let unless_handlers =
List.map2 (fun h (_, c) -> h.hand_state, c) aut.aut_handlers unodes
in
let unless_expr =
- mkexpr aut.aut_loc
+ mkexpr
+ aut.aut_loc
(Expr_merge (aut_state.incoming_s.var_id, unless_handlers))
in
let unless_eq =
- mkeq aut.aut_loc
+ mkeq
+ aut.aut_loc
([ aut_state.actual_r.var_id; aut_state.actual_s.var_id ], unless_expr)
in
let assign_until_handlers =
List.map2 (fun h (_, _, c) -> h.hand_state, c) aut.aut_handlers aunodes
in
let assign_until_expr =
- mkexpr aut.aut_loc
+ mkexpr
+ aut.aut_loc
(Expr_merge (aut_state.actual_s.var_id, assign_until_handlers))
in
let assign_until_vars =
@@ -418,15 +449,20 @@ let expand_automata nused used owner typedef node aut =
mkeq aut.aut_loc (assign_until_vars, assign_until_expr)
in
let fby_incoming_expr =
- mkfby aut.aut_loc
- (mkpair aut.aut_loc
+ mkfby
+ aut.aut_loc
+ (mkpair
+ aut.aut_loc
(mkconst aut.aut_loc tag_false)
(mkconst aut.aut_loc initial))
- (mkidentpair aut.aut_loc aut_state.incoming_r'.var_id
+ (mkidentpair
+ aut.aut_loc
+ aut_state.incoming_r'.var_id
aut_state.incoming_s'.var_id)
in
let incoming_eq =
- mkeq aut.aut_loc
+ mkeq
+ aut.aut_loc
( [ aut_state.incoming_r.var_id; aut_state.incoming_s.var_id ],
fby_incoming_expr )
in
@@ -434,10 +470,12 @@ let expand_automata nused used owner typedef node aut =
let eqs' = [ Eq unless_eq; Eq assign_until_eq; Eq incoming_eq ] in
( List.map2
(fun h (n, _) -> mktop_decl h.hand_loc owner false (Node n))
- aut.aut_handlers unodes
+ aut.aut_handlers
+ unodes
@ List.map2
(fun h (_, n, _) -> mktop_decl h.hand_loc owner false (Node n))
- aut.aut_handlers aunodes,
+ aut.aut_handlers
+ aunodes,
locals',
eqs' )
@@ -477,7 +515,8 @@ let expand_node_stmts nused used loc owner node =
let top_types', top_nodes', locals', eqs' =
List.fold_left
(expand_node_stmt nused used owner node)
- ([], [], [], []) node.node_stmts
+ ([], [], [], [])
+ node.node_stmts
in
let node' =
{ node with node_locals = locals' @ node.node_locals; node_stmts = eqs' }
@@ -498,8 +537,12 @@ let rec expand_decls_rec nused top_decls =
|| List.exists (fun v -> v.var_id = name) nd.node_locals
in
let top_types', top_decl', top_nodes' =
- expand_node_stmts nused used top_decl.top_decl_loc
- top_decl.top_decl_owner nd
+ expand_node_stmts
+ nused
+ used
+ top_decl.top_decl_loc
+ top_decl.top_decl_owner
+ nd
in
top_types' @ top_decl' :: expand_decls_rec nused (top_nodes' @ q)
| _ ->
@@ -516,7 +559,8 @@ let expand_decls top_decls =
ISet.add nd.nodei_id names
| _ ->
names)
- ISet.empty top_decls
+ ISet.empty
+ top_decls
in
let nused name = ISet.mem name top_names in
expand_decls_rec nused top_decls
diff --git a/src/backends/Ada/ada_backend.ml b/src/backends/Ada/ada_backend.ml
index 8049f8a6..065ffa71 100644
--- a/src/backends/Ada/ada_backend.ml
+++ b/src/backends/Ada/ada_backend.ml
@@ -59,7 +59,8 @@ let get_typed_submachines machines m =
(fun instance submachine ->
let ident = fst instance in
ident, (get_substitution m ident submachine, submachine))
- instances submachines
+ instances
+ submachines
let extract_contract machines m =
let rec find_submachine_from_ident ident = function
@@ -145,7 +146,9 @@ let translate_to_ada basename machines =
| main_node -> (
match Machine_code_common.get_machine_opt filtered_machines main_node with
| None ->
- Format.eprintf "Ada Code generation error: %a@." Error.pp
+ Format.eprintf
+ "Ada Code generation error: %a@."
+ Error.pp
Error.Main_not_found;
raise (Error.Error (Location.dummy, Error.Main_not_found))
| Some m ->
@@ -173,17 +176,24 @@ let translate_to_ada basename machines =
| None ->
()
| Some machine ->
- write_file destname pp_main_filename Ada_backend_wrapper.pp_main_adb
+ write_file
+ destname
+ pp_main_filename
+ Ada_backend_wrapper.pp_main_adb
(*get_typed_submachines filtered_machines machine*)
machine;
- write_file destname
+ write_file
+ destname
(fun fmt _ -> Ada_backend_wrapper.pp_project_name (basename ^ "_exe") fmt)
(Ada_backend_wrapper.pp_project_file filtered_machines basename)
main_machine);
- write_file destname Ada_backend_wrapper.pp_project_configuration_name
+ write_file
+ destname
+ Ada_backend_wrapper.pp_project_configuration_name
(fun fmt _ -> Ada_backend_wrapper.pp_project_configuration_file fmt)
basename;
- write_file destname
+ write_file
+ destname
(fun fmt _ -> Ada_backend_wrapper.pp_project_name (basename ^ "_lib") fmt)
(Ada_backend_wrapper.pp_project_file filtered_machines basename)
None
diff --git a/src/backends/Ada/ada_backend_adb.ml b/src/backends/Ada/ada_backend_adb.ml
index 47e620a3..cf61062c 100644
--- a/src/backends/Ada/ada_backend_adb.ml
+++ b/src/backends/Ada/ada_backend_adb.ml
@@ -45,7 +45,12 @@ let rec pp_machine_instr typed_submachines env instr fmt =
in
(* Print a case *)
let pp_case fmt (g, hl) =
- fprintf fmt "case %a is@,%aend case" (pp_value env) g pp_block
+ fprintf
+ fmt
+ "case %a is@,%aend case"
+ (pp_value env)
+ g
+ pp_block
(List.map pp_when hl)
in
(* Print a if *)
@@ -64,7 +69,12 @@ let rec pp_machine_instr typed_submachines env instr fmt =
| Some i2 ->
fun fmt -> fprintf fmt "else@,%a" pp_block (List.map pp_instr i2)
in
- fprintf fmt "if %a then@,%a%tend if" pp_cond g pp_block
+ fprintf
+ fmt
+ "if %a then@,%a%tend if"
+ pp_cond
+ g
+ pp_block
(List.map pp_instr instrs1)
pp_else
in
@@ -109,7 +119,9 @@ let rec pp_machine_instr typed_submachines env instr fmt =
pp_case fmt (g, hl)
| MComment s ->
let lines = String.split_on_char '\n' s in
- fprintf fmt "%a"
+ fprintf
+ fmt
+ "%a"
(pp_print_list ~pp_sep:pp_print_nothing pp_oneline_comment)
lines
| _ ->
@@ -171,7 +183,11 @@ let pp_reset_definition env typed_submachines fmt (m, m_spec_opt) =
let pp_instr_list =
List.map (pp_machine_instr typed_submachines env) (assigns @ m.minit)
in
- pp_procedure pp_reset_procedure_name (build_pp_arg_reset m) None fmt
+ pp_procedure
+ pp_reset_procedure_name
+ (build_pp_arg_reset m)
+ None
+ fmt
(AdaProcedureContent ([], pp_instr_list))
(** Print the package definition(ads) of a machine. It requires the list of all
@@ -185,7 +201,9 @@ let pp_file fmt (typed_submachines, ((opt_spec_machine, guarantees), machine)) =
let env = List.map (fun x -> x.var_id, pp_state_name) machine.mmemory in
let pp_reset fmt =
if is_machine_statefull machine then
- fprintf fmt "%a;@,@,"
+ fprintf
+ fmt
+ "%a;@,@,"
(pp_reset_definition env typed_submachines)
(machine, opt_spec_machine)
else fprintf fmt ""
@@ -198,14 +216,20 @@ let pp_file fmt (typed_submachines, ((opt_spec_machine, guarantees), machine)) =
in
let packages = List.map pp_str (List.fold_left aux [] machine.mcalls) in
let pp_content fmt =
- fprintf fmt "%t%a" (*Define the reset procedure*) pp_reset
+ fprintf
+ fmt
+ "%t%a"
+ (*Define the reset procedure*) pp_reset
(*Define the step procedure*)
(pp_step_definition env typed_submachines)
(machine, opt_spec_machine, guarantees)
in
- fprintf fmt "%a%a;@."
+ fprintf
+ fmt
+ "%a%a;@."
(* Include all the required packages*)
- (pp_print_list ~pp_sep:pp_print_semicolon
+ (pp_print_list
+ ~pp_sep:pp_print_semicolon
~pp_epilogue:(fun fmt () -> fprintf fmt ";@,@,")
(pp_with AdaPrivate))
packages
diff --git a/src/backends/Ada/ada_backend_ads.ml b/src/backends/Ada/ada_backend_ads.ml
index f7ef4737..dd69ab5a 100644
--- a/src/backends/Ada/ada_backend_ads.ml
+++ b/src/backends/Ada/ada_backend_ads.ml
@@ -52,14 +52,20 @@ let pp_transition_predicate fmt (_, m) =
in
let inputs = build_pp_var_decl_step_input AdaIn None m in
let outputs = build_pp_var_decl_step_output AdaIn None m in
- pp_predicate pp_transition_name
+ pp_predicate
+ pp_transition_name
([ [ old_state; new_state ] ] @ inputs @ outputs)
- true fmt None
+ true
+ fmt
+ None
let pp_invariant_predicate fmt () =
- pp_predicate pp_invariant_name
+ pp_predicate
+ pp_invariant_name
[ [ build_pp_state_decl AdaIn None ] ]
- true fmt None
+ true
+ fmt
+ None
(** Print a new statement instantiating a generic package. @param fmt the
formater to print on @param substitutions the instanciation substitution
@@ -140,12 +146,15 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
let pp_state_decl_and_reset fmt =
let init fmt =
- pp_call fmt
+ pp_call
+ fmt
( pp_access pp_axiomatize_package_name pp_init_name,
[ [ pp_state_name ] ] )
in
let contract = Some (false, false, [], [ init ]) in
- fprintf fmt "%t;@,@,%a;@,@,"
+ fprintf
+ fmt
+ "%t;@,@,%a;@,@,"
(*Declare the state type*)
(pp_type_decl pp_state_type AdaPrivate)
(*Declare the reset procedure*)
@@ -154,14 +163,19 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
in
let pp_private_section fmt =
- fprintf fmt "@,private@,@,%a%a%a"
+ fprintf
+ fmt
+ "@,private@,@,%a%a%a"
(*Instantiate the polymorphic type that need to be instantiated*)
- (pp_print_list ~pp_sep:pp_print_semicolon
+ (pp_print_list
+ ~pp_sep:pp_print_semicolon
~pp_epilogue:(fun fmt () -> fprintf fmt ";@,@,")
pp_new_package)
- typed_machines_to_instanciate (*Define the state type*) pp_ifstatefull
+ typed_machines_to_instanciate
+ (*Define the state type*) pp_ifstatefull
(fun fmt -> pp_record pp_state_type fmt var_lists)
- (pp_print_list ~pp_sep:pp_print_semicolon
+ (pp_print_list
+ ~pp_sep:pp_print_semicolon
~pp_prologue:(fun fmt () -> fprintf fmt ";@,@,")
(fun fmt pp -> pp fmt))
ghost_private
@@ -181,11 +195,13 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
@ if output != [] then [ output ] else []
in
let transition fmt =
- pp_call fmt
+ pp_call
+ fmt
(pp_access pp_axiomatize_package_name pp_transition_name, args)
in
let invariant fmt =
- pp_call fmt
+ pp_call
+ fmt
( pp_access pp_axiomatize_package_name pp_invariant_name,
[ [ pp_state_name ] ] )
in
@@ -205,29 +221,42 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
Some (true, false, [], []) )
in
let ghost_public = List.map pp_guarantee guarantees in
- fprintf fmt "@,%a%a%a%a@,@,%a;@,@,%t"
- (pp_print_list ~pp_sep:pp_print_semicolon
+ fprintf
+ fmt
+ "@,%a%a%a%a@,@,%a;@,@,%t"
+ (pp_print_list
+ ~pp_sep:pp_print_semicolon
~pp_epilogue:(fun fmt () -> fprintf fmt ";@,@,")
(fun fmt pp -> pp fmt))
- ghost_public pp_ifstatefull pp_state_decl_and_reset
+ ghost_public
+ pp_ifstatefull
+ pp_state_decl_and_reset
(*Declare the step procedure*)
- (pp_procedure pp_step_procedure_name (build_pp_arg_step m) pp_contract_opt)
- AdaNoContent pp_ifstatefull
+ (pp_procedure
+ pp_step_procedure_name
+ (build_pp_arg_step m)
+ pp_contract_opt)
+ AdaNoContent
+ pp_ifstatefull
(fun fmt -> fprintf fmt ";@,")
(pp_package pp_axiomatize_package_name [] false)
(fun fmt ->
- fprintf fmt
+ fprintf
+ fmt
"pragma Annotate (GNATProve, External_Axiomatization);@,\
@,\
%a;@,\
%a;@,\
%a"
(*Declare the init predicate*)
- pp_init_predicate ()
+ pp_init_predicate
+ ()
(*Declare the transition predicate*)
- pp_transition_predicate (m_spec_opt, m)
+ pp_transition_predicate
+ (m_spec_opt, m)
(*Declare the invariant predicate*)
- pp_invariant_predicate ())
+ pp_invariant_predicate
+ ())
(*Print the private section*)
pp_private_section
in
@@ -235,9 +264,12 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
let pp_poly_type id = pp_type_decl (pp_polymorphic_type id) AdaPrivate in
let pp_generics = List.map pp_poly_type polymorphic_types in
- fprintf fmt "@[<v>%a%a;@]@."
+ fprintf
+ fmt
+ "@[<v>%a%a;@]@."
(* Include all the subinstance package*)
- (pp_print_list ~pp_sep:pp_print_semicolon
+ (pp_print_list
+ ~pp_sep:pp_print_semicolon
~pp_epilogue:(fun fmt () -> fprintf fmt ";@,@,")
(pp_with AdaNoVisibility))
machines_to_import
diff --git a/src/backends/Ada/ada_backend_common.ml b/src/backends/Ada/ada_backend_common.ml
index efc7d194..61f83f83 100644
--- a/src/backends/Ada/ada_backend_common.ml
+++ b/src/backends/Ada/ada_backend_common.ml
@@ -96,7 +96,7 @@ let pp_type fmt typ =
eprintf "Tarrow@.";
assert false (*TODO*)
| Ttuple l ->
- eprintf "Ttuple %a @." (pp_print_list print_ty) l;
+ eprintf "Ttuple %a @." (pp_print_list pp) l;
assert false (*TODO*)
| Tenum _ ->
eprintf "Tenum@.";
@@ -117,7 +117,7 @@ let pp_type fmt typ =
eprintf "Tvar@.";
assert false
(*TODO*)
-(*| _ -> eprintf "Type error : %a@." Types.print_ty typ; assert false *)
+(*| _ -> eprintf "Type error : %a@." Types.pp typ; assert false *)
(** Return a default ada constant for a given type. @param cst_typ the constant
type **)
@@ -152,9 +152,13 @@ let pp_package_name_with_polymorphic substitution machine fmt =
assert (
List.for_all2
(fun poly1 (poly2, _) -> poly1 = poly2)
- polymorphic_types substituion);
+ polymorphic_types
+ substituion);
let instantiated_types = snd (List.split substitution) in
- fprintf fmt "%t%a" (pp_package_name machine)
+ fprintf
+ fmt
+ "%t%a"
+ (pp_package_name machine)
(pp_print_list
~pp_prologue:(fun fmt () -> pp_print_string fmt "_")
~pp_sep:(fun fmt () -> pp_print_string fmt "_")
@@ -183,7 +187,8 @@ let pp_var env fmt var =
@param fmt the formater to use @param t the tag to print **)
let pp_ada_tag fmt t =
- pp_print_string fmt
+ pp_print_string
+ fmt
(if t = tag_true then "True" else if t = tag_false then "False" else t)
(** Printing function for machine type constants. For the moment, arrays are not
@@ -219,9 +224,19 @@ let pp_ada_const fmt c =
let pp_mod pp_value v1 v2 fmt =
if !Options.integer_div_euclidean then
(* (a rem b) + (a rem b < 0 ? abs(b) : 0) *)
- Format.fprintf fmt
- "((%a rem %a) + (if (%a rem %a) < 0 then abs(%a) else 0))" pp_value v1
- pp_value v2 pp_value v1 pp_value v2 pp_value v2
+ Format.fprintf
+ fmt
+ "((%a rem %a) + (if (%a rem %a) < 0 then abs(%a) else 0))"
+ pp_value
+ v1
+ pp_value
+ v2
+ pp_value
+ v1
+ pp_value
+ v2
+ pp_value
+ v2
else
(* Ada behavior for rem *)
Format.fprintf fmt "(%a rem %a)" pp_value v1 pp_value v2
@@ -236,8 +251,14 @@ let pp_mod pp_value v1 v2 fmt =
let pp_div pp_value v1 v2 fmt =
if !Options.integer_div_euclidean then
(* (a - ((a rem b) + (if a rem b < 0 then abs (b) else 0))) / b) *)
- Format.fprintf fmt "(%a - %t) / %a" pp_value v1 (pp_mod pp_value v1 v2)
- pp_value v2
+ Format.fprintf
+ fmt
+ "(%a - %t) / %a"
+ pp_value
+ v1
+ (pp_mod pp_value v1 v2)
+ pp_value
+ v2
else
(* Ada behavior for / *)
Format.fprintf fmt "(%a / %a)" pp_value v1 pp_value v2
@@ -272,8 +293,15 @@ let pp_basic_lib_fun pp_value ident fmt vl =
| "!=", [ v1; v2 ] ->
Format.fprintf fmt "(%a %s %a)" pp_value v1 "/=" pp_value v2
| "ite", [ v1; v2; v3 ] ->
- Format.fprintf fmt "(if %a then %a else %a)" pp_value v1 pp_value v2
- pp_value v3
+ Format.fprintf
+ fmt
+ "(if %a then %a else %a)"
+ pp_value
+ v1
+ pp_value
+ v2
+ pp_value
+ v3
| op, [ v1; v2 ] ->
Format.fprintf fmt "(%a %s %a)" pp_value v1 op pp_value v2
| _, [ v1 ] when List.mem_assoc ident ada_supported_funs ->
diff --git a/src/backends/Ada/ada_backend_wrapper.ml b/src/backends/Ada/ada_backend_wrapper.ml
index 27cc87d1..c105bf6d 100644
--- a/src/backends/Ada/ada_backend_wrapper.ml
+++ b/src/backends/Ada/ada_backend_wrapper.ml
@@ -46,7 +46,9 @@ let pp_main_adb fmt machine =
[
[
AdaLocalVar
- (build_pp_state_decl_from_subinstance AdaNoMode None
+ (build_pp_state_decl_from_subinstance
+ AdaNoMode
+ None
(asprintf "%t" pp_state_name, ([], machine)));
];
]
@@ -64,29 +66,43 @@ let pp_main_adb fmt machine =
let get_type var = Types.repr var.var_type in
let pp_read fmt var =
if Types.is_bool_type (get_type var) then
- fprintf fmt "%t := Integer'Value(Ada.Text_IO.Get_Line) /= 0"
+ fprintf
+ fmt
+ "%t := Integer'Value(Ada.Text_IO.Get_Line) /= 0"
(pp_var_name var)
else
- fprintf fmt "%t := %a'Value(Ada.Text_IO.Get_Line)" (pp_var_name var)
- pp_var_type var
+ fprintf
+ fmt
+ "%t := %a'Value(Ada.Text_IO.Get_Line)"
+ (pp_var_name var)
+ pp_var_type
+ var
in
let pp_write fmt var =
let t = get_type var in
if Types.is_bool_type t then
- fprintf fmt
+ fprintf
+ fmt
"Ada.Text_IO.Put_Line(\"'%t': '\" & (if %t then \"1\" else \"0\") & \
\"' \")"
- (pp_var_name var) (pp_var_name var)
+ (pp_var_name var)
+ (pp_var_name var)
else if Types.is_int_type t then
- fprintf fmt
+ fprintf
+ fmt
"Ada.Text_IO.Put(\"'%t': '\");@,\
Integer_IO.Put(%t);@,\
- Ada.Text_IO.Put_Line(\"' \")" (pp_var_name var) (pp_var_name var)
+ Ada.Text_IO.Put_Line(\"' \")"
+ (pp_var_name var)
+ (pp_var_name var)
else if Types.is_real_type t then
- fprintf fmt
+ fprintf
+ fmt
"Ada.Text_IO.Put(\"'%t': '\");@,\
Float_IO.Put(%t, Fore=>0, Aft=> 15, Exp => 0);@,\
- Ada.Text_IO.Put_Line(\"' \")" (pp_var_name var) (pp_var_name var)
+ Ada.Text_IO.Put_Line(\"' \")"
+ (pp_var_name var)
+ (pp_var_name var)
else assert false
(* Could not be the top level inputs *)
in
@@ -96,13 +112,16 @@ let pp_main_adb fmt machine =
let args =
pp_state_name
::
- List.map pp_var_name
+ List.map
+ pp_var_name
(machine.mstep.step_inputs @ machine.mstep.step_outputs)
in
- fprintf fmt
+ fprintf
+ fmt
"while not Ada.Text_IO.End_Of_File loop@, @[<v>%a;@,%a;@,%a;@]@,end loop"
(pp_print_list ~pp_sep:pp_print_semicolon pp_read)
- machine.mstep.step_inputs pp_call
+ machine.mstep.step_inputs
+ pp_call
(pp_package_access (pp_package, pp_step_procedure_name), [ args ])
(pp_print_list ~pp_sep:pp_print_semicolon pp_write)
machine.mstep.step_outputs
@@ -113,15 +132,21 @@ let pp_main_adb fmt machine =
(if statefull then
[
(fun fmt ->
- pp_call fmt
+ pp_call
+ fmt
( pp_package_access (pp_package, pp_reset_procedure_name),
[ [ pp_state_name ] ] ));
]
else [])
@ [ pp_loop ]
in
- fprintf fmt "@[<v>%a;@,%a;@,@,%a;@]" (pp_with AdaPrivate) (pp_str text_io)
- (pp_with AdaPrivate) (pp_package_name machine)
+ fprintf
+ fmt
+ "@[<v>%a;@,%a;@,@,%a;@]"
+ (pp_with AdaPrivate)
+ (pp_str text_io)
+ (pp_with AdaPrivate)
+ (pp_package_name machine)
(pp_procedure pp_main_procedure_name [] None)
(AdaProcedureContent (locals, instrs))
@@ -140,12 +165,17 @@ let pp_project_name basename fmt = fprintf fmt "%s.gpr" basename
let pp_for_single name arg fmt = fprintf fmt "for %s use \"%s\"" name arg
let pp_for name args fmt =
- fprintf fmt "for %s use (@[%a@])" name
+ fprintf
+ fmt
+ "for %s use (@[%a@])"
+ name
(pp_comma_list (fun fmt arg -> fprintf fmt "\"%s\"" arg))
args
let pp_content fmt lines =
- fprintf fmt " @[<v>%a%a@]"
+ fprintf
+ fmt
+ " @[<v>%a%a@]"
(pp_print_list ~pp_sep:pp_print_semicolon (fun fmt pp ->
fprintf fmt "%t" pp))
lines
@@ -169,9 +199,12 @@ let pp_project_file machines basename fmt machine_opt =
[ asprintf "%a" pp_main_filename m ]
in
let project_name = basename ^ if machine_opt = None then "_lib" else "_exe" in
- fprintf fmt "%sproject %s is@,%a@,end %s;"
+ fprintf
+ fmt
+ "%sproject %s is@,%a@,end %s;"
(if machine_opt = None then "library " else "")
- project_name pp_content
+ project_name
+ pp_content
((match machine_opt with
| None ->
[
@@ -186,14 +219,18 @@ let pp_project_file machines basename fmt machine_opt =
@ [
pp_for_single "Object_Dir" "obj";
pp_for "Source_Files" adbs;
- pp_package "Builder"
+ pp_package
+ "Builder"
[
- pp_for_single "Global_Configuration_Pragmas"
+ pp_for_single
+ "Global_Configuration_Pragmas"
(asprintf "%a" pp_project_configuration_name basename);
];
- pp_package "Prove"
+ pp_package
+ "Prove"
[
- pp_for "Switches"
+ pp_for
+ "Switches"
[
"--mode=prove";
"--report=statistics";
diff --git a/src/backends/Ada/ada_printer.ml b/src/backends/Ada/ada_printer.ml
index 2d98055b..c1df895c 100644
--- a/src/backends/Ada/ada_printer.ml
+++ b/src/backends/Ada/ada_printer.ml
@@ -35,7 +35,9 @@ type def_content =
(** Print a parameter_mode. @param fmt the formater to print on @param mode the
modifier **)
let pp_parameter_mode fmt mode =
- fprintf fmt "%s"
+ fprintf
+ fmt
+ "%s"
(match mode with
| AdaNoMode ->
""
@@ -47,7 +49,9 @@ let pp_parameter_mode fmt mode =
"in out")
let pp_kind_def fmt kind_def =
- fprintf fmt "%s"
+ fprintf
+ fmt
+ "%s"
(match kind_def with
| AdaType ->
"type"
@@ -61,7 +65,9 @@ let pp_kind_def fmt kind_def =
"package body")
let pp_visibility fmt visibility =
- fprintf fmt "%s"
+ fprintf
+ fmt
+ "%s"
(match visibility with
| AdaNoVisibility ->
""
@@ -87,19 +93,26 @@ let pp_args ~pp_sep fmt = function
| [] ->
fprintf fmt ""
| args ->
- fprintf fmt " (@[<v>%a)@]"
+ fprintf
+ fmt
+ " (@[<v>%a)@]"
(pp_print_list ~pp_sep (fun fmt pp -> pp fmt))
args
let pp_block fmt pp_item_list =
- pp_print_list ~pp_open_box:pp_open_vbox0
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(fun fmt () -> pp_print_string fmt " ")
- ~pp_epilogue:pp_print_semicolon ~pp_sep:pp_print_semicolon
+ ~pp_epilogue:pp_print_semicolon
+ ~pp_sep:pp_print_semicolon
(fun fmt pp -> pp fmt)
- fmt pp_item_list
+ fmt
+ pp_item_list
let pp_and l fmt =
- fprintf fmt "(%t)"
+ fprintf
+ fmt
+ "(%t)"
(pp_group ~pp_sep:(fun fmt () -> fprintf fmt "@ and then ") l)
let pp_or l fmt =
@@ -121,7 +134,9 @@ let pp_ada_with fmt = function
let pp_import fmt =
if not import then fprintf fmt ""
else
- fprintf fmt " Import%a"
+ fprintf
+ fmt
+ " Import%a"
(if contract = [] then pp_print_nothing else pp_print_comma)
()
in
@@ -136,8 +151,14 @@ let pp_ada_with fmt = function
if pres != [] && posts != [] then fprintf fmt ",@,"
else fprintf fmt ""
in
- fprintf fmt "@, @[<v>%a%t%a@]" (pp_aspect "Pre") pres sep
- (pp_aspect "Post") posts
+ fprintf
+ fmt
+ "@, @[<v>%a%t%a@]"
+ (pp_aspect "Pre")
+ pres
+ sep
+ (pp_aspect "Post")
+ posts
in
fprintf fmt " with%t%t%t" pp_ghost pp_import pp_contract
@@ -152,9 +173,16 @@ let pp_generic_instanciation (pp_name, pp_type) fmt =
@param pp_type a format printer wich print the variable type @param fmt the
formater to print on @param id the variable **)
let pp_var_decl (mode, pp_name, pp_type, with_statement) fmt =
- fprintf fmt "%t: %a%s%t%a" pp_name pp_parameter_mode mode
+ fprintf
+ fmt
+ "%t: %a%s%t%a"
+ pp_name
+ pp_parameter_mode
+ mode
(if mode = AdaNoMode then "" else " ")
- pp_type pp_ada_with with_statement
+ pp_type
+ pp_ada_with
+ with_statement
let apply_var_decl_lists var_list =
List.map (fun l -> List.map pp_var_decl l) var_list
@@ -188,33 +216,55 @@ and pp_content pp_name fmt = function
| AdaSimpleContent pp_content ->
fprintf fmt " is@, @[<v 2>(%t)@]" pp_content
| AdaProcedureContent (local_list, pp_instr_list) ->
- fprintf fmt " is@,%abegin@,%aend %t" pp_block
+ fprintf
+ fmt
+ " is@,%abegin@,%aend %t"
+ pp_block
(List.map
(fun l -> pp_group ~pp_sep:pp_print_semicolon (List.map pp_local l))
local_list)
- pp_block pp_instr_list pp_name
+ pp_block
+ pp_instr_list
+ pp_name
| AdaRecord var_list ->
assert (var_list != []);
let pp_lists = apply_var_decl_lists var_list in
- fprintf fmt " is@, @[<v>record@, @[<v>%a@]@,end record@]" pp_block
+ fprintf
+ fmt
+ " is@, @[<v>record@, @[<v>%a@]@,end record@]"
+ pp_block
(List.map (pp_group ~pp_sep:pp_print_semicolon) pp_lists)
| AdaPackageInstanciation (pp_name, instanciations) ->
- fprintf fmt " is new %t%a" pp_name
+ fprintf
+ fmt
+ " is new %t%a"
+ pp_name
(pp_args ~pp_sep:pp_print_comma)
(List.map pp_generic_instanciation instanciations)
and pp_def fmt
(pp_generics, kind_def, pp_name, args, pp_type_opt, content, pp_with_opt) =
let pp_arg_lists = apply_var_decl_lists args in
- fprintf fmt "%a%a %t%a%a%a%a" pp_generic pp_generics pp_kind_def kind_def
+ fprintf
+ fmt
+ "%a%a %t%a%a%a%a"
+ pp_generic
+ pp_generics
+ pp_kind_def
+ kind_def
pp_name
(pp_args ~pp_sep:pp_print_semicolon)
(List.map (pp_group ~pp_sep:pp_print_semicolon) pp_arg_lists)
- (pp_opt "return") pp_type_opt (pp_content pp_name) content pp_ada_with
+ (pp_opt "return")
+ pp_type_opt
+ (pp_content pp_name)
+ content
+ pp_ada_with
pp_with_opt
and pp_package_instanciation pp_name pp_base_name fmt instanciations =
- pp_def fmt
+ pp_def
+ fmt
( [],
AdaPackageDecl,
pp_name,
@@ -231,7 +281,8 @@ let pp_adastring pp_content fmt = fprintf fmt "\"%t\"" pp_content
print on @param machine the machine **)
let pp_package pp_name pp_generics body fmt pp_content =
let kind = if body then AdaPackageBody else AdaPackageDecl in
- pp_def fmt
+ pp_def
+ fmt
(pp_generics, kind, pp_name, [], None, AdaPackageContent pp_content, None)
(** Print a new statement instantiating a generic package. @param fmt the
@@ -265,7 +316,8 @@ let pp_predicate pp_name args imported fmt content_opt =
| None ->
AdaNoContent, Some (true, imported, [], [])
in
- pp_def fmt
+ pp_def
+ fmt
([], AdaFunction, pp_name, args, Some pp_boolean_type, content, with_st)
(** Print a cleaned an identifier for ada exportation : Ada names must not start
@@ -359,7 +411,9 @@ let pp_clean_ada_identifier fmt name =
s
| i when String.get s i == '_' && String.get s (i + 1) == '_' ->
remove_double_underscore
- (sprintf "%s%s" (String.sub s 0 i)
+ (sprintf
+ "%s%s"
+ (String.sub s 0 i)
(String.sub s (i + 1) (String.length s - i - 1)))
i
| i ->
@@ -396,7 +450,10 @@ let pp_oneline_comment fmt s =
fprintf fmt "-- %s@," s
let pp_call fmt (pp_name, args) =
- fprintf fmt "%t%a" pp_name
+ fprintf
+ fmt
+ "%t%a"
+ pp_name
(pp_args ~pp_sep:pp_print_comma)
(List.map (pp_group ~pp_sep:pp_print_comma) args)
diff --git a/src/backends/C/c_backend.ml b/src/backends/C/c_backend.ml
index 9bb5511a..561053e4 100644
--- a/src/backends/C/c_backend.ml
+++ b/src/backends/C/c_backend.ml
@@ -118,7 +118,7 @@ let print_c_header basename =
let header_file = destname ^ ".h" in
with_out_file header_file (fun header_fmt ->
assert (not lusic.obsolete);
- Header.print_header_from_header header_fmt basename lusic.contents)
+ Header.pp_header_from_header header_fmt basename lusic.contents)
let translate_to_c generate_c_header basename prog machines dependencies =
let header_m, source_m, source_main_m, makefile_m =
@@ -133,7 +133,7 @@ let translate_to_c generate_c_header basename prog machines dependencies =
let open C_backend_spec in
( C_backend_header.((module HdrMod : MODIFIERS_HDR)),
C_backend_src.((module SrcMod : MODIFIERS_SRC)),
- C_backend_main.((module EmptyMod : MODIFIERS_MAINSRC)),
+ C_backend_main.((module MainMod : MODIFIERS_MAINSRC)),
C_backend_makefile.((module MakefileMod : MODIFIERS_MKF)) )
| SpecC ->
assert false
@@ -145,10 +145,10 @@ let translate_to_c generate_c_header basename prog machines dependencies =
let module Makefile = C_backend_makefile.Main ((val makefile_m)) in
(* let module CMakefile = C_backend_cmake.Main (MakefileMod) in *)
let funs =
- ( Header.print_alloc_header,
- Source.print_lib_c,
- SourceMain.print_main_c,
- Makefile.print_makefile )
+ ( Header.pp_alloc_header,
+ Source.pp_lib_c,
+ SourceMain.pp_main_c,
+ Makefile.pp_makefile )
(* CMakefile.print_makefile *)
in
if generate_c_header then print_c_header basename;
diff --git a/src/backends/C/c_backend_cmake.ml b/src/backends/C/c_backend_cmake.ml
index c0b726db..ef03dda3 100644
--- a/src/backends/C/c_backend_cmake.ml
+++ b/src/backends/C/c_backend_cmake.ml
@@ -33,7 +33,8 @@ let header_libs header =
Utils.list_union nd.nodei_in_lib accu
| _ ->
accu)
- [] header
+ []
+ header
let compiled_dependencies dep =
List.filter (fun (Dep (_, _, header, _)) -> header_has_code header) dep
@@ -42,7 +43,8 @@ let lib_dependencies dep =
List.fold_left
(fun accu (Dep (_, _, header, _)) ->
Utils.list_union (header_libs header) accu)
- [] dep
+ []
+ dep
let fprintf_dependencies fmt (dep : dep_t list) =
let compiled_dep = compiled_dependencies dep in
@@ -86,7 +88,9 @@ functor
fprintf fmt "GCC=gcc@.";
fprintf fmt "LUSTREC=%s@." Sys.executable_name;
- fprintf fmt "LUSTREC_BASE=%s@."
+ fprintf
+ fmt
+ "LUSTREC_BASE=%s@."
(Filename.dirname (Filename.dirname Sys.executable_name));
fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
fprintf fmt "@.";
@@ -96,12 +100,16 @@ functor
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_dependencies fmt dependencies;
- fprintf fmt "\t${GCC} -O0 -o %s_%s io_frontend.o %a %s.o %s_main.o %a@."
- basename nodename
+ fprintf
+ fmt
+ "\t${GCC} -O0 -o %s_%s io_frontend.o %a %s.o %s_main.o %a@."
+ basename
+ nodename
(Utils.fprintf_list ~sep:" " (fun fmt (Dep (_, s, _, _)) ->
Format.fprintf fmt "%s.o" s))
(compiled_dependencies dependencies)
- basename (* library .o *) basename
+ basename
+ (* library .o *) basename
(* main function . o *)
(Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib))
(lib_dependencies dependencies);
diff --git a/src/backends/C/c_backend_common.ml b/src/backends/C/c_backend_common.ml
index 308fa56c..ea86dbbb 100644
--- a/src/backends/C/c_backend_common.ml
+++ b/src/backends/C/c_backend_common.ml
@@ -18,7 +18,8 @@ open Machine_code_common
module Mpfr = Lustrec_mpfr
let pp_print_version fmt () =
- fprintf fmt
+ fprintf
+ fmt
"/* @[<v>C code generated by %s@,\
Version number %s@,\
Code is %s compliant@,\
@@ -141,11 +142,14 @@ let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id
-let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
+let pp_machine_static_declare_name ?(ghost = false) fmt id =
+ fprintf fmt "%s_DECLARE%s" id (if ghost then "_GHOST" else "")
-let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
+let pp_machine_static_link_name ?(ghost = false) fmt id =
+ fprintf fmt "%s_LINK%s" id (if ghost then "_GHOST" else "")
-let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
+let pp_machine_static_alloc_name ?(ghost = false) fmt id =
+ fprintf fmt "%s_ALLOC%s" id (if ghost then "_GHOST" else "")
let pp_machine_set_reset_name fmt id = fprintf fmt "%s_set_reset" id
@@ -160,8 +164,19 @@ let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
let pp_mod pp_val v1 v2 fmt =
if !Options.integer_div_euclidean then
(* (a mod_C b) + (a mod_C b < 0 ? abs(b) : 0) *)
- fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))" pp_val v1 pp_val
- v2 pp_val v1 pp_val v2 pp_val v2
+ fprintf
+ fmt
+ "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))"
+ pp_val
+ v1
+ pp_val
+ v2
+ pp_val
+ v1
+ pp_val
+ v2
+ pp_val
+ v2
else
(* Regular behavior: printing a % *)
fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
@@ -200,7 +215,7 @@ let pp_basic_lib_fun is_int i pp_val fmt vl =
fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2
| _ ->
(* TODO: raise proper error *)
- eprintf "internal error: Basic_library.pp_c %s@." i;
+ eprintf "internal error: C_backend_common.pp_basic_lib_fun %s@." i;
assert false
let rec pp_c_dimension fmt dim =
@@ -213,10 +228,19 @@ let rec pp_c_dimension fmt dim =
| Dbool b ->
fprintf fmt "%B" b
| Dite (i, t, e) ->
- fprintf fmt "((%a)?%a:%a)" pp_c_dimension i pp_c_dimension t pp_c_dimension
+ fprintf
+ fmt
+ "((%a)?%a:%a)"
+ pp_c_dimension
+ i
+ pp_c_dimension
+ t
+ pp_c_dimension
e
| Dappl (f, args) ->
- fprintf fmt "%a"
+ fprintf
+ fmt
+ "%a"
(pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension)
args
| Dlink dim' ->
@@ -248,9 +272,14 @@ let pp_basic_c_type ?(pp_c_basic_type_desc = pp_c_basic_type_desc) ?var_opt fmt
let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
let rec aux t pp_suffix =
if is_basic_c_type t then
- fprintf fmt "%a %s%a"
+ fprintf
+ fmt
+ "%a %s%a"
(pp_basic_c_type ?pp_c_basic_type_desc ?var_opt)
- t var_id pp_suffix ()
+ t
+ var_id
+ pp_suffix
+ ()
else
let open Types in
match (repr t).tdesc with
@@ -270,7 +299,7 @@ let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
fprintf fmt "void (*%s)()" var_id
| _ ->
(* TODO: raise proper error *)
- eprintf "internal error: C_backend_common.pp_c_type %a@." print_ty t;
+ eprintf "internal error: C_backend_common.pp_c_type %a@." pp t;
assert false
in
aux t (fun _ () -> ())
@@ -283,7 +312,8 @@ let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) (Utils.duplicate 0
(Dimension.size_const_dimension d)) | _ -> assert false *)
let pp_c_tag fmt t =
- pp_print_string fmt
+ pp_print_string
+ fmt
(if t = tag_true then "1" else if t = tag_false then "0" else t)
(* Prints a constant value *)
@@ -307,14 +337,20 @@ let rec pp_c_const fmt c =
let reset_flag_name = "_reset"
let pp_reset_flag ?(indirect = true) pp_stru fmt stru =
- fprintf fmt "%a%s%s" pp_stru stru
+ fprintf
+ fmt
+ "%a%s%s"
+ pp_stru
+ stru
(if indirect then "->" else ".")
reset_flag_name
let pp_reset_flag' ?indirect fmt = pp_reset_flag ?indirect pp_print_string fmt
let pp_reset_assign self fmt b =
- fprintf fmt "%a = %i;"
+ fprintf
+ fmt
+ "%a = %i;"
(pp_reset_flag' ~indirect:true)
self
(if b then 1 else 0)
@@ -333,7 +369,8 @@ let rec pp_c_val m self pp_var fmt v =
fprintf fmt "%a[%a]" pp_c_val t pp_c_val i
| Power (v, _) ->
(* TODO: raise proper error *)
- eprintf "internal error: C_backend_common.pp_c_val %a@."
+ eprintf
+ "internal error: C_backend_common.pp_c_val %a@."
(Machine_code_common.pp_val m)
v;
assert false
@@ -381,7 +418,8 @@ let pp_c_var_write m fmt id =
dimensions, as it is the case for generics *)
let pp_c_decl_input_var fmt id =
if !Options.ansi && Types.is_address_type id.var_type then
- pp_c_type ~var_opt:id
+ pp_c_type
+ ~var_opt:id
(sprintf "(*%s)" id.var_id)
fmt
(Types.array_base_type id.var_type)
@@ -395,7 +433,8 @@ let pp_c_decl_output_var fmt id =
if (not !Options.ansi) && Types.is_address_type id.var_type then
pp_c_type ~var_opt:id id.var_id fmt id.var_type
else
- pp_c_type ~var_opt:id
+ pp_c_type
+ ~var_opt:id
(sprintf "(*%s)" id.var_id)
fmt
(Types.array_base_type id.var_type)
@@ -405,13 +444,17 @@ let pp_c_decl_output_var fmt id =
the full type *)
let pp_c_decl_local_var ?pp_c_basic_type_desc m fmt id =
if id.var_dec_const then
- fprintf fmt "%a = %a"
+ fprintf
+ fmt
+ "%a = %a"
(pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id)
id.var_type
(pp_c_val m "" (pp_c_var_read m))
(Machine_code_common.get_const_assign m id)
else
- fprintf fmt "%a"
+ fprintf
+ fmt
+ "%a"
(pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id)
id.var_type
@@ -426,7 +469,9 @@ let pp_c_decl_struct_var fmt id =
else pp_c_type id.var_id fmt id.var_type
let pp_c_decl_instance_var ?(ghost = false) fmt (name, (node, _)) =
- fprintf fmt "%a %s%s"
+ fprintf
+ fmt
+ "%a %s%s"
(pp_machine_memtype_name ~ghost)
(node_name node)
(if ghost then "" else "*")
@@ -468,7 +513,8 @@ let has_c_prototype funname dependencies =
| _ ->
assert false
else None)
- None dependencies
+ None
+ dependencies
in
match imported_node_opt with
| None ->
@@ -573,14 +619,19 @@ let rec pp_c_const_suffix var_type fmt c =
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
+ fprintf
+ fmt
+ "(%a[])%a"
+ (pp_c_type "")
+ var_type
(pp_print_braced (pp_c_const_suffix var_type))
ca
| Const_struct fl ->
pp_print_braced
(fun fmt (f, c) ->
(pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)
- fmt fl
+ fmt
+ fl
| Const_string _ | Const_modeid _ ->
assert false
(* string occurs in annotations not in C *)
@@ -588,31 +639,55 @@ let rec pp_c_const_suffix var_type fmt c =
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
let rec pp_value_suffix ?(indirect = true) m self var_type loop_vars pp_var fmt
value =
- (*eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type
- Machine_code.pp_val value pp_suffix loop_vars;*)
+ (*eprintf "pp_value_suffix: %a %a %a@." Types.pp var_type Machine_code.pp_val
+ value pp_suffix loop_vars;*)
let pp_suffix =
pp_suffix (pp_value_suffix ~indirect m self var_type [] pp_var)
in
match loop_vars, value.value_desc with
| (x, LAcc i) :: q, _ when is_const_index i ->
let r = ref (Dimension.size_const (dimension_of_value i)) in
- pp_value_suffix ~indirect m self var_type ((x, LInt r) :: q) pp_var fmt
+ pp_value_suffix
+ ~indirect
+ m
+ self
+ var_type
+ ((x, LInt r) :: q)
+ pp_var
+ fmt
value
| (_, LInt r) :: q, Cst (Const_array cl) ->
let var_type = Types.array_element_type var_type in
- pp_value_suffix ~indirect m self var_type q pp_var fmt
+ pp_value_suffix
+ ~indirect
+ m
+ self
+ var_type
+ q
+ pp_var
+ fmt
(mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
| (_, LInt r) :: q, Array vl ->
let var_type = Types.array_element_type var_type in
pp_value_suffix ~indirect m self var_type q pp_var fmt (List.nth vl !r)
| loop_var :: q, Array vl ->
let var_type = Types.array_element_type var_type in
- fprintf fmt "(%a[])%a%a" (pp_c_type "") var_type
+ fprintf
+ fmt
+ "(%a[])%a%a"
+ (pp_c_type "")
+ var_type
(pp_print_braced (pp_value_suffix ~indirect m self var_type q pp_var))
- vl pp_suffix [ loop_var ]
+ vl
+ pp_suffix
+ [ loop_var ]
| [], Array vl ->
let var_type = Types.array_element_type var_type in
- fprintf fmt "(%a[])%a" (pp_c_type "") var_type
+ fprintf
+ fmt
+ "(%a[])%a"
+ (pp_c_type "")
+ var_type
(pp_print_braced (pp_value_suffix ~indirect m self var_type [] pp_var))
vl
| _ :: q, Power (v, _) ->
@@ -622,12 +697,18 @@ let rec pp_value_suffix ?(indirect = true) m self var_type loop_vars pp_var fmt
(Types.is_int_type value.value_type)
n
(pp_value_suffix ~indirect m self var_type loop_vars pp_var)
- fmt vl
+ fmt
+ vl
| _, Access (v, i) ->
let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
- pp_value_suffix m self var_type
+ pp_value_suffix
+ m
+ self
+ var_type
((Dimension.mkdim_var (), LAcc i) :: loop_vars)
- pp_var fmt v
+ pp_var
+ fmt
+ v
| _, Var v ->
if is_memory m v then
(* array memory vars are represented by an indirection to a local var with
@@ -635,21 +716,39 @@ let rec pp_value_suffix ?(indirect = true) m self var_type loop_vars pp_var fmt
if Types.is_array_type v.var_type then
fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
else
- fprintf fmt "%s%s_reg.%a%a" self
+ fprintf
+ fmt
+ "%s%s_reg.%a%a"
+ self
(if indirect then "->" else ".")
- pp_var v pp_suffix loop_vars
+ pp_var
+ v
+ pp_suffix
+ loop_vars
else if is_reset_flag v then
- fprintf fmt "%s%s%a%a" self
+ fprintf
+ fmt
+ "%s%s%a%a"
+ self
(if indirect then "->" else ".")
- pp_var v pp_suffix loop_vars
+ pp_var
+ v
+ pp_suffix
+ loop_vars
else fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
| _, Cst cst ->
pp_c_const_suffix var_type fmt cst
| _, ResetFlag ->
pp_reset_flag' fmt self
| _, _ ->
- eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@."
- Types.print_ty var_type (pp_val m) value pp_suffix loop_vars;
+ eprintf
+ "internal error: C_backend_common.pp_value_suffix %a %a %a@."
+ Types.pp
+ var_type
+ (pp_val m)
+ value
+ pp_suffix
+ loop_vars;
assert false
(********************************************************************************************)
@@ -670,7 +769,9 @@ let rec pp_value_suffix ?(indirect = true) m self var_type loop_vars pp_var fmt
let pp_machine_struct ?(ghost = false) fmt m =
if not (fst (Machine_code_common.get_stateless_status m)) then
(* Define struct *)
- fprintf fmt "@[<v 2>%a {@,_Bool _reset;%a%a@]@,};"
+ fprintf
+ fmt
+ "@[<v 2>%a {@,_Bool _reset;%a%a@]@,};"
(pp_machine_memtype_name ~ghost)
m.mname.node_id
(if ghost then
@@ -680,15 +781,20 @@ let pp_machine_struct ?(ghost = false) fmt m =
| _ ->
fprintf fmt "@,%a _reg;" pp_machine_regtype_name m.mname.node_id
else
- pp_print_list ~pp_open_box:pp_open_vbox0
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(fun fmt () ->
fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id)
- ~pp_sep:pp_print_semicolon ~pp_eol:pp_print_semicolon'
+ ~pp_sep:pp_print_semicolon
+ ~pp_eol:pp_print_semicolon'
~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;")
pp_c_decl_struct_var)
m.mmemory
- (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
- ~pp_sep:pp_print_semicolon ~pp_eol:pp_print_semicolon'
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:pp_print_cut
+ ~pp_sep:pp_print_semicolon
+ ~pp_eol:pp_print_semicolon'
(pp_c_decl_instance_var ~ghost))
m.minstances
@@ -703,14 +809,22 @@ let pp_global_clear_prototype fmt baseNAME =
fprintf fmt "void %a ()" pp_global_clear_name baseNAME
let pp_alloc_prototype fmt (name, static) =
- fprintf fmt "%a * %a %a"
+ fprintf
+ fmt
+ "%a * %a %a"
(pp_machine_memtype_name ~ghost:false)
- name pp_machine_alloc_name name
+ name
+ pp_machine_alloc_name
+ name
(pp_print_parenthesized pp_c_decl_input_var)
static
let pp_dealloc_prototype fmt name =
- fprintf fmt "void %a (%a * _alloc)" pp_machine_dealloc_name name
+ fprintf
+ fmt
+ "void %a (%a * _alloc)"
+ pp_machine_dealloc_name
+ name
(pp_machine_memtype_name ~ghost:false)
name
@@ -728,58 +842,95 @@ end
module Protos (Mod : MODIFIERS_GHOST_PROTO) = struct
let pp_mem_ghost name fmt mem =
- pp_machine_decl ~ghost:true
+ pp_machine_decl
+ ~ghost:true
(fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem)
- fmt (name, mem)
+ fmt
+ (name, mem)
- let print_clear_reset_prototype self mem fmt (name, static) =
- fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" pp_machine_clear_reset_name name
+ let pp_clear_reset_prototype self mem fmt (name, static) =
+ fprintf
+ fmt
+ "@[<v>void %a (%a%a *%s)%a@]"
+ pp_machine_clear_reset_name
+ name
(pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
static
(pp_machine_memtype_name ~ghost:false)
- name self
+ name
+ self
(Mod.pp_ghost_parameters ~cut:true)
[ mem, pp_mem_ghost name ]
- let print_set_reset_prototype self mem fmt (name, static) =
- fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" pp_machine_set_reset_name name
+ let pp_set_reset_prototype self mem fmt (name, static) =
+ fprintf
+ fmt
+ "@[<v>void %a (%a%a *%s)%a@]"
+ pp_machine_set_reset_name
+ name
(pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
static
(pp_machine_memtype_name ~ghost:false)
- name self
+ name
+ self
(Mod.pp_ghost_parameters ~cut:true)
[ mem, pp_mem_ghost name ]
- let print_step_prototype self mem fmt (name, inputs, outputs) =
- fprintf fmt "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]" pp_machine_step_name name
- (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
+ let pp_step_prototype self mem fmt (name, inputs, outputs) =
+ fprintf
+ fmt
+ "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]"
+ pp_machine_step_name
+ name
+ (pp_comma_list
+ ~pp_eol:pp_print_comma
+ ~pp_epilogue:pp_print_cut
pp_c_decl_input_var)
inputs
- (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
+ (pp_comma_list
+ ~pp_eol:pp_print_comma
+ ~pp_epilogue:pp_print_cut
pp_c_decl_output_var)
outputs
(pp_machine_memtype_name ~ghost:false)
- name self
+ name
+ self
(Mod.pp_ghost_parameters ~cut:true)
[ mem, pp_mem_ghost name ]
- let print_init_prototype self fmt (name, static) =
- fprintf fmt "void %a (%a%a *%s)" pp_machine_init_name name
+ let pp_init_prototype self fmt (name, static) =
+ fprintf
+ fmt
+ "void %a (%a%a *%s)"
+ pp_machine_init_name
+ name
(pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
static
(pp_machine_memtype_name ~ghost:false)
- name self
+ name
+ self
- let print_clear_prototype self fmt (name, static) =
- fprintf fmt "void %a (%a%a *%s)" pp_machine_clear_name name
+ let pp_clear_prototype self fmt (name, static) =
+ fprintf
+ fmt
+ "void %a (%a%a *%s)"
+ pp_machine_clear_name
+ name
(pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
static
(pp_machine_memtype_name ~ghost:false)
- name self
+ name
+ self
- let print_stateless_prototype fmt (name, inputs, outputs) =
- fprintf fmt "void %a (@[<v>%a%a@])" pp_machine_step_name name
- (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
+ let pp_stateless_prototype fmt (name, inputs, outputs) =
+ fprintf
+ fmt
+ "void %a (@[<v>%a%a@])"
+ pp_machine_step_name
+ name
+ (pp_comma_list
+ ~pp_eol:pp_print_comma
+ ~pp_epilogue:pp_print_cut
pp_c_decl_input_var)
inputs
(pp_comma_list pp_c_decl_output_var)
@@ -818,8 +969,15 @@ let pp_initialize m self pp_var fmt var =
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
+ 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
@@ -839,8 +997,15 @@ let pp_clear m self pp_var fmt var =
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
+ 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
@@ -856,33 +1021,55 @@ let pp_clear m self pp_var fmt var =
(*** Common functions for main ***)
let pp_file file_suffix fmt (typ, arg) =
- fprintf fmt
+ fprintf
+ fmt
"@[<v 2>if (traces) {@,fprintf(f_%s, \"%%%s\\n\", %s);@,fflush(f_%s);@]@,}"
- file_suffix typ arg file_suffix
+ file_suffix
+ typ
+ arg
+ file_suffix
let pp_put_var fmt file_suffix name var_type var_id =
- let pp_file = pp_file ("out" ^ file_suffix) in
+ let opt = !Options.c_main_options in
+ let pp_file fmt =
+ if opt then fprintf fmt "@,%a" (pp_file ("out" ^ file_suffix))
+ else pp_print_nothing fmt
+ in
let unclocked_t = Types.unclock_type var_type in
- fprintf fmt "@[<v>%a@]"
+ fprintf
+ fmt
+ "@[<v>%a@]"
(fun fmt () ->
if Types.is_int_type unclocked_t then
- fprintf fmt "_put_int(\"%s\", %s);@,%a" name var_id pp_file ("d", var_id)
+ fprintf fmt "_put_int(\"%s\", %s);%a" name var_id pp_file ("d", var_id)
else if Types.is_bool_type unclocked_t then
- fprintf fmt "_put_bool(\"%s\", %s);@,%a" name var_id pp_file
- ("i", var_id)
+ fprintf fmt "_put_bool(\"%s\", %s);%a" name var_id pp_file ("i", var_id)
else if Types.is_real_type unclocked_t then
if !Options.mpfr then
- fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@,%a" name
- var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double pp_file
+ fprintf
+ fmt
+ "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);%a"
+ name
+ var_id
+ (Mpfr.mpfr_rnd ())
+ !Options.print_prec_double
+ pp_file
( ".*f",
string_of_int !Options.print_prec_double
^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)" )
else
- fprintf fmt "_put_double(\"%s\", %s, %i);@,%a" name var_id
- !Options.print_prec_double pp_file
+ fprintf
+ fmt
+ "_put_double(\"%s\", %s, %i);%a"
+ name
+ var_id
+ !Options.print_prec_double
+ pp_file
(".*f", string_of_int !Options.print_prec_double ^ ", " ^ var_id)
else (
- eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty
+ eprintf
+ "Impossible to print the _put_xx for type %a@.@?"
+ Types.pp
var_type;
assert false))
()
@@ -895,7 +1082,8 @@ let pp_file_decl fmt inout idx =
let pp_file_open fmt inout idx =
let idx = idx + 1 in
(* we start from 1: in1, in2, ... *)
- fprintf fmt
+ fprintf
+ fmt
"@[<v>const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@,\
size_t l%s%i = strlen(dir) + strlen(prefix) + \
strlen(cst_char_suffix_%s%i);@,\
@@ -906,8 +1094,34 @@ let pp_file_open fmt inout idx =
strcat(f_%s%i_name, cst_char_suffix_%s%i);@,\
f_%s%i = fopen(f_%s%i_name, \"w\");@,\
free(f_%s%i_name);@]"
- inout idx inout idx inout idx inout idx inout idx inout idx inout idx inout
- idx inout idx inout idx inout idx inout idx inout idx inout idx;
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx
+ inout
+ idx;
"f_" ^ inout ^ string_of_int idx
let pp_basic_assign pp_var fmt typ var_name value =
@@ -922,8 +1136,8 @@ let pp_assign m self pp_var fmt (var, value) =
let depth = expansion_depth value in
let var_type = var.var_type in
let var = mk_val (Var var) var_type in
- (*eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name
- pp_val value depth;*)
+ (*eprintf "pp_assign %a %a %a %d@." Types.pp var_type pp_val var_name pp_val
+ value depth;*)
let loop_vars = mk_loop_variables m var_type depth in
let reordered_loop_vars = reorder_loop_variables loop_vars in
let rec aux typ fmt vars =
@@ -931,17 +1145,31 @@ let pp_assign m self pp_var fmt (var, value) =
| [] ->
pp_basic_assign
(pp_value_suffix m self var_type loop_vars pp_var)
- fmt typ var value
+ fmt
+ typ
+ var
+ value
| (d, LVar i) :: q ->
let typ' = Types.array_element_type typ in
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
- fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" i i i
- pp_c_dimension d i (aux typ') q
+ fprintf
+ fmt
+ "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
+ i
+ i
+ i
+ pp_c_dimension
+ d
+ i
+ (aux typ')
+ q
| (d, LInt r) :: 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 d) in
- fprintf fmt "@[<v 2>{@,%a@]@,}"
+ fprintf
+ fmt
+ "@[<v 2>{@,%a@]@,}"
(pp_print_list (fun fmt i ->
r := i;
aux typ' fmt q))
@@ -954,6 +1182,179 @@ let pp_assign m self pp_var fmt (var, value) =
aux var_type fmt reordered_loop_vars
(*eprintf "end pp_assign@.";*)
+let rec pp_static_val pp_var fmt v =
+ match v.value_desc with
+ | Cst c ->
+ pp_c_const fmt c
+ | Var v ->
+ pp_var fmt v
+ | Fun (n, vl) ->
+ pp_basic_lib_fun
+ (Types.is_int_type v.value_type)
+ n
+ (pp_static_val pp_var)
+ fmt
+ vl
+ | _ ->
+ (* TODO: raise proper error *)
+ eprintf "Internal error: C_backend_common.pp_static_val";
+ assert false
+
+let pp_constant_decl (m, attr, inst) pp_var fmt v =
+ fprintf
+ fmt
+ "%s %a = %a"
+ attr
+ (pp_c_type (sprintf "%s ## %s" inst v.var_id))
+ v.var_type
+ (pp_static_val pp_var)
+ (get_const_assign m v)
+
+let pp_var inst const_locals fmt v =
+ if List.mem v const_locals then fprintf fmt "%s ## %s" inst v.var_id
+ else fprintf fmt "%s" v.var_id
+
+let pp_static_constant_decl ((_, _, inst) as macro) fmt const_locals =
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\")
+ ~pp_eol:(pp_print_endcut ";\\")
+ (pp_constant_decl macro (pp_var inst const_locals))
+ fmt
+ const_locals
+
+let pp_static_declare_instance ?(ghost = false) (m, attr, inst) const_locals fmt
+ (i, (n, static)) =
+ let values = List.map (value_of_dimension m) static in
+ fprintf
+ fmt
+ "%a(%s, %a%s)"
+ (pp_machine_static_declare_name ~ghost)
+ (node_name n)
+ attr
+ (pp_print_list
+ ~pp_open_box:pp_open_hbox
+ ~pp_sep:pp_print_comma
+ ~pp_eol:pp_print_comma
+ (pp_static_val (pp_var inst const_locals)))
+ values
+ i
+
+let pp_static_declare_macro ?(ghost = false) fmt ((m, attr, inst) as macro) =
+ let const_locals =
+ List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals
+ in
+ let array_mem =
+ List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
+ in
+ fprintf
+ fmt
+ "@[<v 2>#define %a(%s, %a%s)\\@,%a%s %a %s;\\@,%a%a;@]"
+ (pp_machine_static_declare_name ~ghost)
+ m.mname.node_id
+ attr
+ (pp_print_list
+ ~pp_sep:pp_print_comma
+ ~pp_eol:pp_print_comma
+ (pp_c_var_read m))
+ m.mstatic
+ inst
+ (* constants *)
+ (pp_static_constant_decl macro)
+ const_locals
+ attr
+ (pp_machine_memtype_name ~ghost)
+ m.mname.node_id
+ inst
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\")
+ ~pp_eol:(pp_print_endcut ";\\")
+ (pp_c_decl_local_var m))
+ array_mem
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\")
+ (fun fmt (i', m') ->
+ let path = sprintf "%s ## _%s" inst i' in
+ fprintf
+ fmt
+ "%a"
+ (pp_static_declare_instance ~ghost macro const_locals)
+ (path, m')))
+ m.minstances
+
+let pp_static_link_instance ?(ghost = false) fmt (i, (m, _)) =
+ fprintf fmt "%a(%s)" (pp_machine_static_link_name ~ghost) (node_name m) i
+
+(* Allocation of a node struct: - if node memory is an array/matrix/etc, we cast
+ it to a pointer (see pp_registers_struct) *)
+let pp_static_link_macro ?(ghost = false) fmt (m, _, inst) =
+ let array_mem =
+ List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
+ in
+ fprintf
+ fmt
+ "@[<v>@[<v 2>#define %a(%s) do {\\@,%a%a;\\@]@,} while (0)@]"
+ (pp_machine_static_link_name ~ghost)
+ m.mname.node_id
+ inst
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\")
+ ~pp_eol:(pp_print_endcut ";\\")
+ (fun fmt v ->
+ fprintf
+ fmt
+ "%s._reg.%s = (%a*) &%s"
+ inst
+ v.var_id
+ (fun fmt v -> pp_c_type "" fmt (Types.array_base_type v.var_type))
+ v
+ v.var_id))
+ array_mem
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\")
+ (fun fmt (i', m') ->
+ let path = sprintf "%s ## _%s" inst i' in
+ fprintf
+ fmt
+ "%a;\\@,%s.%s = %s%s"
+ (pp_static_link_instance ~ghost)
+ (path, m')
+ inst
+ i'
+ (if ghost then "" else "&")
+ path))
+ m.minstances
+
+let pp_static_alloc_macro ?(ghost = false) fmt (m, attr, inst) =
+ fprintf
+ fmt
+ "@[<v>@[<v 2>#define %a(%s, %a%s)\\@,%a(%s, %a%s);\\@,%a(%s);@]@]"
+ (pp_machine_static_alloc_name ~ghost)
+ m.mname.node_id
+ attr
+ (pp_print_list
+ ~pp_sep:pp_print_comma
+ ~pp_eol:pp_print_comma
+ (pp_c_var_read m))
+ m.mstatic
+ inst
+ (pp_machine_static_declare_name ~ghost)
+ m.mname.node_id
+ attr
+ (pp_print_list
+ ~pp_sep:pp_print_comma
+ ~pp_eol:pp_print_comma
+ (pp_c_var_read m))
+ m.mstatic
+ inst
+ (pp_machine_static_link_name ~ghost)
+ m.mname.node_id
+ inst
+
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
(* End: *)
diff --git a/src/backends/C/c_backend_common.mli b/src/backends/C/c_backend_common.mli
index a4629f06..a5a934ed 100644
--- a/src/backends/C/c_backend_common.mli
+++ b/src/backends/C/c_backend_common.mli
@@ -23,7 +23,7 @@ val pp_machine_step_name : formatter -> ident -> unit
val pp_machine_alloc_name : formatter -> ident -> unit
-val pp_machine_static_alloc_name : formatter -> ident -> unit
+val pp_machine_static_alloc_name : ?ghost:bool -> formatter -> ident -> unit
val pp_machine_dealloc_name : formatter -> ident -> unit
@@ -31,9 +31,9 @@ val pp_global_init_name : formatter -> ident -> unit
val pp_global_clear_name : formatter -> ident -> unit
-val pp_machine_static_declare_name : formatter -> ident -> unit
+val pp_machine_static_declare_name : ?ghost:bool -> formatter -> ident -> unit
-val pp_machine_static_link_name : formatter -> ident -> unit
+val pp_machine_static_link_name : ?ghost:bool -> formatter -> ident -> unit
val pp_global_init_prototype : formatter -> ident -> unit
@@ -160,6 +160,15 @@ val pp_clear :
var_decl ->
unit
+val pp_static_declare_macro :
+ ?ghost:bool -> formatter -> machine_t * ident * ident -> unit
+
+val pp_static_link_macro :
+ ?ghost:bool -> formatter -> machine_t * ident * ident -> unit
+
+val pp_static_alloc_macro :
+ ?ghost:bool -> formatter -> machine_t * ident * ident -> unit
+
val mk_call_var_decl : Location.t -> ident -> var_decl
val pp_c_basic_type_desc : Types.t -> string
@@ -243,20 +252,19 @@ end
module EmptyGhostProto : MODIFIERS_GHOST_PROTO
module Protos (Mod : MODIFIERS_GHOST_PROTO) : sig
- val print_stateless_prototype :
+ val pp_stateless_prototype :
formatter -> ident * var_decl list * var_decl list -> unit
- val print_clear_reset_prototype :
+ val pp_clear_reset_prototype :
ident -> ident -> formatter -> ident * var_decl list -> unit
- val print_set_reset_prototype :
+ val pp_set_reset_prototype :
ident -> ident -> formatter -> ident * var_decl list -> unit
- val print_step_prototype :
+ val pp_step_prototype :
ident -> ident -> formatter -> ident * var_decl list * var_decl list -> unit
- val print_init_prototype : ident -> formatter -> ident * var_decl list -> unit
+ val pp_init_prototype : ident -> formatter -> ident * var_decl list -> unit
- val print_clear_prototype :
- ident -> formatter -> ident * var_decl list -> unit
+ val pp_clear_prototype : ident -> formatter -> ident * var_decl list -> unit
end
diff --git a/src/backends/C/c_backend_header.ml b/src/backends/C/c_backend_header.ml
index f6e95c4a..0dfed110 100644
--- a/src/backends/C/c_backend_header.ml
+++ b/src/backends/C/c_backend_header.ml
@@ -24,20 +24,30 @@ module Mpfr = Lustrec_mpfr
module type MODIFIERS_HDR = sig
module GhostProto : MODIFIERS_GHOST_PROTO
- val print_machine_decl_prefix : formatter -> machine_t -> unit
+ val pp_machine_decl_prefix : formatter -> machine_t -> unit
+
+ val pp_machine_ghost_struct : formatter -> machine_t -> unit
val pp_import_arrow : formatter -> unit -> unit
+
+ val pp_machine_alloc_decl : formatter -> machine_t -> unit
end
module EmptyMod = struct
module GhostProto = EmptyGhostProto
- let print_machine_decl_prefix _ _ = ()
+ let pp_machine_decl_prefix _ _ = ()
+
+ let pp_machine_ghost_struct _ _ = ()
let pp_import_arrow fmt () =
- fprintf fmt "#include \"%s/arrow.h%s\""
+ fprintf
+ fmt
+ "#include \"%s/arrow.h%s\""
(Arrow.arrow_top_decl ()).top_decl_owner
(if !Options.cpp then "pp" else "")
+
+ let pp_machine_alloc_decl _ _ = ()
end
module Main =
@@ -47,166 +57,77 @@ functor
struct
module Protos = Protos (Mod.GhostProto)
- let print_import_standard fmt () =
+ let pp_import_standard fmt () =
(* if Machine_types.has_machine_type () then *)
- fprintf fmt "#include <stdint.h>@,%a%a"
+ fprintf
+ fmt
+ "#include <stdint.h>@,%a%a"
(if !Options.mpfr then pp_print_endcut "#include <mpfr.h>"
else pp_print_nothing)
- () Mod.pp_import_arrow ()
-
- let rec print_static_val pp_var fmt v =
- match v.value_desc with
- | Cst c ->
- pp_c_const fmt c
- | Var v ->
- pp_var fmt v
- | Fun (n, vl) ->
- pp_basic_lib_fun
- (Types.is_int_type v.value_type)
- n (print_static_val pp_var) fmt vl
- | _ ->
- (* TODO: raise proper error *)
- eprintf "Internal error: C_backend_header.print_static_val";
- assert false
-
- let print_constant_decl (m, attr, inst) pp_var fmt v =
- fprintf fmt "%s %a = %a" attr
- (pp_c_type (sprintf "%s ## %s" inst v.var_id))
- v.var_type (print_static_val pp_var) (get_const_assign m v)
-
- let pp_var inst const_locals fmt v =
- if List.mem v const_locals then fprintf fmt "%s ## %s" inst v.var_id
- else fprintf fmt "%s" v.var_id
-
- let print_static_constant_decl ((_, _, inst) as macro) fmt const_locals =
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:(pp_print_endcut ";\\")
- ~pp_eol:(pp_print_endcut ";\\")
- (print_constant_decl macro (pp_var inst const_locals))
- fmt const_locals
-
- let print_static_declare_instance (m, attr, inst) const_locals fmt
- (i, (n, static)) =
- let values = List.map (value_of_dimension m) static in
- fprintf fmt "%a(%s, %a%s)" pp_machine_static_declare_name (node_name n)
- attr
- (pp_print_list ~pp_open_box:pp_open_hbox ~pp_sep:pp_print_comma
- ~pp_eol:pp_print_comma
- (print_static_val (pp_var inst const_locals)))
- values i
-
- let print_static_declare_macro fmt ((m, attr, inst) as macro) =
- let const_locals =
- List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals
- in
- let array_mem =
- List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
- in
- fprintf fmt "@[<v 2>#define %a(%s, %a%s)\\@,%a%s %a %s;\\@,%a%a;@]"
- pp_machine_static_declare_name m.mname.node_id attr
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- (pp_c_var_read m))
- m.mstatic inst
- (* constants *)
- (print_static_constant_decl macro)
- const_locals attr
- (pp_machine_memtype_name ~ghost:false)
- m.mname.node_id inst
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\") ~pp_eol:(pp_print_endcut ";\\")
- (pp_c_decl_local_var m))
- array_mem
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\") (fun fmt (i', m') ->
- let path = sprintf "%s ## _%s" inst i' in
- fprintf fmt "%a"
- (print_static_declare_instance macro const_locals)
- (path, m')))
- m.minstances
-
- let print_static_link_instance fmt (i, (m, _)) =
- fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
-
- (* Allocation of a node struct: - if node memory is an array/matrix/etc, we
- cast it to a pointer (see pp_registers_struct) *)
- let print_static_link_macro fmt (m, _, inst) =
- let array_mem =
- List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
- in
- fprintf fmt "@[<v>@[<v 2>#define %a(%s) do {\\@,%a%a;\\@]@,} while (0)@]"
- pp_machine_static_link_name m.mname.node_id inst
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\") ~pp_eol:(pp_print_endcut ";\\")
- (fun fmt v ->
- fprintf fmt "%s._reg.%s = (%a*) &%s" inst v.var_id
- (fun fmt v ->
- pp_c_type "" fmt (Types.array_base_type v.var_type))
- v v.var_id))
- array_mem
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\") (fun fmt (i', m') ->
- let path = sprintf "%s ## _%s" inst i' in
- fprintf fmt "%a;\\@,%s.%s = &%s" print_static_link_instance
- (path, m') inst i' path))
- m.minstances
-
- let print_static_alloc_macro fmt (m, attr, inst) =
- fprintf fmt
- "@[<v>@[<v 2>#define %a(%s, %a%s)\\@,%a(%s, %a%s);\\@,%a(%s);@]@]"
- pp_machine_static_alloc_name m.mname.node_id attr
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- (pp_c_var_read m))
- m.mstatic inst pp_machine_static_declare_name m.mname.node_id attr
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- (pp_c_var_read m))
- m.mstatic inst pp_machine_static_link_name m.mname.node_id inst
+ ()
+ Mod.pp_import_arrow
+ ()
(* TODO: ACSL we do multiple things: - provide the semantics of the node as
a predicate: function step and reset are associated to ACSL predicate -
the node is associated to a refinement contract, wrt its ACSL sem - if
the node is a regular node associated to a contract, print the contract
as function contract. - do not print anything if this is a contract node *)
- let print_machine_alloc_decl fmt m =
- Mod.print_machine_decl_prefix fmt m;
+ let pp_machine_alloc_decl fmt m =
+ Mod.pp_machine_decl_prefix fmt m;
if not (fst (get_stateless_status m)) then
if !Options.static_mem then
(* Static allocation *)
let macro = m, mk_attribute m, mk_instance m in
- fprintf fmt "%a@,%a@,%a" print_static_declare_macro macro
- print_static_link_macro macro print_static_alloc_macro macro
+ fprintf
+ fmt
+ "%a@,%a@,%a"
+ (fun x -> pp_static_declare_macro x)
+ macro
+ (fun x -> pp_static_link_macro x)
+ macro
+ (fun x -> pp_static_alloc_macro x)
+ macro
else
(* Dynamic allocation *)
- fprintf fmt "extern %a;@,extern %a" pp_alloc_prototype
+ fprintf
+ fmt
+ "extern %a;@,extern %a"
+ pp_alloc_prototype
(m.mname.node_id, m.mstatic)
- pp_dealloc_prototype m.mname.node_id
+ pp_dealloc_prototype
+ m.mname.node_id
- let print_machine_struct_top_decl_from_header fmt tdecl =
+ let pp_machine_struct_top_decl_from_header fmt tdecl =
let inode = imported_node_of_top tdecl in
if not inode.nodei_stateless then
(* Declare struct *)
fprintf fmt "%a;" (pp_machine_memtype_name ~ghost:false) inode.nodei_id
- let print_stateless_C_prototype fmt (name, inputs, outputs) =
+ let pp_stateless_C_prototype fmt (name, inputs, outputs) =
let output = match outputs with [ hd ] -> hd | _ -> assert false in
- fprintf fmt "%a %s %a"
+ fprintf
+ fmt
+ "%a %s %a"
(fun x -> pp_basic_c_type ~pp_c_basic_type_desc x)
- output.var_type name
+ output.var_type
+ name
(pp_print_parenthesized pp_c_decl_input_var)
inputs
- let print_machine_decl_top_decl_from_header fmt tdecl =
+ let pp_machine_decl_top_decl_from_header fmt tdecl =
let inode = imported_node_of_top tdecl in
(*Mod.print_machine_decl_prefix fmt m;*)
let prototype = inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs in
if inode.nodei_prototype = Some "C" then
if inode.nodei_stateless then
- fprintf fmt "extern %a;" print_stateless_C_prototype prototype
+ fprintf fmt "extern %a;" pp_stateless_C_prototype prototype
else (
(* TODO: raise proper error *)
- Format.eprintf
- "internal error: print_machine_decl_top_decl_from_header";
+ Format.eprintf "internal error: pp_machine_decl_top_decl_from_header";
assert false)
else if inode.nodei_stateless then
- fprintf fmt "extern %a;" Protos.print_stateless_prototype prototype
+ fprintf fmt "extern %a;" Protos.pp_stateless_prototype prototype
else
let static_inputs =
List.filter (fun v -> v.var_dec_const) inode.nodei_inputs
@@ -219,21 +140,26 @@ functor
let self = mk_new_name used "self" in
let mem = mk_new_name used "mem" in
let static_prototype = inode.nodei_id, static_inputs in
- fprintf fmt "extern %a;@,extern %a;@,extern %a;@,extern %a;@,extern %a;"
- (Protos.print_set_reset_prototype self mem)
+ fprintf
+ fmt
+ "extern %a;@,extern %a;@,extern %a;@,extern %a;@,extern %a;"
+ (Protos.pp_set_reset_prototype self mem)
static_prototype
- (Protos.print_clear_reset_prototype self mem)
+ (Protos.pp_clear_reset_prototype self mem)
static_prototype
- (Protos.print_init_prototype self)
+ (Protos.pp_init_prototype self)
static_prototype
- (Protos.print_clear_prototype self)
+ (Protos.pp_clear_prototype self)
static_prototype
- (Protos.print_step_prototype self mem)
+ (Protos.pp_step_prototype self mem)
prototype
- let print_const_top_decl fmt tdecl =
+ let pp_const_top_decl fmt tdecl =
let cdecl = const_of_top tdecl in
- fprintf fmt "extern %a;" (pp_c_type cdecl.const_id)
+ fprintf
+ fmt
+ "extern %a;"
+ (pp_c_type cdecl.const_id)
(if
!Options.mpfr
&& Types.(is_real_type (array_base_type cdecl.const_type))
@@ -258,24 +184,34 @@ functor
| Tydec_const c ->
fprintf fmt "%s %s" c var
| Tydec_array (d, ty) ->
- fprintf fmt "%a[%a]"
+ fprintf
+ fmt
+ "%a[%a]"
(pp_c_type_decl filename cpt var)
- ty pp_c_dimension d
+ ty
+ pp_c_dimension
+ d
| Tydec_enum tl ->
incr cpt;
- fprintf fmt "enum _enum_%s_%d %a %s"
+ fprintf
+ fmt
+ "enum _enum_%s_%d %a %s"
(protect_filename filename)
!cpt
(pp_print_braced pp_print_string)
- tl var
+ tl
+ var
| Tydec_struct fl ->
incr cpt;
- fprintf fmt "struct _struct_%s_%d %a %s"
+ fprintf
+ fmt
+ "struct _struct_%s_%d %a %s"
(protect_filename filename)
!cpt
(pp_print_braced ~pp_sep:pp_print_semicolon (fun fmt (label, tdesc) ->
pp_c_type_decl filename cpt label fmt tdesc))
- fl var
+ fl
+ var
(* let print_type_definitions fmt filename =
* let cpt_type = ref 0 in
@@ -290,12 +226,14 @@ functor
* end
* | _ -> ()) type_table *)
- let reset_type_definitions, print_type_definition_top_decl_from_header =
+ let reset_type_definitions, pp_type_definition_top_decl_from_header =
let cpt_type = ref 0 in
( (fun () -> cpt_type := 0),
fun filename fmt tdecl ->
let typ = typedef_of_top tdecl in
- fprintf fmt "typedef %a;"
+ fprintf
+ fmt
+ "typedef %a;"
(pp_c_type_decl filename cpt_type typ.tydef_id)
typ.tydef_desc )
@@ -303,10 +241,11 @@ functor
(* MAIN Header Printing functions *)
(********************************************************************************************)
- let print_alloc_header header_fmt basename machines dependencies =
+ let pp_alloc_header header_fmt basename machines dependencies =
(* Include once: start *)
let baseNAME = file_to_module_name basename in
- fprintf header_fmt
+ fprintf
+ header_fmt
"@[<v>%a@,\
#ifndef _%s_alloc@,\
#define _%s_alloc@,\
@@ -314,10 +253,14 @@ functor
/* Import header from %s */@,\
%a@,\
@,\
- %a%a%a#endif@]"
+ %a%a%a%a%a#endif@]@."
(* Print the svn version number and the supported C standard (C90 or
C99) *)
- pp_print_version () baseNAME baseNAME (* Import the header *) basename
+ pp_print_version
+ ()
+ baseNAME
+ baseNAME
+ (* Import the header *) basename
pp_import_prototype
{
local = true;
@@ -326,28 +269,52 @@ functor
is_stateful = true (* assuming it is staful *);
}
(* Print dependencies *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Import dependencies */")
- pp_import_alloc_prototype ~pp_epilogue:pp_print_cutcut)
+ pp_import_alloc_prototype
+ ~pp_epilogue:pp_print_cutcut)
dependencies
(* Print the struct definitions of all machines. *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Struct definitions */")
- ~pp_sep:pp_print_cutcut pp_machine_struct
+ ~pp_sep:pp_print_cutcut
+ pp_machine_struct
+ ~pp_epilogue:pp_print_cutcut)
+ machines
+ (* Print the ghost struct definitions of all machines. *)
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Ghost struct definitions */")
+ ~pp_sep:pp_print_cutcut
+ Mod.pp_machine_ghost_struct
~pp_epilogue:pp_print_cutcut)
machines
(* Print the prototypes of all machines *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:
(pp_print_endcut "/* Node allocation function/macro prototypes */")
- ~pp_sep:pp_print_cutcut print_machine_alloc_decl
+ ~pp_sep:pp_print_cutcut
+ pp_machine_alloc_decl
+ ~pp_epilogue:pp_print_cutcut)
+ machines
+ (* Print the spec prototypes of all machines *)
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:
+ (pp_print_endcut
+ "/* Node allocation function/macro ghost prototypes */")
+ ~pp_sep:pp_print_cutcut
+ Mod.pp_machine_alloc_decl
~pp_epilogue:pp_print_cutcut)
machines
(* Include once: end *)
(* Function called when compiling a lusi file and generating the associated
C header. *)
- let print_header_from_header header_fmt basename header =
+ let pp_header_from_header header_fmt basename header =
(* Include once: start *)
let baseNAME = file_to_module_name basename in
let types = get_typedefs header in
@@ -355,7 +322,8 @@ functor
let nodes = get_imported_nodes header in
let dependencies = get_dependencies header in
reset_type_definitions ();
- fprintf header_fmt
+ fprintf
+ header_fmt
"@[<v>%a@,\
#ifndef _%s@,\
#define _%s@,\
@@ -365,15 +333,21 @@ functor
@,\
%a%a%a%a%a%a#endif@]@."
(* Print the version number and the supported C standard (C90 or C99) *)
- pp_print_version () baseNAME baseNAME
+ pp_print_version
+ ()
+ baseNAME
+ baseNAME
(* imports standard library definitions (arrow) *)
- print_import_standard ()
+ pp_import_standard
+ ()
(* imports dependencies *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Import dependencies */")
(fun fmt dep ->
let local, name = dependency_of_top dep in
- pp_import_prototype fmt
+ pp_import_prototype
+ fmt
{
local;
name;
@@ -383,41 +357,51 @@ functor
~pp_epilogue:pp_print_cutcut)
dependencies
(* Print the type definitions from the type table *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Types definitions */")
- (print_type_definition_top_decl_from_header basename)
+ (pp_type_definition_top_decl_from_header basename)
~pp_epilogue:pp_print_cutcut)
types
(* Print the global constant declarations. *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:
(pp_print_endcut
"/* Global constants (declarations, definitions are in C file) \
*/")
- print_const_top_decl ~pp_epilogue:pp_print_cutcut)
+ pp_const_top_decl
+ ~pp_epilogue:pp_print_cutcut)
consts
(* MPFR *)
(if !Options.mpfr then fun fmt () ->
- fprintf fmt
+ fprintf
+ fmt
"/* Global initialization declaration */@,\
extern %a;@,\
@,\
/* Global clear declaration */@,\
extern %a;@,\
@,"
- pp_global_init_prototype baseNAME pp_global_clear_prototype baseNAME
+ pp_global_init_prototype
+ baseNAME
+ pp_global_clear_prototype
+ baseNAME
else pp_print_nothing)
()
(* Print the struct declarations of all machines. *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Struct declarations */")
- print_machine_struct_top_decl_from_header
+ pp_machine_struct_top_decl_from_header
~pp_epilogue:pp_print_cutcut)
nodes
(* Print the prototypes of all machines *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Nodes declarations */")
- ~pp_sep:pp_print_cutcut print_machine_decl_top_decl_from_header
+ ~pp_sep:pp_print_cutcut
+ pp_machine_decl_top_decl_from_header
~pp_epilogue:pp_print_cutcut)
nodes
end
diff --git a/src/backends/C/c_backend_header.mli b/src/backends/C/c_backend_header.mli
index e23ea75f..b5bd0a23 100644
--- a/src/backends/C/c_backend_header.mli
+++ b/src/backends/C/c_backend_header.mli
@@ -6,16 +6,20 @@ open C_backend_common
module type MODIFIERS_HDR = sig
module GhostProto : MODIFIERS_GHOST_PROTO
- val print_machine_decl_prefix : formatter -> machine_t -> unit
+ val pp_machine_decl_prefix : formatter -> machine_t -> unit
+
+ val pp_machine_ghost_struct : formatter -> machine_t -> unit
val pp_import_arrow : formatter -> unit -> unit
+
+ val pp_machine_alloc_decl : formatter -> machine_t -> unit
end
module EmptyMod : MODIFIERS_HDR
module Main (Mod : MODIFIERS_HDR) : sig
- val print_header_from_header : formatter -> string -> top_decl list -> unit
+ val pp_header_from_header : formatter -> string -> top_decl list -> unit
- val print_alloc_header :
+ val pp_alloc_header :
formatter -> string -> machine_t list -> dep_t list -> unit
end
diff --git a/src/backends/C/c_backend_main.ml b/src/backends/C/c_backend_main.ml
index 8c033597..28fae342 100644
--- a/src/backends/C/c_backend_main.ml
+++ b/src/backends/C/c_backend_main.ml
@@ -9,326 +9,478 @@
(* *)
(********************************************************************)
+open Utils
open Lustre_types
open Machine_code_types
open Machine_code_common
-open Utils.Format
+open Format
open C_backend_common
module Mpfr = Lustrec_mpfr
-module type MODIFIERS_MAINSRC = sig end
+module type MODIFIERS_MAINSRC = sig
+ val pp_declare_ghost_state : formatter -> ident -> unit
-module EmptyMod = struct end
+ val pp_ghost_state_parameter : formatter -> unit -> unit
-module Main =
-functor
- (Mod : MODIFIERS_MAINSRC)
- ->
- struct
- (********************************************************************************************)
- (* Main related functions *)
- (********************************************************************************************)
+ val pp_main_spec : formatter -> machine_t -> unit
+end
- let pp_c_main_var_input fmt id = fprintf fmt "%s" id.var_id
+module EmptyMod = struct
+ let pp_declare_ghost_state _ _ = ()
- 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_ghost_state_parameter _ _ = ()
- let print_put_output fmt id o' o =
- let suff = string_of_int (id + 1) in
- pp_put_var fmt suff o'.var_id o.var_type o.var_id
+ let pp_main_spec _ _ = ()
+end
- 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
+module Main (Mod : MODIFIERS_MAINSRC) = struct
+ (********************************************************************************************)
+ (* Main related functions *)
+ (********************************************************************************************)
- 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 ~ghost:false)
- mname pp_machine_alloc_name mname)
- () pp_machine_set_reset_name mname main_mem
+ let pp_c_main_var_input fmt id = fprintf fmt "%s" id.var_id
- 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 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_global_clear fmt basename =
- let mNAME = file_to_module_name basename in
- fprintf fmt "/* Clear global constants */@,%a();" pp_global_clear_name
- mNAME
+ let pp_put_output fmt id o' o =
+ let suff = string_of_int (id + 1) in
+ pp_put_var fmt suff o'.var_id o.var_type o.var_id
- 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 pp_main_inout_declaration fmt m =
+ let opt = !Options.c_main_options in
+ fprintf
+ fmt
+ "/* Declaration of inputs/outputs variables */@,%a%a%a"
+ (pp_print_list_i ~pp_open_box:pp_open_vbox0 (fun fmt idx v ->
+ fprintf
+ fmt
+ "%a; %a"
+ (pp_c_type v.var_id)
+ v.var_type
+ (if opt then fun fmt () -> pp_file_decl fmt "in" idx
+ else pp_print_nothing)
+ ()))
+ m.mstep.step_inputs
+ (pp_print_list_i
+ ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:pp_print_cut
+ (fun fmt idx v ->
+ fprintf
+ fmt
+ "%a; %a"
+ (pp_c_type v.var_id)
+ v.var_type
+ (if opt then fun fmt () -> pp_file_decl fmt "out" idx
+ else pp_print_nothing)
+ ()))
+ m.mstep.step_outputs
+ (if opt then fun fmt () ->
+ fprintf
+ fmt
+ "@,@[<v 2>if (traces) {@,%a%a@]@,}"
+ (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
+ else pp_print_nothing)
+ ()
- 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_file ("in" ^ string_of_int (id + 1)) in
- let unclocked_t = Types.unclock_type v.var_type in
- fprintf fmt "@[<v>%a@]"
+ let pp_main_memory_allocation mname main_mem fmt m =
+ if not (fst (get_stateless_status m)) then
+ fprintf
+ fmt
+ "@[<v>/* Main memory allocation */@,\
+ %a@,\
+ %a@,\
+ /* Initialize the main memory */@,\
+ %a(%s)%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 (
- Global.main_node := !Options.main_node;
- eprintf "Code generation error: %a%a@." Error.pp
- Error.Main_wrong_kind Location.pp v'.var_loc;
- raise (Error.Error (v'.var_loc, Error.Main_wrong_kind))))
+ if !Options.static_mem && !Options.main_node <> "" then
+ fprintf
+ fmt
+ "%a(static,main_mem);"
+ (fun x -> pp_machine_static_alloc_name x)
+ mname
+ else
+ fprintf
+ fmt
+ "%a *main_mem = %a();"
+ (pp_machine_memtype_name ~ghost:false)
+ mname
+ pp_machine_alloc_name
+ mname)
()
-
- 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 "%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 "%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)
+ Mod.pp_declare_ghost_state
+ mname
+ pp_machine_set_reset_name
+ mname
+ main_mem
+ Mod.pp_ghost_state_parameter
()
- (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 pp_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_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 pp_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_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
+ let pp_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
- 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 () ->
+ let pp_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 pp_get_input fmt id v' v =
+ let opt = !Options.c_main_options in
+ let pp_file fmt =
+ if opt then fprintf fmt "@,%a" (pp_file ("in" ^ string_of_int (id + 1)))
+ else pp_print_nothing fmt
+ 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 "@[<v>%a@,%a@]@,"
- (print_main_clear mname main_mem)
- m print_global_clear basename)
- ()
+ 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 (
+ Global.main_node := !Options.main_node;
+ eprintf
+ "Code generation error: %a%a@."
+ Error.pp
+ Error.Main_wrong_kind
+ Location.pp
+ v'.var_loc;
+ raise (Error.Error (v'.var_loc, Error.Main_wrong_kind))))
+ ()
- 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 pp_main_call mname self fmt m inputs outputs =
+ let pp_inputs =
+ pp_print_list
+ ~pp_sep:pp_print_comma
+ ~pp_eol:pp_print_comma
+ (pp_c_val m self pp_c_main_var_input)
+ in
+ let pp_outputs ?pp_eol fmt x =
+ pp_print_list ~pp_sep:pp_print_comma ?pp_eol pp_c_main_var_output fmt x
+ in
+ if fst (get_stateless_status m) then
+ fprintf
+ fmt
+ "%a(%a%a);"
+ pp_machine_step_name
+ mname
+ pp_inputs
+ inputs
+ (pp_outputs ~pp_eol:pp_print_nothing)
+ outputs
+ else
+ fprintf
+ fmt
+ "%a(%a%a%s)%a;"
+ pp_machine_step_name
+ mname
+ pp_inputs
+ inputs
+ (pp_outputs ~pp_eol:pp_print_comma)
+ outputs
+ self
+ Mod.pp_ghost_state_parameter
()
- 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\n\
- \ @]@." print_main_header () pp_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
+ let pp_main_loop mname main_mem fmt m =
+ let opt = !Options.c_main_options in
+ 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);@,\
+ %a%a%a%a@]@,\
+ }"
+ (if opt then fun fmt () ->
+ fprintf
+ fmt
+ "@[<v 2>if (traces) {@,%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
+ else pp_print_nothing)
+ ()
+ (pp_print_list_i2
+ ~pp_open_box:pp_open_vbox0
+ ~pp_epilogue:pp_print_cut
+ pp_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
+ pp_put_output)
+ (m.mname.node_outputs, m.mstep.step_outputs)
+
+ let pp_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 pp_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 pp_main_code fmt (basename, m) =
+ let opt = !Options.c_main_options in
+ 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%a@[<v 2>int main (%a) {@,\
+ %a%a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %areturn 1;@]@,\
+ }@]@."
+ (if opt then pp_usage else pp_print_nothing)
+ ()
+ Mod.pp_main_spec
+ m
+ (if opt then pp_print_string else pp_print_nothing)
+ "int argc, char *argv[]"
+ (if opt then pp_options else pp_print_nothing)
+ (basename ^ "_" ^ mname)
+ pp_main_inout_declaration
+ m
+ (Plugins.c_backend_main_loop_body_prefix basename mname)
+ ()
+ (pp_main_memory_allocation mname main_mem)
+ m
+ (fun fmt () ->
+ if !Options.mpfr then
+ fprintf
+ fmt
+ "@[<v>%a@,%a@]@,"
+ pp_global_initialize
+ basename
+ (pp_main_initialize mname main_mem)
+ m)
+ ()
+ (pp_main_loop mname main_mem)
+ m
+ Plugins.c_backend_main_loop_body_suffix
+ ()
+ (fun fmt () ->
+ if !Options.mpfr then
+ fprintf
+ fmt
+ "@[<v>%a@,%a@]@,"
+ (pp_main_clear mname main_mem)
+ m
+ pp_global_clear
+ basename)
+ ()
+
+ let pp_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 pp_main_c main_fmt main_machine basename _prog _machines _dependencies =
+ fprintf
+ main_fmt
+ "@[<v>%a@,\
+ #include <stdlib.h>@,\
+ #include <assert.h>@,\
+ %a@,\
+ @,\
+ %a@,\
+ %a\n\
+ \ @]@."
+ pp_main_header
+ ()
+ pp_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
+ ()
+ pp_main_code
+ (basename, main_machine)
+end
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
diff --git a/src/backends/C/c_backend_main.mli b/src/backends/C/c_backend_main.mli
index 7369ba5f..cac68250 100644
--- a/src/backends/C/c_backend_main.mli
+++ b/src/backends/C/c_backend_main.mli
@@ -1,13 +1,20 @@
+open Utils
open Format
open Lustre_types
open Machine_code_types
-module type MODIFIERS_MAINSRC = sig end
+module type MODIFIERS_MAINSRC = sig
+ val pp_declare_ghost_state : formatter -> ident -> unit
+
+ val pp_ghost_state_parameter : formatter -> unit -> unit
+
+ val pp_main_spec : formatter -> machine_t -> unit
+end
module EmptyMod : MODIFIERS_MAINSRC
module Main (Mod : MODIFIERS_MAINSRC) : sig
- val print_main_c :
+ val pp_main_c :
formatter ->
machine_t ->
string ->
diff --git a/src/backends/C/c_backend_makefile.ml b/src/backends/C/c_backend_makefile.ml
index 92c57893..6db2a679 100644
--- a/src/backends/C/c_backend_makefile.ml
+++ b/src/backends/C/c_backend_makefile.ml
@@ -41,7 +41,8 @@ let header_libs header =
Utils.list_union nd.nodei_in_lib accu
| _ ->
accu)
- [] header
+ []
+ header
let compiled_dependencies deps =
List.filter (fun dep -> header_has_code dep.content) deps
@@ -49,7 +50,8 @@ let compiled_dependencies deps =
let lib_dependencies deps =
List.fold_left
(fun accu dep -> Utils.list_union (header_libs dep.content) accu)
- [] deps
+ []
+ deps
let fprintf_dependencies fmt (deps : dep_t list) =
(* eprintf "Deps: %a@." pp_deps dep; *)
@@ -91,7 +93,7 @@ functor
shorter version if it is long (md5?) - a provided name given when calling
the makefile so the user can control the expected name of the binary *)
- let print_makefile basename nodename (dependencies : dep_t list) fmt =
+ let pp_makefile basename nodename (dependencies : dep_t list) fmt =
let binname =
let s = basename ^ "_" ^ nodename in
if
@@ -107,22 +109,32 @@ functor
fprintf fmt "BINNAME?=%s@." binname;
fprintf fmt "GCC=gcc -O0@.";
fprintf fmt "LUSTREC=%s@." Sys.executable_name;
- fprintf fmt "LUSTREC_BASE=%s@."
+ fprintf
+ fmt
+ "LUSTREC_BASE=%s@."
(Filename.dirname (Filename.dirname Sys.executable_name));
fprintf fmt "INC=%s@." Version.include_path
(*"${LUSTREC_BASE}/include/lustrec"*);
fprintf fmt "@.";
(* Main binary *)
- fprintf fmt "%s_%s: %s.c %s_main.c@." basename "run" (*nodename*) basename
+ fprintf
+ fmt
+ "%s_%s: %s.c %s_main.c@."
+ basename
+ "run"
+ (*nodename*) basename
basename;
fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;
fprintf fmt "\t${GCC} -I${INC} -I. -c %s_main.c@." basename;
fprintf_dependencies fmt dependencies;
- fprintf fmt "\t${GCC} -o ${BINNAME} io_frontend.o %a %s.o %s_main.o %a@."
+ fprintf
+ fmt
+ "\t${GCC} -o ${BINNAME} io_frontend.o %a %s.o %s_main.o %a@."
(pp_print_list (fun fmt dep -> fprintf fmt "%s.o" dep.name))
(compiled_dependencies dependencies)
- basename (* library .o *) basename
+ basename
+ (* library .o *) basename
(* main function . o *)
(pp_print_list (fun fmt lib -> fprintf fmt "-l%s" lib))
(lib_dependencies dependencies);
diff --git a/src/backends/C/c_backend_makefile.mli b/src/backends/C/c_backend_makefile.mli
index 9495abe4..b0014136 100644
--- a/src/backends/C/c_backend_makefile.mli
+++ b/src/backends/C/c_backend_makefile.mli
@@ -9,7 +9,7 @@ end
module EmptyMod : MODIFIERS_MKF
module Main (Mod : MODIFIERS_MKF) : sig
- val print_makefile : string -> string -> dep_t list -> formatter -> unit
+ val pp_makefile : string -> string -> dep_t list -> formatter -> unit
end
val fprintf_dependencies : formatter -> dep_t list -> unit
diff --git a/src/backends/C/c_backend_mauve.ml b/src/backends/C/c_backend_mauve.ml
index 0a2bea2e..6762862b 100644
--- a/src/backends/C/c_backend_mauve.ml
+++ b/src/backends/C/c_backend_mauve.ml
@@ -25,7 +25,8 @@ let fsm_name node = node ^ "FSM"
let print_mauve_header fmt basename =
fprintf fmt "#include \"mauve/runtime.hpp\"@.";
- pp_import_alloc_prototype fmt
+ pp_import_alloc_prototype
+ fmt
{ local = true; name = basename; content = []; is_stateful = true }
(* assuming it is stateful*);
pp_print_newline fmt ();
@@ -77,8 +78,13 @@ let print_mauve_shell fmt mauve_machine =
(fun v ->
let v_name = v.var_id in
let v_type = pp_c_basic_type_desc v.var_type in
- fprintf fmt "\tReadPort<%s> & port_%s = mk_readPort<%s>(\"%s\", " v_type
- v_name v_type v_name;
+ fprintf
+ fmt
+ "\tReadPort<%s> & port_%s = mk_readPort<%s>(\"%s\", "
+ v_type
+ v_name
+ v_type
+ v_name;
print_mauve_default fmt mauve_machine v;
fprintf fmt ");@.")
mauve_machine.mstep.step_inputs;
@@ -88,8 +94,13 @@ let print_mauve_shell fmt mauve_machine =
(fun v ->
let v_name = v.var_id in
let v_type = pp_c_basic_type_desc v.var_type in
- fprintf fmt "\tWritePort<%s> & port_%s = mk_writePort<%s>(\"%s\");@."
- v_type v_name v_type v_name)
+ fprintf
+ fmt
+ "\tWritePort<%s> & port_%s = mk_writePort<%s>(\"%s\");@."
+ v_type
+ v_name
+ v_type
+ v_name)
mauve_machine.mstep.step_outputs;
fprintf fmt "};@.";
@@ -122,7 +133,10 @@ let print_mauve_core fmt mauve_machine =
fprintf fmt " * CORE@.";
fprintf fmt " */@.";
- fprintf fmt "struct %s: public Core<%s> {@." (core_name node_name)
+ fprintf
+ fmt
+ "struct %s: public Core<%s> {@."
+ (core_name node_name)
(shell_name node_name);
(* Attribute *)
@@ -217,15 +231,23 @@ let print_mauve_fsm fmt mauve_machine =
fprintf fmt " * FSM@.";
fprintf fmt " */@.";
- fprintf fmt "struct %s: public FiniteStateMachine<%s, %s> {@."
- (fsm_name node_name) (shell_name node_name) (core_name node_name);
+ fprintf
+ fmt
+ "struct %s: public FiniteStateMachine<%s, %s> {@."
+ (fsm_name node_name)
+ (shell_name node_name)
+ (core_name node_name);
(* Attribute *)
- fprintf fmt
+ fprintf
+ fmt
"\tExecState<%s> & update = mk_execution (\"Update\" , \
&%s::update);@."
- (core_name node_name) (core_name node_name);
- fprintf fmt "\tSynchroState<%s> & synchro = mk_synchronization(\"Synchro\", "
+ (core_name node_name)
+ (core_name node_name);
+ fprintf
+ fmt
+ "\tSynchroState<%s> & synchro = mk_synchronization(\"Synchro\", "
(core_name node_name);
print_mauve_period fmt mauve_machine;
fprintf fmt ");@.";
diff --git a/src/backends/C/c_backend_spec.ml b/src/backends/C/c_backend_spec.ml
index 525ab3e0..469b7958 100644
--- a/src/backends/C/c_backend_spec.ml
+++ b/src/backends/C/c_backend_spec.ml
@@ -43,16 +43,21 @@ let pp_acsl_line pp fmt = fprintf fmt "//%@ @[<h>%a@]" pp
let pp_acsl_line' pp fmt = fprintf fmt "/*%@ @[<h>%a@] */" pp
-let pp_requires pp_req fmt = fprintf fmt "requires %a;" pp_req
+let pp_acsl_line'_cut pp fmt = fprintf fmt "%a@," (pp_acsl_line' pp)
-let pp_ensures pp_ens fmt = fprintf fmt "ensures %a;" pp_ens
+let pp_requires pp fmt = fprintf fmt "requires %a;" pp
-let pp_assumes pp_asm fmt = fprintf fmt "assumes %a;" pp_asm
+let pp_ensures pp fmt = fprintf fmt "ensures %a;" pp
+
+let pp_assumes pp fmt = fprintf fmt "assumes %a;" pp
+
+let pp_terminates pp fmt = fprintf fmt "terminates %a;" pp
let pp_assigns pp =
pp_comma_list
~pp_prologue:(fun fmt () -> pp_print_string fmt "assigns ")
- ~pp_epilogue:pp_print_semicolon' pp
+ ~pp_epilogue:pp_print_semicolon'
+ pp
let pp_ghost pp_gho fmt = fprintf fmt "ghost %a" pp_gho
@@ -63,6 +68,8 @@ let pp_mem_valid pp_var fmt (name, var) =
let pp_mem_valid' = pp_mem_valid pp_print_string
+let pp_ref pp fmt = fprintf fmt "&%a" pp
+
let pp_indirect pp_ptr pp_field fmt (ptr, field) =
fprintf fmt "%a->%a" pp_ptr ptr pp_field field
@@ -125,7 +132,8 @@ let pp_memory ?(indirect = true) ptr fmt (path, mem) =
((if indirect then pp_indirect else pp_access)
(pp_instance ~indirect ptr)
pp_print_string)
- pp_var_decl fmt
+ pp_var_decl
+ fmt
((path, "_reg"), mem)
let prefixes l =
@@ -140,7 +148,11 @@ let prefixes l =
let powerset_instances paths = List.map prefixes paths |> List.flatten
let pp_separated self mem fmt (paths, ptrs) =
- fprintf fmt "\\separated(@[<v>%s, %s@;%a@;%a@])" self mem
+ fprintf
+ fmt
+ "\\separated(@[<v>%s, %s@;%a@;%a@])"
+ self
+ mem
(pp_comma_list ~pp_prologue:pp_print_comma' (pp_instance self))
paths
(pp_comma_list ~pp_prologue:pp_print_comma' pp_var_decl)
@@ -149,7 +161,8 @@ let pp_separated self mem fmt (paths, ptrs) =
let pp_separated' =
pp_comma_list
~pp_prologue:(fun fmt () -> pp_print_string fmt "\\separated(")
- ~pp_epilogue:pp_print_cpar pp_var_decl
+ ~pp_epilogue:pp_print_cpar
+ pp_var_decl
let pp_forall pp_l pp_r fmt (l, r) =
fprintf fmt "@[<v 2>\\forall %a;@,%a@]" pp_l l pp_r r
@@ -165,14 +178,18 @@ let pp_implies pp_l pp_r fmt (l, r) =
let pp_and pp_l pp_r fmt (l, r) = fprintf fmt "@[<v>%a @ && %a@]" pp_l l pp_r r
let pp_and_l pp_v fmt =
- pp_print_list ~pp_open_box:pp_open_vbox0
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_sep:(fun fmt () -> fprintf fmt "@,&& ")
- pp_v fmt
+ pp_v
+ fmt
let pp_or_l pp_v fmt =
- pp_print_list ~pp_open_box:pp_open_vbox0
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_sep:(fun fmt () -> fprintf fmt "@,|| ")
- pp_v fmt
+ pp_v
+ fmt
let pp_not pp fmt = fprintf fmt "!%a" pp
@@ -212,11 +229,24 @@ let pp_assign_spec m self_l pp_var_l indirect_l self_r pp_var_r indirect_r fmt
match vars with
| [] ->
pp_basic_assign_spec
- (pp_value_suffix ~indirect:indirect_l m self_l var_type loop_vars
+ (pp_value_suffix
+ ~indirect:indirect_l
+ m
+ self_l
+ var_type
+ loop_vars
pp_var_l)
- (pp_value_suffix ~indirect:indirect_r m self_r var_type loop_vars
+ (pp_value_suffix
+ ~indirect:indirect_r
+ m
+ self_r
+ var_type
+ loop_vars
pp_var_r)
- fmt typ var_name value
+ fmt
+ typ
+ var_name
+ value
| (_d, LVar _i) :: _q ->
assert false
(* let typ' = Types.array_element_type typ in
@@ -236,18 +266,32 @@ let pp_assign_spec m self_l pp_var_l indirect_l self_r pp_var_r indirect_r fmt
aux var_type fmt reordered_loop_vars
let pp_memory_pack_aux ?i pp_mem pp_self fmt (name, mem, self) =
- fprintf fmt "%s_pack%a(@[<hov>%a,@ %a@])" name
+ fprintf
+ fmt
+ "%s_pack%a(@[<hov>%a,@ %a@])"
+ name
(pp_print_option pp_print_int)
- i pp_mem mem pp_self self
+ i
+ pp_mem
+ mem
+ pp_self
+ self
let pp_memory_pack pp_mem pp_self fmt (mp, mem, self) =
- pp_memory_pack_aux ?i:mp.mpindex pp_mem pp_self fmt
+ pp_memory_pack_aux
+ ?i:mp.mpindex
+ pp_mem
+ pp_self
+ fmt
(mp.mpname.node_id, mem, self)
let pp_transition_aux ?i m pp_mem_in pp_mem_out pp_var fmt
(name, vars, mem_in, mem_out) =
let stateless = fst (get_stateless_status m) in
- fprintf fmt "%s_transition%a(@[<hov>%t%a%t@])" name
+ fprintf
+ fmt
+ "%s_transition%a(@[<hov>%t%a%t@])"
+ name
(pp_print_option pp_print_int)
i
(fun fmt -> if not stateless then pp_mem_in fmt mem_in)
@@ -258,7 +302,13 @@ let pp_transition_aux ?i m pp_mem_in pp_mem_out pp_var fmt
(fun fmt -> if not stateless then fprintf fmt ",@ %a" pp_mem_out mem_out)
let pp_transition m pp_mem_in pp_mem_out pp_var fmt (t, mem_in, mem_out) =
- pp_transition_aux ?i:t.tindex m pp_mem_in pp_mem_out pp_var fmt
+ pp_transition_aux
+ ?i:t.tindex
+ m
+ pp_mem_in
+ pp_mem_out
+ pp_var
+ fmt
(t.tname.node_id, t.tvars, mem_in, mem_out)
let pp_transition_aux' ?i m =
@@ -266,8 +316,14 @@ let pp_transition_aux' ?i m =
(if is_output m v then pp_ptr_decl else pp_var_decl) fmt v)
let pp_reset_cleared pp_mem_in pp_mem_out fmt (name, mem_in, mem_out) =
- fprintf fmt "%s_reset_cleared(@[<hov>%a,@ %a@])" name pp_mem_in mem_in
- pp_mem_out mem_out
+ fprintf
+ fmt
+ "%s_reset_cleared(@[<hov>%a,@ %a@])"
+ name
+ pp_mem_in
+ mem_in
+ pp_mem_out
+ mem_out
let pp_reset_cleared' = pp_reset_cleared pp_print_string pp_print_string
@@ -276,11 +332,17 @@ let pp_functional_update mems insts fmt mem =
| [] ->
pp_print_string fmt mem
| (x, is_mem) :: fields ->
- fprintf fmt "{ @[<hov>%a@ \\with .%s%s = %s@] }" aux fields
+ fprintf
+ fmt
+ "{ @[<hov>%a@ \\with .%s%s = %s@] }"
+ aux
+ fields
(if is_mem then "_reg." else "")
- x x
+ x
+ x
in
- aux fmt
+ aux
+ fmt
(List.map (fun (x, _) -> x, false) (Utils.IMap.bindings insts)
@ List.map (fun x -> x, true) (Utils.ISet.elements mems))
@@ -345,7 +407,13 @@ module PrintSpec = struct
else pp_access' fmt (mem_in, inst)),
fun fmt mem_out -> pp_access' fmt (mem_out, inst) )
in
- pp_transition_aux ?i m pp_mem_in pp_mem_out (pp_expr test_output) fmt
+ pp_transition_aux
+ ?i
+ m
+ pp_mem_in
+ pp_mem_out
+ (pp_expr test_output)
+ fmt
(f, vars, mem_in', mem_out')
| Reset (_f, inst, r) ->
pp_ite
@@ -424,11 +492,15 @@ module PrintSpec = struct
| False ->
pp_false fmt ()
| Equal (a, b) ->
- pp_assign_spec m mem_out
+ pp_assign_spec
+ m
+ mem_out
(pp_c_var_read ~test_output:false m)
- indirect_l mem_in
+ indirect_l
+ mem_in
(pp_c_var_read ~test_output:false m)
- indirect_r fmt
+ indirect_r
+ fmt
(type_of_l_value a, val_of_expr a, val_of_expr b)
| And fs ->
pp_and_l pp_spec' fmt fs
@@ -446,11 +518,15 @@ module PrintSpec = struct
pp_predicate mode m mem_in mem_in' mem_out mem_out' fmt p
| StateVarPack ResetFlag ->
let r = vdecl_to_val reset_flag in
- pp_assign_spec m mem_out
+ pp_assign_spec
+ m
+ mem_out
(pp_c_var_read ~test_output:false m)
- indirect_l mem_in
+ indirect_l
+ mem_in
(pp_c_var_read ~test_output:false m)
- indirect_r fmt
+ indirect_r
+ fmt
(Type_predef.type_bool, r, r)
| StateVarPack (StateVar v) ->
let v' = vdecl_to_val v in
@@ -458,9 +534,12 @@ module PrintSpec = struct
pp_paren
(pp_implies
(pp_not (pp_initialization pp_access'))
- (pp_assign_spec m mem_out
+ (pp_assign_spec
+ m
+ mem_out
(pp_c_var_read ~test_output:false m)
- indirect_l mem_in
+ indirect_l
+ mem_in
(pp_c_var_read ~test_output:false m)
indirect_r))
fmt
@@ -508,13 +587,19 @@ let pp_memory_pack_def m fmt mp =
fmt
((mp, (name, mem), (name, self)), mp.mpformula)
-let print_machine_ghost_struct fmt m =
+let pp_machine_ghost_struct fmt m =
pp_acsl (pp_ghost (pp_machine_struct ~ghost:true)) fmt m
let pp_memory_pack_defs fmt m =
if not (fst (get_stateless_status m)) then
- fprintf fmt "%a@,%a" print_machine_ghost_struct m
- (pp_print_list ~pp_epilogue:pp_print_cut ~pp_open_box:pp_open_vbox0
+ fprintf
+ fmt
+ "%a@,%a"
+ pp_machine_ghost_struct
+ m
+ (pp_print_list
+ ~pp_epilogue:pp_print_cut
+ ~pp_open_box:pp_open_vbox0
(pp_memory_pack_def m))
m.mspec.mmemory_packs
@@ -524,7 +609,8 @@ let pp_transition_def m fmt t =
let mem_out = mk_mem_out m in
pp_acsl
(pp_predicate
- (pp_transition m
+ (pp_transition
+ m
(pp_machine_decl' ~ghost:true)
(pp_machine_decl' ~ghost:true)
(pp_local m))
@@ -533,11 +619,18 @@ let pp_transition_def m fmt t =
((t, (name, mem_in), (name, mem_out)), t.tformula)
let pp_transition_defs fmt m =
- pp_print_list ~pp_epilogue:pp_print_cut ~pp_open_box:pp_open_vbox0
- (pp_transition_def m) fmt m.mspec.mtransitions
+ pp_print_list
+ ~pp_epilogue:pp_print_cut
+ ~pp_open_box:pp_open_vbox0
+ (pp_transition_def m)
+ fmt
+ m.mspec.mtransitions
let pp_transition_footprint fmt t =
- fprintf fmt "%s_transition%a_footprint" t.tname.node_id
+ fprintf
+ fmt
+ "%s_transition%a_footprint"
+ t.tname.node_id
(pp_print_option pp_print_int)
t.tindex
@@ -564,12 +657,17 @@ let pp_transition_footprint_lemma m fmt t =
let insts_empty = IMap.is_empty insts in
let instances = List.map (fun (i, f) -> f, i) (IMap.bindings insts) in
let tr ?mems ?insts () =
- Spec_common.mk_transition ?mems ?insts ?i:t.tindex name
+ Spec_common.mk_transition
+ ?mems
+ ?insts
+ ?i:t.tindex
+ name
(vdecls_to_vals t.tvars)
in
if not (mems_empty && insts_empty) then
pp_acsl
- (pp_lemma pp_transition_footprint
+ (pp_lemma
+ pp_transition_footprint
(pp_forall
(pp_machine_decl ~ghost:true (pp_comma_list pp_print_string))
((if insts_empty then fun pp fmt (_, x) -> pp fmt x
@@ -585,7 +683,9 @@ let pp_transition_footprint_lemma m fmt t =
)
let pp_transition_footprint_lemmas fmt m =
- pp_print_list ~pp_epilogue:pp_print_cut ~pp_open_box:pp_open_vbox0
+ pp_print_list
+ ~pp_epilogue:pp_print_cut
+ ~pp_open_box:pp_open_vbox0
(pp_transition_footprint_lemma m)
fmt
(List.filter
@@ -605,7 +705,8 @@ let pp_initialization_def fmt m =
else
pp_equal
(pp_reset_flag ~indirect:false pp_access')
- pp_print_int fmt
+ pp_print_int
+ fmt
((mem_in, i), 1))))
fmt
((name, (name, mem_in)), m.minstances)
@@ -644,14 +745,17 @@ let pp_reset_flag_chain ?(indirect = true) ptr fmt mems =
~pp_epilogue:(fun fmt () -> pp_reset_flag' ~indirect fmt "")
~pp_sep:(fun fmt () -> pp_print_string fmt (if indirect then "->" else "."))
(fun fmt (i, _) -> pp_print_string fmt i)
- fmt mems
+ fmt
+ mems
let pp_arrow_reset_ghost mem fmt inst =
fprintf fmt "%s_reset_ghost(%a)" Arrow.arrow_id pp_indirect' (mem, inst)
module GhostProto : MODIFIERS_GHOST_PROTO = struct
let pp_ghost_parameters ?(cut = true) fmt vs =
- fprintf fmt "%a%a"
+ fprintf
+ fmt
+ "%a%a"
(if cut then pp_print_cut else pp_print_nothing)
()
(pp_acsl_line'
@@ -662,23 +766,55 @@ end
module HdrMod = struct
module GhostProto = GhostProto
- let print_machine_decl_prefix _ _ = ()
+ let pp_machine_decl_prefix _ _ = ()
let pp_import_arrow fmt () =
- fprintf fmt "#include \"%s/arrow_spec.h%s\""
+ fprintf
+ fmt
+ "#include \"%s/arrow_spec.h%s\""
(Arrow.arrow_top_decl ()).top_decl_owner
(if !Options.cpp then "pp" else "")
+
+ let pp_machine_ghost_struct = pp_machine_ghost_struct
+
+ let pp_machine_alloc_decl fmt m =
+ pp_machine_decl_prefix fmt m;
+ if not (fst (get_stateless_status m)) then
+ if !Options.static_mem then
+ (* Static allocation *)
+ let macro = m, mk_attribute m, mk_instance m in
+ fprintf
+ fmt
+ "%a@,%a@,%a"
+ (pp_static_declare_macro ~ghost:true)
+ macro
+ (pp_static_link_macro ~ghost:true)
+ macro
+ (pp_static_alloc_macro ~ghost:true)
+ macro
+ else
+ (* Dynamic allocation *)
+ (* TODO: handle dynamic alloc *)
+ assert false
+ (* fprintf fmt "extern %a;@,extern %a" pp_alloc_prototype
+ * (m.mname.node_id, m.mstatic)
+ * pp_dealloc_prototype m.mname.node_id *)
end
module SrcMod = struct
module GhostProto = GhostProto
- let pp_predicates (* dependencies *) fmt machines =
+ let pp_predicates fmt machines =
let pp_preds comment pp =
- pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut comment) pp ~pp_epilogue:pp_print_cutcut
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut comment)
+ pp
+ ~pp_epilogue:pp_print_cutcut
in
- fprintf fmt "%a%a%a%a%a%a"
+ fprintf
+ fmt
+ "%a%a%a%a%a%a"
(pp_preds "/* ACSL `valid` predicates */" pp_mem_valid_def)
machines
(pp_preds "/* ACSL `memory pack` simulations */" pp_memory_pack_defs)
@@ -689,7 +825,8 @@ module SrcMod = struct
machines
(pp_preds "/* ACSL transition annotations */" pp_transition_defs)
machines
- (pp_preds "/* ACSL transition memory footprints lemmas */"
+ (pp_preds
+ "/* ACSL transition memory footprints lemmas */"
pp_transition_footprint_lemmas)
machines
@@ -701,7 +838,8 @@ module SrcMod = struct
let mk_insts = List.map (fun x -> [ x ]) in
pp_acsl_cut
(fun fmt () ->
- fprintf fmt
+ fprintf
+ fmt
"%a@,\
%a@,\
%a@,\
@@ -729,7 +867,8 @@ module SrcMod = struct
(pp_ensures
(pp_memory_pack_aux
~i:(List.length m.mspec.mmemory_packs - 2)
- pp_ptr pp_print_string))
+ pp_ptr
+ pp_print_string))
(name, mem, self)
(pp_assigns pp_reset_flag')
[ self ]
@@ -751,20 +890,24 @@ module SrcMod = struct
(mem, 0)
(pp_ensures (pp_equal pp_ptr (pp_old pp_ptr)))
(mem, mem))
- fmt ()
+ fmt
+ ()
let pp_set_reset_spec fmt self mem m =
let name = m.mname.node_id in
pp_acsl_cut
(fun fmt () ->
- fprintf fmt "%a@,%a@,%a"
+ fprintf
+ fmt
+ "%a@,%a@,%a"
(pp_ensures (pp_memory_pack_aux pp_ptr pp_print_string))
(name, mem, self)
(pp_ensures (pp_equal pp_reset_flag' pp_print_int))
(mem, 1)
(pp_assigns pp_reset_flag')
[ self; mem ])
- fmt ()
+ fmt
+ ()
let pp_step_spec fmt machines self mem m =
let name = m.mname.node_id in
@@ -781,15 +924,20 @@ module SrcMod = struct
pp_acsl_cut
(fun fmt () ->
if fst (get_stateless_status m) then
- fprintf fmt "%a@,%a@,%a@,%a"
+ fprintf
+ fmt
+ "%a@,%a@,%a@,%a"
(pp_requires (pp_valid pp_var_decl))
outputs
(pp_requires pp_separated')
- outputs (pp_assigns pp_ptr_decl) outputs
+ outputs
+ (pp_assigns pp_ptr_decl)
+ outputs
(pp_ensures (pp_transition_aux' m))
(name, inputs @ outputs, "", "")
else
- fprintf fmt
+ fprintf
+ fmt
"%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a"
(pp_requires (pp_valid pp_var_decl))
outputs
@@ -805,7 +953,8 @@ module SrcMod = struct
(pp_transition_aux m (pp_old pp_ptr) pp_ptr (fun fmt v ->
(if is_output m v then pp_ptr_decl else pp_var_decl) fmt v)))
(name, inputs @ outputs, mem, mem)
- (pp_assigns pp_ptr_decl) outputs
+ (pp_assigns pp_ptr_decl)
+ outputs
(pp_assigns (pp_reg self))
m.mmemory
(pp_assigns pp_reset_flag')
@@ -826,12 +975,15 @@ module SrcMod = struct
insts
(pp_assigns (pp_reset_flag_chain ~indirect:false mem))
insts'')
- fmt ()
+ fmt
+ ()
let pp_ghost_instr_code m self fmt instr =
match instr.instr_desc with
| MStateAssign (x, v) ->
- fprintf fmt "@,%a"
+ fprintf
+ fmt
+ "@,%a"
(pp_acsl_line (pp_ghost (pp_assign m self (pp_c_var_read m))))
(x, v)
| MResetAssign b ->
@@ -839,29 +991,75 @@ module SrcMod = struct
| MSetReset inst ->
let td, _ = List.assoc inst m.minstances in
if Arrow.td_is_arrow td then
- fprintf fmt "@,%a;"
+ fprintf
+ fmt
+ "@,%a;"
(pp_acsl_line (pp_ghost (pp_arrow_reset_ghost self)))
inst
| _ ->
()
let pp_step_instr_spec m self mem fmt instr =
- fprintf fmt "%a%a"
+ fprintf
+ fmt
+ "%a%a"
(pp_ghost_instr_code m mem)
instr
- (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:pp_print_cut
(pp_acsl_line' (pp_assert (PrintSpec.pp_spec (InstrMode self) m))))
instr.instr_spec
let pp_ghost_parameter mem fmt inst =
- GhostProto.pp_ghost_parameters ~cut:false fmt
+ GhostProto.pp_ghost_parameters
+ ~cut:false
+ fmt
(match inst with
| Some inst ->
- [ (inst, fun fmt inst -> fprintf fmt "&%a" pp_indirect' (mem, inst)) ]
+ [ (inst, fun fmt inst -> pp_ref pp_indirect' fmt (mem, inst)) ]
| None ->
[ mem, pp_print_string ])
end
+module MainMod = struct
+ let main_mem_ghost = "main_mem_ghost"
+
+ let pp_declare_ghost_state fmt name =
+ pp_acsl_line'_cut
+ (pp_ghost (fun fmt () ->
+ fprintf
+ fmt
+ "%a(,%s);"
+ (pp_machine_static_alloc_name ~ghost:true)
+ name
+ main_mem_ghost))
+ fmt
+ ()
+
+ let pp_ghost_state_parameter fmt () =
+ GhostProto.pp_ghost_parameters
+ ~cut:false
+ fmt
+ [ main_mem_ghost, pp_ref pp_print_string ]
+
+ let pp_main_spec fmt m =
+ (* let name = m.mname.node_id in *)
+ pp_acsl_cut
+ (fun fmt () ->
+ fprintf
+ fmt
+ "%a@,%a@,%a"
+ (pp_ensures pp_false)
+ ()
+ (pp_assigns pp_print_string)
+ []
+ (pp_terminates pp_false)
+ ())
+ fmt
+ ()
+end
+
(**************************************************************************)
(* MAKEFILE *)
(**************************************************************************)
@@ -871,33 +1069,49 @@ module MakefileMod = struct
fprintf fmt "FRAMACEACSL=`frama-c -print-share-path`/e-acsl@.";
(* EACSL version of library file . c *)
fprintf fmt "%s_eacsl.c: %s.c %s.h@." basename basename basename;
- fprintf fmt
+ fprintf
+ fmt
"\tframa-c -e-acsl-full-mmodel -machdep x86_64 -e-acsl %s.c -then-on \
e-acsl -print -ocode %s_eacsl.c@."
- basename basename;
+ basename
+ basename;
fprintf fmt "@.";
fprintf fmt "@.";
(* EACSL version of library file . c + main .c *)
- fprintf fmt "%s_main_eacsl.c: %s.c %s.h %s_main.c@." basename basename
- basename basename;
- fprintf fmt
+ fprintf
+ fmt
+ "%s_main_eacsl.c: %s.c %s.h %s_main.c@."
+ basename
+ basename
+ basename
+ basename;
+ fprintf
+ fmt
"\tframa-c -e-acsl-full-mmodel -machdep x86_64 -e-acsl %s.c %s_main.c \
-then-on e-acsl -print -ocode %s_main_eacsl.i@."
- basename basename basename;
+ basename
+ basename
+ basename;
(* Ugly hack to deal with eacsl bugs *)
- fprintf fmt "\tgrep -v _fc_stdout %s_main_eacsl.i > %s_main_eacsl.c"
- basename basename;
+ fprintf
+ fmt
+ "\tgrep -v _fc_stdout %s_main_eacsl.i > %s_main_eacsl.c"
+ basename
+ basename;
fprintf fmt "@.";
fprintf fmt "@.";
(* EACSL version of binary *)
fprintf fmt "%s_main_eacsl: %s_main_eacsl.c@." basename basename;
- fprintf fmt "\t${GCC} -Wno-attributes -I${INC} -I. -c %s_main_eacsl.c@."
+ fprintf
+ fmt
+ "\t${GCC} -Wno-attributes -I${INC} -I. -c %s_main_eacsl.c@."
basename;
(* compiling instrumented lib + main *)
C_backend_makefile.fprintf_dependencies fmt dependencies;
- fprintf fmt
+ fprintf
+ fmt
"\t${GCC} -Wno-attributes -o %s_main_eacsl io_frontend.o %a %s \
%s_main_eacsl.o %a@."
basename
diff --git a/src/backends/C/c_backend_spec.mli b/src/backends/C/c_backend_spec.mli
index 5f89b425..f25935f2 100644
--- a/src/backends/C/c_backend_spec.mli
+++ b/src/backends/C/c_backend_spec.mli
@@ -3,3 +3,5 @@ module HdrMod : C_backend_header.MODIFIERS_HDR
module SrcMod : C_backend_src.MODIFIERS_SRC
module MakefileMod : C_backend_makefile.MODIFIERS_MKF
+
+module MainMod : C_backend_main.MODIFIERS_MAINSRC
diff --git a/src/backends/C/c_backend_src.ml b/src/backends/C/c_backend_src.ml
index 121ae917..b1428331 100644
--- a/src/backends/C/c_backend_src.ml
+++ b/src/backends/C/c_backend_src.ml
@@ -116,8 +116,12 @@ module Main (Mod : MODIFIERS_SRC) = struct
let node, static =
try List.assoc inst m.minstances
with Not_found ->
- eprintf "internal error: %s %s %s %s:@." fn_name m.mname.node_id
- self inst;
+ eprintf
+ "internal error: %s %s %s %s:@."
+ fn_name
+ m.mname.node_id
+ self
+ inst;
raise Not_found
in
node_name node, Arrow.td_is_arrow node, static
@@ -125,23 +129,37 @@ module Main (Mod : MODIFIERS_SRC) = struct
m.mname.node_id, false, []
in
let is_arrow_reset = is_arrow && fn_name = "pp_machine_set_reset" in
- fprintf fmt "%a(%a%s%a)%a;"
+ fprintf
+ fmt
+ "%a(%a%s%a)%a;"
(if is_arrow_reset then fun fmt -> fprintf fmt "%s_reset"
else pp_machine_name)
name
(pp_comma_list ~pp_eol:pp_print_comma Dimension.pp)
- static self
+ static
+ self
(pp_print_option (fun fmt -> fprintf fmt "->%s"))
inst
(if is_arrow_reset then pp_print_nothing else Mod.pp_ghost_parameter mem)
inst
let pp_machine_set_reset m self mem fmt inst =
- pp_machine_ pp_machine_set_reset_name "pp_machine_set_reset" m fmt ~inst
- self mem
+ pp_machine_
+ pp_machine_set_reset_name
+ "pp_machine_set_reset"
+ m
+ fmt
+ ~inst
+ self
+ mem
let pp_machine_clear_reset m self mem fmt =
- pp_machine_ pp_machine_clear_reset_name "pp_machine_clear_reset" m fmt self
+ pp_machine_
+ pp_machine_clear_reset_name
+ "pp_machine_clear_reset"
+ m
+ fmt
+ self
mem
let pp_machine_init m self mem fmt inst =
@@ -154,19 +172,31 @@ module Main (Mod : MODIFIERS_SRC) = struct
try
(* stateful node instance *)
let n, _ = List.assoc i m.minstances in
- fprintf fmt "%a(%a%a%s->%s)%a;" pp_machine_step_name (node_name n)
+ fprintf
+ fmt
+ "%a(%a%a%s->%s)%a;"
+ pp_machine_step_name
+ (node_name n)
(pp_comma_list ~pp_eol:pp_print_comma (pp_c_val m self pp_read))
inputs
(pp_comma_list ~pp_eol:pp_print_comma pp_write)
- outputs self i
+ outputs
+ self
+ i
(Mod.pp_ghost_parameter mem)
(Some i)
with Not_found ->
(* stateless node instance *)
let n, _ = List.assoc i m.mcalls in
- fprintf fmt "%a(%a%a);" pp_machine_step_name (node_name n)
+ fprintf
+ fmt
+ "%a(%a%a);"
+ pp_machine_step_name
+ (node_name n)
(pp_comma_list ~pp_eol:pp_print_comma (pp_c_val m self pp_read))
- inputs (pp_comma_list pp_write) outputs
+ inputs
+ (pp_comma_list pp_write)
+ outputs
let pp_basic_instance_call m self mem =
pp_call m self mem (pp_c_var_read m) (pp_c_var_write m)
@@ -174,8 +204,15 @@ module Main (Mod : MODIFIERS_SRC) = struct
let pp_arrow_call m self mem fmt i outputs =
match outputs with
| [ x ] ->
- fprintf fmt "%a = %a(%s->%s)%a;" (pp_c_var_read m) x pp_machine_step_name
- Arrow.arrow_id self i
+ fprintf
+ fmt
+ "%a = %a(%s->%s)%a;"
+ (pp_c_var_read m)
+ x
+ pp_machine_step_name
+ Arrow.arrow_id
+ self
+ i
(Mod.pp_ghost_parameter mem)
(Some i)
| _ ->
@@ -183,7 +220,11 @@ module Main (Mod : MODIFIERS_SRC) = struct
let pp_instance_call m self mem fmt i inputs outputs =
let pp_offset pp_var indices fmt var =
- fprintf fmt "%a%a" pp_var var
+ fprintf
+ fmt
+ "%a%a"
+ pp_var
+ var
(pp_print_list ~pp_sep:pp_print_nothing (fun fmt -> fprintf fmt "[%s]"))
indices
in
@@ -191,8 +232,15 @@ module Main (Mod : MODIFIERS_SRC) = struct
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
+ 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
@@ -205,7 +253,9 @@ module Main (Mod : MODIFIERS_SRC) = struct
let rec pp_conditional dependencies m self mem fmt c tl el =
let pp_machine_instrs =
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:pp_print_cut
(pp_machine_instr dependencies m self mem)
in
let pp_cond = pp_c_val m self (pp_c_var_read m) in
@@ -215,8 +265,15 @@ module Main (Mod : MODIFIERS_SRC) = struct
| _, [] ->
fprintf fmt "@[<v 2>if (%a) {%a@]@,}" pp_cond c pp_machine_instrs tl
| _, _ ->
- fprintf fmt "@[<v 2>if (%a) {%a@]@,@[<v 2>} else {%a@]@,}" pp_cond c
- pp_machine_instrs tl pp_machine_instrs el
+ fprintf
+ fmt
+ "@[<v 2>if (%a) {%a@]@,@[<v 2>} else {%a@]@,}"
+ pp_cond
+ c
+ pp_machine_instrs
+ tl
+ pp_machine_instrs
+ el
and pp_machine_instr dependencies m self mem fmt instr =
let pp_instr fmt instr =
@@ -227,9 +284,12 @@ module Main (Mod : MODIFIERS_SRC) = struct
pp_machine_set_reset m self mem fmt inst
| MClearReset ->
if not (fst (get_stateless_status m)) then
- fprintf fmt "%t@,%a"
+ fprintf
+ fmt
+ "%t@,%a"
(pp_machine_clear_reset m self mem)
- pp_label reset_label
+ pp_label
+ reset_label
| MResetAssign b ->
pp_reset_assign self fmt b
| MLocalAssign (i, v) ->
@@ -239,13 +299,21 @@ module Main (Mod : MODIFIERS_SRC) = struct
| MStep ([ i0 ], i, vl)
when Basic_library.is_value_internal_fun
(mk_val (Fun (i, vl)) i0.var_type) ->
- pp_machine_instr dependencies m self mem fmt
- (update_instr_desc instr
+ pp_machine_instr
+ dependencies
+ m
+ self
+ mem
+ fmt
+ (update_instr_desc
+ instr
(MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type)))
| MStep (il, i, vl) when !Options.mpfr && Mpfr.is_homomorphic_fun i ->
pp_instance_call m self mem fmt i vl il
| MStep ([ i0 ], i, vl) when has_c_prototype i dependencies ->
- fprintf fmt "%a = %s%a;"
+ fprintf
+ fmt
+ "%a = %s%a;"
(pp_c_val m self (pp_c_var_read m))
(mk_val (Var i0) i0.var_type)
i
@@ -256,8 +324,10 @@ module Main (Mod : MODIFIERS_SRC) = struct
if Arrow.td_is_arrow td then pp_arrow_call m self mem fmt i il
else pp_basic_instance_call m self mem fmt i vl il
| MBranch (_, []) ->
- eprintf "internal error: C_backend_src.pp_machine_instr %a@."
- (pp_instr m) instr;
+ eprintf
+ "internal error: C_backend_src.pp_machine_instr %a@."
+ (pp_instr m)
+ instr;
assert false
| MBranch (g, hl) ->
if
@@ -274,16 +344,26 @@ module Main (Mod : MODIFIERS_SRC) = struct
List.filter (fun i ->
match i.instr_desc with MNoReset _ -> false | _ -> true)
in
- pp_conditional dependencies m self mem fmt g (no_noreset tl)
+ pp_conditional
+ dependencies
+ m
+ self
+ mem
+ fmt
+ g
+ (no_noreset tl)
(no_noreset el)
else
(* enum type case *)
(*let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst
(List.hd hl))) in*)
- fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
+ fprintf
+ fmt
+ "@[<v 2>switch(%a) {@,%a@,}@]"
(pp_c_val m self (pp_c_var_read m))
g
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
(pp_machine_branch dependencies m self mem))
hl
| MSpec s ->
@@ -294,8 +374,13 @@ module Main (Mod : MODIFIERS_SRC) = struct
fprintf fmt "%a%a" pp_instr instr (Mod.pp_step_instr_spec m self mem) instr
and pp_machine_branch dependencies m self mem fmt (t, h) =
- fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ fprintf
+ fmt
+ "@[<v 2>case %a:@,%a@,break;@]"
+ pp_c_tag
+ t
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
(pp_machine_instr dependencies m self mem))
h
@@ -311,53 +396,84 @@ module Main (Mod : MODIFIERS_SRC) = struct
(* C file Printing functions *)
(********************************************************************************************)
- let print_const_def fmt tdecl =
+ let pp_const_def fmt tdecl =
let cdecl = const_of_top tdecl in
if !Options.mpfr && Types.(is_real_type (array_base_type cdecl.const_type))
then
- fprintf fmt "%a;" (pp_c_type cdecl.const_id)
+ fprintf
+ fmt
+ "%a;"
+ (pp_c_type cdecl.const_id)
(Types.dynamic_type cdecl.const_type)
else
- fprintf fmt "%a = %a;" (pp_c_type cdecl.const_id) cdecl.const_type
- pp_c_const cdecl.const_value
-
- let print_alloc_instance fmt (i, (m, static)) =
- fprintf fmt "_alloc->%s = %a %a;" i pp_machine_alloc_name (node_name m)
+ fprintf
+ fmt
+ "%a = %a;"
+ (pp_c_type cdecl.const_id)
+ cdecl.const_type
+ pp_c_const
+ cdecl.const_value
+
+ let pp_alloc_instance fmt (i, (m, static)) =
+ fprintf
+ fmt
+ "_alloc->%s = %a %a;"
+ i
+ pp_machine_alloc_name
+ (node_name m)
(pp_print_parenthesized Dimension.pp)
static
- let print_dealloc_instance fmt (i, (m, _)) =
+ let pp_dealloc_instance fmt (i, (m, _)) =
fprintf fmt "%a (_alloc->%s);" pp_machine_dealloc_name (node_name m) i
let const_locals m =
List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals
let pp_c_decl_array_mem self fmt id =
- fprintf fmt "%a = (%a) (%s->_reg.%s)"
+ fprintf
+ fmt
+ "%a = (%a) (%s->_reg.%s)"
(pp_c_type (sprintf "(*%s)" id.var_id))
- id.var_type (pp_c_type "(*)") id.var_type self id.var_id
-
- let print_alloc_const fmt m =
- pp_print_list ~pp_sep:(pp_print_endcut ";") ~pp_eol:(pp_print_endcut ";")
- (pp_c_decl_local_var m) fmt (const_locals m)
+ id.var_type
+ (pp_c_type "(*)")
+ id.var_type
+ self
+ id.var_id
+
+ let pp_alloc_const fmt m =
+ pp_print_list
+ ~pp_sep:(pp_print_endcut ";")
+ ~pp_eol:(pp_print_endcut ";")
+ (pp_c_decl_local_var m)
+ fmt
+ (const_locals m)
- let print_alloc_array fmt vdecl =
+ let pp_alloc_array fmt vdecl =
let base_type = Types.array_base_type vdecl.var_type in
let size_types = Types.array_type_multi_dimension vdecl.var_type in
let size_type = Dimension.multi_product vdecl.var_loc size_types in
- fprintf fmt
+ fprintf
+ fmt
"_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);"
- vdecl.var_id (pp_c_type "") base_type Dimension.pp size_type
- (pp_c_type "") base_type vdecl.var_id
-
- let print_dealloc_array fmt vdecl =
+ vdecl.var_id
+ (pp_c_type "")
+ base_type
+ Dimension.pp
+ size_type
+ (pp_c_type "")
+ base_type
+ vdecl.var_id
+
+ let pp_dealloc_array fmt vdecl =
fprintf fmt "free (_alloc->_reg.%s);" vdecl.var_id
let array_mems m =
List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
- let print_alloc_code fmt m =
- fprintf fmt
+ let pp_alloc_code fmt m =
+ fprintf
+ fmt
"%a *_alloc;@,\
_alloc = (%a *) malloc(sizeof(%a));@,\
assert(_alloc);@,\
@@ -368,16 +484,18 @@ module Main (Mod : MODIFIERS_SRC) = struct
m.mname.node_id
(pp_machine_memtype_name ~ghost:false)
m.mname.node_id
- (pp_print_list ~pp_sep:pp_print_nothing print_alloc_array)
+ (pp_print_list ~pp_sep:pp_print_nothing pp_alloc_array)
(array_mems m)
- (pp_print_list ~pp_sep:pp_print_nothing print_alloc_instance)
+ (pp_print_list ~pp_sep:pp_print_nothing pp_alloc_instance)
m.minstances
- let print_dealloc_code fmt m =
- fprintf fmt "%a%afree (_alloc);@,return;"
- (pp_print_list ~pp_sep:pp_print_nothing print_dealloc_array)
+ let pp_dealloc_code fmt m =
+ fprintf
+ fmt
+ "%a%afree (_alloc);@,return;"
+ (pp_print_list ~pp_sep:pp_print_nothing pp_dealloc_array)
(array_mems m)
- (pp_print_list ~pp_sep:pp_print_nothing print_dealloc_instance)
+ (pp_print_list ~pp_sep:pp_print_nothing pp_dealloc_instance)
m.minstances
(* let print_stateless_init_code fmt m self =
@@ -411,7 +529,11 @@ module Main (Mod : MODIFIERS_SRC) = struct
* (Utils.pp_newline_if_non_empty m.minit) *)
let pp_c_check m self fmt (loc, check) =
- fprintf fmt "@[<v>%a@,assert (%a);@]" Location.pp_c loc
+ fprintf
+ fmt
+ "@[<v>%a@,assert (%a);@]"
+ Location.pp_c
+ loc
(pp_c_val m self (pp_c_var_read m))
check
@@ -423,15 +545,26 @@ module Main (Mod : MODIFIERS_SRC) = struct
?(pp_check = pp_print_nothing) ?(checks = [])
?(pp_extra = pp_print_nothing)
?(pp_instr = fun fmt _ -> pp_print_nothing fmt ()) ?(instrs = []) fmt =
- fprintf fmt "%a@[<v 2>%a {@,%a%a%a%a%a%a%areturn;@]@,}" pp_spec ()
- pp_prototype prototype
+ fprintf
+ fmt
+ "%a@[<v 2>%a {@,%a%a%a%a%a%a%areturn;@]@,}"
+ pp_spec
+ ()
+ pp_prototype
+ prototype
(* locals *)
- (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_semicolon
- ~pp_eol:pp_print_semicolon pp_local)
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:pp_print_semicolon
+ ~pp_eol:pp_print_semicolon
+ pp_local)
base_locals
(* array mems *)
- (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_semicolon
- ~pp_eol:pp_print_semicolon pp_array_mem)
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:pp_print_semicolon
+ ~pp_eol:pp_print_semicolon
+ pp_array_mem)
array_mems
(* locals initialization *)
(pp_print_list ~pp_epilogue:pp_print_cut pp_init_mpfr_local)
@@ -440,13 +573,16 @@ module Main (Mod : MODIFIERS_SRC) = struct
(pp_print_list pp_check)
checks
(* instrs *)
- (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_epilogue:pp_print_cut
pp_instr)
instrs
(* locals clear *)
(pp_print_list ~pp_epilogue:pp_print_cut pp_clear_mpfr_local)
(mpfr_vars mpfr_locals) (* extra *)
- pp_extra ()
+ pp_extra
+ ()
let node_of_machine m =
{
@@ -456,21 +592,24 @@ module Main (Mod : MODIFIERS_SRC) = struct
top_decl_itf = false;
}
- let print_stateless_code machines dependencies fmt m =
+ let pp_stateless_code machines dependencies fmt m =
let self = "__ERROR__" in
if not (!Options.ansi && is_generic_node (node_of_machine m)) then
(* C99 code *)
pp_print_function
~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self self m)
- ~pp_prototype:Protos.print_stateless_prototype
+ ~pp_prototype:Protos.pp_stateless_prototype
~prototype:(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
- ~pp_local:(pp_c_decl_local_var m) ~base_locals:m.mstep.step_locals
+ ~pp_local:(pp_c_decl_local_var m)
+ ~base_locals:m.mstep.step_locals
~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mstep.step_locals ~pp_check:(pp_c_check m self)
+ ~mpfr_locals:m.mstep.step_locals
+ ~pp_check:(pp_c_check m self)
~checks:m.mstep.step_checks
~pp_instr:(pp_machine_instr dependencies m self self)
- ~instrs:m.mstep.step_instrs fmt
+ ~instrs:m.mstep.step_instrs
+ fmt
else
(* C90 code *)
let gen_locals, base_locals =
@@ -485,25 +624,30 @@ module Main (Mod : MODIFIERS_SRC) = struct
mk_call_var_decl e.expr_loc id)
m.mname.node_gencalls
in
- pp_print_function ~pp_prototype:Protos.print_stateless_prototype
+ pp_print_function
+ ~pp_prototype:Protos.pp_stateless_prototype
~prototype:
( m.mname.node_id,
m.mstep.step_inputs @ gen_locals @ gen_calls,
m.mstep.step_outputs )
- ~pp_local:(pp_c_decl_local_var m) ~base_locals
+ ~pp_local:(pp_c_decl_local_var m)
+ ~base_locals
~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mstep.step_locals ~pp_check:(pp_c_check m self)
+ ~mpfr_locals:m.mstep.step_locals
+ ~pp_check:(pp_c_check m self)
~checks:m.mstep.step_checks
~pp_instr:(pp_machine_instr dependencies m self self)
- ~instrs:m.mstep.step_instrs fmt
+ ~instrs:m.mstep.step_instrs
+ fmt
- let print_clear_reset_code dependencies self mem fmt m =
+ let pp_clear_reset_code dependencies self mem fmt m =
pp_print_function
~pp_spec:(fun fmt () -> Mod.pp_clear_reset_spec fmt self mem m)
- ~pp_prototype:(Protos.print_clear_reset_prototype self mem)
+ ~pp_prototype:(Protos.pp_clear_reset_prototype self mem)
~prototype:(m.mname.node_id, m.mstatic)
- ~pp_local:(pp_c_decl_local_var m) ~base_locals:(const_locals m)
+ ~pp_local:(pp_c_decl_local_var m)
+ ~base_locals:(const_locals m)
~pp_instr:(pp_machine_instr dependencies m self mem)
~instrs:
[
@@ -513,16 +657,16 @@ module Main (Mod : MODIFIERS_SRC) = struct
]
fmt
- let print_set_reset_code dependencies self mem fmt m =
+ let pp_set_reset_code dependencies self mem fmt m =
pp_print_function
~pp_spec:(fun fmt () -> Mod.pp_set_reset_spec fmt self mem m)
- ~pp_prototype:(Protos.print_set_reset_prototype self mem)
+ ~pp_prototype:(Protos.pp_set_reset_prototype self mem)
~prototype:(m.mname.node_id, m.mstatic)
~pp_instr:(pp_machine_instr dependencies m self mem)
~instrs:[ mkinstr (MResetAssign true) ]
fmt
- let print_init_code self fmt m =
+ let pp_init_code self fmt m =
let minit =
List.map
(fun i ->
@@ -530,18 +674,22 @@ module Main (Mod : MODIFIERS_SRC) = struct
m.minit
in
pp_print_function
- ~pp_prototype:(Protos.print_init_prototype self)
+ ~pp_prototype:(Protos.pp_init_prototype self)
~prototype:(m.mname.node_id, m.mstatic)
- ~pp_array_mem:(pp_c_decl_array_mem self) ~array_mems:(array_mems m)
+ ~pp_array_mem:(pp_c_decl_array_mem self)
+ ~array_mems:(array_mems m)
~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
~mpfr_locals:m.mmemory
~pp_extra:(fun fmt () ->
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_epilogue:pp_print_cut
(pp_machine_init m self self)
- fmt minit)
+ fmt
+ minit)
fmt
- let print_clear_code self fmt m =
+ let pp_clear_code self fmt m =
let minit =
List.map
(fun i ->
@@ -549,32 +697,40 @@ module Main (Mod : MODIFIERS_SRC) = struct
m.minit
in
pp_print_function
- ~pp_prototype:(Protos.print_clear_prototype self)
+ ~pp_prototype:(Protos.pp_clear_prototype self)
~prototype:(m.mname.node_id, m.mstatic)
- ~pp_array_mem:(pp_c_decl_array_mem self) ~array_mems:(array_mems m)
+ ~pp_array_mem:(pp_c_decl_array_mem self)
+ ~array_mems:(array_mems m)
~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
~mpfr_locals:m.mmemory
~pp_extra:(fun fmt () ->
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_epilogue:pp_print_cut
(pp_machine_clear m self self)
- fmt minit)
+ fmt
+ minit)
fmt
- let print_step_code machines dependencies self mem fmt m =
+ let pp_step_code machines dependencies self mem fmt m =
if not (!Options.ansi && is_generic_node (node_of_machine m)) then
(* C99 code *)
pp_print_function
~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
- ~pp_prototype:(Protos.print_step_prototype self mem)
+ ~pp_prototype:(Protos.pp_step_prototype self mem)
~prototype:(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
- ~pp_local:(pp_c_decl_local_var m) ~base_locals:m.mstep.step_locals
- ~pp_array_mem:(pp_c_decl_array_mem self) ~array_mems:(array_mems m)
+ ~pp_local:(pp_c_decl_local_var m)
+ ~base_locals:m.mstep.step_locals
+ ~pp_array_mem:(pp_c_decl_array_mem self)
+ ~array_mems:(array_mems m)
~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mstep.step_locals ~pp_check:(pp_c_check m self)
+ ~mpfr_locals:m.mstep.step_locals
+ ~pp_check:(pp_c_check m self)
~checks:m.mstep.step_checks
~pp_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:m.mstep.step_instrs fmt
+ ~instrs:m.mstep.step_instrs
+ fmt
else
(* C90 code *)
let gen_locals, base_locals =
@@ -591,18 +747,21 @@ module Main (Mod : MODIFIERS_SRC) = struct
in
pp_print_function
~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
- ~pp_prototype:(Protos.print_step_prototype self mem)
+ ~pp_prototype:(Protos.pp_step_prototype self mem)
~prototype:
( m.mname.node_id,
m.mstep.step_inputs @ gen_locals @ gen_calls,
m.mstep.step_outputs )
- ~pp_local:(pp_c_decl_local_var m) ~base_locals
+ ~pp_local:(pp_c_decl_local_var m)
+ ~base_locals
~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mstep.step_locals ~pp_check:(pp_c_check m self)
+ ~mpfr_locals:m.mstep.step_locals
+ ~pp_check:(pp_c_check m self)
~checks:m.mstep.step_checks
~pp_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:m.mstep.step_instrs fmt
+ ~instrs:m.mstep.step_instrs
+ fmt
(********************************************************************************************)
(* MAIN C file Printing functions *)
@@ -624,13 +783,16 @@ module Main (Mod : MODIFIERS_SRC) = struct
in
pp_print_list
(fun fmt i -> aux (string_of_int i :: indices) (value i) fmt typ')
- fmt szl
+ fmt
+ szl
else
let indices = List.rev indices in
let pp_var_suffix fmt var =
fprintf fmt "%a%a" (pp_c_val m "" pp_var) var pp_array_suffix indices
in
- fprintf fmt "%a@,%a"
+ fprintf
+ fmt
+ "%a@,%a"
(Mpfr.pp_inject_init pp_var_suffix)
var
(Mpfr.pp_inject_real pp_var_suffix pp_c_const)
@@ -646,8 +808,15 @@ module Main (Mod : MODIFIERS_SRC) = struct
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
+ 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
@@ -660,18 +829,19 @@ module Main (Mod : MODIFIERS_SRC) = struct
reset_loop_counter ();
aux [] fmt var.var_type
- let print_import_init fmt dep =
+ let pp_import_init fmt dep =
let baseNAME = file_to_module_name dep.name in
fprintf fmt "%a();" pp_global_init_name baseNAME
- let print_import_clear fmt dep =
+ let pp_import_clear fmt dep =
let baseNAME = file_to_module_name dep.name in
fprintf fmt "%a();" pp_global_clear_name baseNAME
- let print_global_init_code fmt (basename, prog, dependencies) =
+ let pp_global_init_code fmt (basename, prog, dependencies) =
let baseNAME = file_to_module_name basename in
let constants = List.map const_of_top (get_consts prog) in
- fprintf fmt
+ fprintf
+ fmt
"@[<v 2>%a {@,\
static %s init = 0;@,\
@[<v 2>if (!init) { @,\
@@ -679,20 +849,23 @@ module Main (Mod : MODIFIERS_SRC) = struct
}@,\
return;@]@,\
}"
- pp_global_init_prototype baseNAME
+ pp_global_init_prototype
+ baseNAME
(pp_c_basic_type_desc Type_predef.type_bool)
(* constants *)
- (pp_print_list ~pp_prologue:pp_print_cut
+ (pp_print_list
+ ~pp_prologue:pp_print_cut
(pp_const_initialize empty_machine (pp_c_var_read empty_machine)))
(mpfr_consts constants)
(* dependencies initialization *)
- (pp_print_list ~pp_prologue:pp_print_cut print_import_init)
+ (pp_print_list ~pp_prologue:pp_print_cut pp_import_init)
(List.filter (fun dep -> dep.local) dependencies)
- let print_global_clear_code fmt (basename, prog, dependencies) =
+ let pp_global_clear_code fmt (basename, prog, dependencies) =
let baseNAME = file_to_module_name basename in
let constants = List.map const_of_top (get_consts prog) in
- fprintf fmt
+ fprintf
+ fmt
"@[<v 2>%a {@,\
static %s clear = 0;@,\
@[<v 2>if (!clear) { @,\
@@ -700,33 +873,47 @@ module Main (Mod : MODIFIERS_SRC) = struct
}@,\
return;@]@,\
}"
- pp_global_clear_prototype baseNAME
+ pp_global_clear_prototype
+ baseNAME
(pp_c_basic_type_desc Type_predef.type_bool)
(* constants *)
- (pp_print_list ~pp_prologue:pp_print_cut
+ (pp_print_list
+ ~pp_prologue:pp_print_cut
(pp_const_clear (pp_c_var_read empty_machine)))
(mpfr_consts constants)
(* dependencies initialization *)
- (pp_print_list ~pp_prologue:pp_print_cut print_import_clear)
+ (pp_print_list ~pp_prologue:pp_print_cut pp_import_clear)
(List.filter (fun dep -> dep.local) dependencies)
- let print_alloc_function fmt m =
+ let pp_alloc_function fmt m =
if not !Options.static_mem then
(* Alloc functions, only if non static mode *)
- fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@,@[<v 2>%a {@,%a%a@]@,@,"
+ fprintf
+ fmt
+ "@[<v 2>%a {@,%a%a@]@,}@,@[<v 2>%a {@,%a%a@]@,@,"
pp_alloc_prototype
(m.mname.node_id, m.mstatic)
- print_alloc_const m print_alloc_code m pp_dealloc_prototype
- m.mname.node_id print_alloc_const m print_dealloc_code m
+ pp_alloc_const
+ m
+ pp_alloc_code
+ m
+ pp_dealloc_prototype
+ m.mname.node_id
+ pp_alloc_const
+ m
+ pp_dealloc_code
+ m
- let print_mpfr_code self fmt m =
+ let pp_mpfr_code self fmt m =
if !Options.mpfr then
- fprintf fmt "@,@[<v>%a@,%a@]"
+ fprintf
+ fmt
+ "@,@[<v>%a@,%a@]"
(* Init function *)
- (print_init_code self)
+ (pp_init_code self)
m
(* Clear function *)
- (print_clear_code self)
+ (pp_clear_code self)
m
(* TODO: ACSL - a contract machine shall not be directly printed in the C
@@ -734,25 +921,33 @@ module Main (Mod : MODIFIERS_SRC) = struct
integrate the associated statements, updating its memories, at the end of
the function body. - last one may print intermediate comment/acsl if/when
they are present in the sequence of instruction *)
- let print_machine machines dependencies fmt m =
+ let pp_machine machines dependencies fmt m =
if fst (get_stateless_status m) then
(* Step function *)
- print_stateless_code machines dependencies fmt m
+ pp_stateless_code machines dependencies fmt m
else
let self = mk_self m in
let mem = mk_mem m in
- fprintf fmt "@[<v>%a%a@,@,%a@,@,%a%a@]" print_alloc_function m
+ fprintf
+ fmt
+ "@[<v>%a%a@,@,%a@,@,%a%a@]"
+ pp_alloc_function
+ m
(* Reset functions *)
- (print_clear_reset_code dependencies self mem)
+ (pp_clear_reset_code dependencies self mem)
m
- (print_set_reset_code dependencies self mem)
+ (pp_set_reset_code dependencies self mem)
m
(* Step function *)
- (print_step_code machines dependencies self mem)
- m (print_mpfr_code self) m
+ (pp_step_code machines dependencies self mem)
+ m
+ (pp_mpfr_code self)
+ m
- let print_import_standard source_fmt () =
- fprintf source_fmt "@[<v>#include <assert.h>@,%a%a%a@]"
+ let pp_import_standard source_fmt () =
+ fprintf
+ source_fmt
+ "@[<v>#include <assert.h>@,%a%a%a@]"
(if Machine_types.has_machine_type () then
pp_print_endcut "#include <stdint.h>"
else pp_print_nothing)
@@ -764,14 +959,23 @@ module Main (Mod : MODIFIERS_SRC) = struct
else pp_print_nothing)
()
- let print_extern_alloc_prototype fmt ind =
+ let pp_extern_alloc_prototype fmt ind =
let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in
- fprintf fmt "extern %a;@,extern %a;" pp_alloc_prototype
- (ind.nodei_id, static) pp_dealloc_prototype ind.nodei_id
-
- let print_lib_c source_fmt basename prog machines dependencies =
- fprintf source_fmt "@[<v>%a%a@,@,%a@,%a%a%a%a%a%a%a@]@."
- print_import_standard () pp_import_prototype
+ fprintf
+ fmt
+ "extern %a;@,extern %a;"
+ pp_alloc_prototype
+ (ind.nodei_id, static)
+ pp_dealloc_prototype
+ ind.nodei_id
+
+ let pp_lib_c source_fmt basename prog machines dependencies =
+ fprintf
+ source_fmt
+ "@[<v>%a%a@,@,%a@,%a%a%a%a%a%a%a@]@."
+ pp_import_standard
+ ()
+ pp_import_prototype
{
local = true;
name = basename;
@@ -779,40 +983,53 @@ module Main (Mod : MODIFIERS_SRC) = struct
is_stateful = true (* assuming it is stateful *);
}
(* Print the svn version number and the supported C standard (C90 or C99) *)
- pp_print_version ()
+ pp_print_version
+ ()
(* Print dependencies *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Import dependencies */")
- pp_import_prototype ~pp_epilogue:pp_print_cutcut)
+ pp_import_prototype
+ ~pp_epilogue:pp_print_cutcut)
dependencies
(* Print consts *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Global constants (definitions) */")
- print_const_def ~pp_epilogue:pp_print_cutcut)
+ pp_const_def
+ ~pp_epilogue:pp_print_cutcut)
(get_consts prog)
(* MPFR *)
(if !Options.mpfr then fun fmt () ->
- fprintf fmt
+ fprintf
+ fmt
"@[<v>/* Global constants initialization */@,\
%a@,\
@,\
/* Global constants clearing */@,\
%a@]@,\
@,"
- print_global_init_code
+ pp_global_init_code
(basename, prog, dependencies)
- print_global_clear_code
+ pp_global_clear_code
(basename, prog, dependencies)
else pp_print_nothing)
()
(if not !Options.static_mem then fun fmt () ->
- fprintf fmt "@[<v>%a%a@]@,@,"
- (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ fprintf
+ fmt
+ "@[<v>%a%a@]@,@,"
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_epilogue:pp_print_cut
~pp_prologue:
(pp_print_endcut "/* External allocation function prototypes */")
(fun fmt dep ->
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
- print_extern_alloc_prototype fmt
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_epilogue:pp_print_cut
+ pp_extern_alloc_prototype
+ fmt
(List.filter_map
(fun decl ->
match decl.top_decl_desc with
@@ -822,24 +1039,37 @@ module Main (Mod : MODIFIERS_SRC) = struct
None)
dep.content)))
dependencies
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:
(pp_print_endcut "/* Node allocation function prototypes */")
- ~pp_sep:pp_print_cutcut (fun fmt m ->
- fprintf fmt "%a;@,%a;" pp_alloc_prototype
+ ~pp_sep:pp_print_cutcut
+ (fun fmt m ->
+ fprintf
+ fmt
+ "%a;@,%a;"
+ pp_alloc_prototype
(m.mname.node_id, m.mstatic)
- pp_dealloc_prototype m.mname.node_id))
+ pp_dealloc_prototype
+ m.mname.node_id))
machines
else pp_print_nothing)
()
(* Print the struct definitions of all machines. *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
~pp_prologue:(pp_print_endcut "/* Struct definitions */")
- ~pp_sep:pp_print_cutcut pp_machine_struct ~pp_epilogue:pp_print_cutcut)
- machines (* Print the spec predicates *) Mod.pp_predicates machines
+ ~pp_sep:pp_print_cutcut
+ pp_machine_struct
+ ~pp_epilogue:pp_print_cutcut)
+ machines
+ (* Print the spec predicates *) Mod.pp_predicates
+ machines
(* Print nodes one by one (in the previous order) *)
- (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_cutcut
- (print_machine machines dependencies))
+ (pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:pp_print_cutcut
+ (pp_machine machines dependencies))
machines
end
diff --git a/src/backends/C/c_backend_src.mli b/src/backends/C/c_backend_src.mli
index f08f3b53..a51a0beb 100644
--- a/src/backends/C/c_backend_src.mli
+++ b/src/backends/C/c_backend_src.mli
@@ -25,6 +25,6 @@ end
module EmptyMod : MODIFIERS_SRC
module Main (Mod : MODIFIERS_SRC) : sig
- val print_lib_c :
+ val pp_lib_c :
formatter -> string -> program_t -> machine_t list -> dep_t list -> unit
end
diff --git a/src/backends/EMF/EMF_backend.ml b/src/backends/EMF/EMF_backend.ml
index 9d3a47e2..db2a361d 100644
--- a/src/backends/EMF/EMF_backend.ml
+++ b/src/backends/EMF/EMF_backend.ml
@@ -170,7 +170,7 @@ let get_instr_id fmt i =
incr branch_cpt;
fprintf fmt "branch_%i" !branch_cpt
| MStep (outs, id, _) ->
- print_protect fmt (fun fmt ->
+ pp_protect fmt (fun fmt ->
fprintf fmt "%a_%s" (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "_")
pp_var_name) outs id)
| _ -> ()
@@ -355,7 +355,7 @@ let rec pp_emf_instr m fmt i =
(fun v -> not (ISet.mem v.var_id branch_all_lhs))
branch_inputs
in
- fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt ->
+ fprintf fmt "@[<v 2>\"%a\": {@ " pp_protect (fun fmt ->
Format.pp_print_string fmt tag);
fprintf fmt "\"guard_value\": \"%a\",@ " pp_tag_id tag;
fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl
@@ -376,7 +376,7 @@ let rec pp_emf_instr m fmt i =
let is_stateful = List.mem_assoc f m.minstances in
fprintf fmt "\"kind\": \"%s\",@ \"name\": \"%a\",@ \"id\": \"%s\",@ "
(if is_stateful then "statefulcall" else "statelesscall")
- print_protect
+ pp_protect
(fun fmt -> pp_print_string fmt node_f.node_id)
f;
fprintf fmt "\"lhs\": [@[%a@]],@ \"args\": [@[%a@]]"
@@ -454,7 +454,7 @@ let pp_emf_annots_list cpt fmt annots_list =
(* let pp_emf_contract fmt nd =
* let c = Printers.node_as_contract nd in
* fprintf fmt "@[<v 2>\"%a\": {@ "
- * print_protect (fun fmt -> pp_print_string fmt nd.node_id);
+ * pp_protect (fun fmt -> pp_print_string fmt nd.node_id);
* fprintf fmt "\"contract\": %a@ "
* pp_emf_spec c;
* fprintf fmt "@]@ }" *)
@@ -465,7 +465,7 @@ let pp_machine fmt m =
m.mstep.step_instrs
in
(* try *)
- fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt ->
+ fprintf fmt "@[<v 2>\"%a\": {@ " pp_protect (fun fmt ->
pp_print_string fmt m.mname.node_id);
(match m.mspec.mnode_spec with
| Some (Contract _) -> fprintf fmt "\"contract\": \"true\",@ "
@@ -506,7 +506,7 @@ let pp_machine fmt m =
let pp_emf_imported_node fmt top =
let ind = Corelang.imported_node_of_top top in
(* try *)
- fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt ->
+ fprintf fmt "@[<v 2>\"%a\": {@ " pp_protect (fun fmt ->
pp_print_string fmt ind.nodei_id);
fprintf fmt "\"imported\": \"true\",@ ";
fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl ind.nodei_inputs;
diff --git a/src/backends/EMF/EMF_common.ml b/src/backends/EMF/EMF_common.ml
index c313cf0b..f03f5bb2 100644
--- a/src/backends/EMF/EMF_common.ml
+++ b/src/backends/EMF/EMF_common.ml
@@ -23,7 +23,8 @@ let rec get_expr_vars v =
| Fun (_, args) ->
List.fold_left
(fun accu v -> VSet.union accu (get_expr_vars v))
- VSet.empty args
+ VSet.empty
+ args
| _ ->
assert false
(* Invalid argument *)
@@ -45,7 +46,7 @@ let hash_map = Hashtbl.create 13
(* If string length of f is longer than 50 chars, we select the 10 first and
last and put a hash in the middle *)
-let print_protect fmt f =
+let pp_protect fmt f =
fprintf str_formatter "%t" f;
let s = flush_str_formatter () in
let l = String.length s in
@@ -69,10 +70,9 @@ let print_protect fmt f =
let pp_var_string fmt v =
fprintf fmt "\"%t\"" (fun fmt ->
- print_protect fmt (fun fmt -> fprintf fmt "%s" v))
+ pp_protect fmt (fun fmt -> fprintf fmt "%s" v))
-let pp_var_name fmt v =
- print_protect fmt (fun fmt -> Printers.pp_var_name fmt v)
+let pp_var_name fmt v = pp_protect fmt (fun fmt -> Printers.pp_var_name fmt v)
(*let pp_node_args = fprintf_list ~sep:", " pp_var_name*)
(********* Printing types ***********)
@@ -92,12 +92,22 @@ let rec pp_emf_dim fmt dim_expr =
| Dident s ->
fprintf fmt "\"kind\": \"ident\",@ \"value\": \"%s\"" s
| Dappl (f, args) ->
- fprintf fmt "\"kind\": \"fun\",@ \"id\": \"%s\",@ \"args\": [@[%a@]]" f
- (pp_comma_list pp_emf_dim) args
+ fprintf
+ fmt
+ "\"kind\": \"fun\",@ \"id\": \"%s\",@ \"args\": [@[%a@]]"
+ f
+ (pp_comma_list pp_emf_dim)
+ args
| Dite (i, t, e) ->
- fprintf fmt
+ fprintf
+ fmt
"\"kind\": \"ite\",@ \"guard\": \"%a\",@ \"then\": %a,@ \"else\": %a"
- pp_emf_dim i pp_emf_dim t pp_emf_dim e
+ pp_emf_dim
+ i
+ pp_emf_dim
+ t
+ pp_emf_dim
+ e
| Dlink e ->
pp_emf_dim fmt e
| Dvar | Dunivar ->
@@ -145,9 +155,12 @@ let rec pp_concrete_type dec_t infered_t fmt =
return something usefull *)
Types.new_var ()
in
- fprintf fmt "{ \"kind\": \"array\", \"base_type\": %t, \"dim\": %a }"
+ fprintf
+ fmt
+ "{ \"kind\": \"array\", \"base_type\": %t, \"dim\": %a }"
(pp_concrete_type e inf_base)
- pp_emf_dim dim
+ pp_emf_dim
+ dim
(* | _ -> eprintf
* "unhandled construct in type printing for EMF backend: %a@."
@@ -170,8 +183,11 @@ and pp_tag_type id typ inf fmt =
| Tydec_enum const_list ->
(* enum can be mapped to int *)
let size = List.length const_list in
- fprintf fmt "{ \"name\": \"%s\", \"kind\": \"enum\", \"size\": \"%i\" }"
- id size
+ fprintf
+ fmt
+ "{ \"name\": \"%s\", \"kind\": \"enum\", \"size\": \"%i\" }"
+ id
+ size
| Tydec_struct _ ->
fprintf fmt "{ \"name\": \"%s\", \"kind\": \"struct\" }" id
| Tydec_any ->
@@ -205,10 +221,15 @@ and pp_infered_type fmt t =
| Tlink ty ->
pp_infered_type fmt ty
| Tarray (dim, base_t) ->
- fprintf fmt "{ \"kind\": \"array\", \"base_type\": %a, \"dim\": %a }"
- pp_infered_type base_t pp_emf_dim dim
+ fprintf
+ fmt
+ "{ \"kind\": \"array\", \"base_type\": %a, \"dim\": %a }"
+ pp_infered_type
+ base_t
+ pp_emf_dim
+ dim
| _ ->
- eprintf "unhandled type: %a@." Types.print_node_ty t;
+ eprintf "unhandled type: %a@." Types.pp_node_ty t;
assert false
(*let pp_cst_type fmt v = match v.value_desc with | Cst c-> pp_cst_type c
@@ -237,9 +258,15 @@ let pp_emf_list ?(eol : ('a, formatter, unit) Stdlib.format = "") pp fmt l =
(* Print the variable declaration *)
let pp_emf_var_decl fmt v =
- fprintf fmt
+ fprintf
+ fmt
"@[{\"name\": \"%a\", \"datatype\": %a, \"original_name\": \"%a\"}@]"
- pp_var_name v pp_var_type v Printers.pp_var_name v
+ pp_var_name
+ v
+ pp_var_type
+ v
+ Printers.pp_var_name
+ v
let pp_emf_vars_decl = pp_emf_list pp_emf_var_decl
@@ -283,8 +310,11 @@ let pp_emf_cst c inf fmt =
fprintf fmt "@]}")
else (
fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ " pp_tag_id t;
- fprintf fmt "\"origin_type\": \"%s\",@ \"origin_value\": \"%s\",@ "
- typ.tydef_id t;
+ fprintf
+ fmt
+ "\"origin_type\": \"%s\",@ \"origin_value\": \"%s\",@ "
+ typ.tydef_id
+ t;
pp_typ fmt;
fprintf fmt "@]}")
| Const_string s ->
@@ -292,8 +322,11 @@ let pp_emf_cst c inf fmt =
pp_typ fmt;
fprintf fmt "@]}"
| _ ->
- fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ "
- Printers.pp_const c;
+ fprintf
+ fmt
+ "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ "
+ Printers.pp_const
+ c;
pp_typ fmt;
fprintf fmt "@]}"
@@ -308,19 +341,30 @@ let rec pp_emf_cst_or_var m fmt v =
fprintf fmt "\"datatype\": %a@ " pp_var_type v;
fprintf fmt "@]}"
| Array vl ->
- fprintf fmt "{@[\"type\": \"array\",@ \"value\": @[[%a@]]@ "
- (pp_emf_cst_or_var_list m) vl;
+ fprintf
+ fmt
+ "{@[\"type\": \"array\",@ \"value\": @[[%a@]]@ "
+ (pp_emf_cst_or_var_list m)
+ vl;
fprintf fmt "@]}"
| Access (arr, idx) ->
- fprintf fmt
+ fprintf
+ fmt
"{@[\"type\": \"array access\",@ \"array\": @[[%a@]],@ \"idx\": \
@[[%a@]]@ "
- (pp_emf_cst_or_var m) arr (pp_emf_cst_or_var m) idx;
+ (pp_emf_cst_or_var m)
+ arr
+ (pp_emf_cst_or_var m)
+ idx;
fprintf fmt "@]}"
| Power (v, nb) ->
- fprintf fmt
+ fprintf
+ fmt
"{@[\"type\": \"power\",@ \"expr\": @[[%a@]],@ \"nb\": @[[%a@]]@ "
- (pp_emf_cst_or_var m) v (pp_emf_cst_or_var m) nb;
+ (pp_emf_cst_or_var m)
+ v
+ (pp_emf_cst_or_var m)
+ nb;
fprintf fmt "@]}"
| Fun _ ->
eprintf "Fun expression should have been normalized: %a@." (pp_val m) v;
@@ -338,10 +382,16 @@ let rec pp_emf_expr fmt e =
| Expr_const c ->
pp_emf_cst c e.expr_type fmt
| Expr_ident id ->
- fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ " print_protect
+ fprintf
+ fmt
+ "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ "
+ pp_protect
(fun fmt -> pp_print_string fmt id);
- fprintf fmt "\"datatype\": %t@ "
- (pp_concrete_type Tydec_any
+ fprintf
+ fmt
+ "\"datatype\": %t@ "
+ (pp_concrete_type
+ Tydec_any
(* don't know much about that time since it was not declared. That may
not work with clock constants *)
e.expr_type);
@@ -355,8 +405,11 @@ let rec pp_emf_expr fmt e =
expr) list | Expr_appl of call_t *)
| _ ->
Log.report ~level:2 (fun fmt ->
- fprintf fmt "Warning: unhandled expression %a in annotation.@ "
- Printers.pp_expr e;
+ fprintf
+ fmt
+ "Warning: unhandled expression %a in annotation.@ "
+ Printers.pp_expr
+ e;
fprintf fmt "Will not be produced in the experted JSON EMF@.");
fprintf fmt "\"unhandled construct, complain to Ploc\""
@@ -386,7 +439,9 @@ let rec pp_emf_expr fmt e =
* let pp_emf_consts = pp_emf_list pp_emf_const *)
let pp_emf_eexpr fmt ee =
- fprintf fmt "{@[<hov 0>%t\"quantifiers\": \"%a\",@ \"qfexpr\": @[%a@]@] }"
+ fprintf
+ fmt
+ "{@[<hov 0>%t\"quantifiers\": \"%a\",@ \"qfexpr\": @[%a@]@] }"
(fun fmt ->
match ee.eexpr_name with
| None ->
@@ -394,7 +449,9 @@ let pp_emf_eexpr fmt ee =
| Some name ->
Format.fprintf fmt "\"name\": \"%s\",@ " name)
(pp_print_list ~pp_sep:pp_print_semicolon Printers.pp_quantifiers)
- ee.eexpr_quantifiers pp_emf_expr ee.eexpr_qfexpr
+ ee.eexpr_quantifiers
+ pp_emf_expr
+ ee.eexpr_qfexpr
let pp_emf_eexprs = pp_emf_list pp_emf_eexpr
@@ -438,27 +495,43 @@ let rec pp_emf_typ_dec fmt tydef_dec =
| Tydec_const c ->
fprintf fmt "\"kind\": \"alias\",@ \"value\": \"%s\"" c
| Tydec_enum el ->
- fprintf fmt "\"kind\": \"enum\",@ \"elements\": [%a]"
+ fprintf
+ fmt
+ "\"kind\": \"enum\",@ \"elements\": [%a]"
(pp_comma_list (fun fmt e -> fprintf fmt "\"%s\"" e))
el
| Tydec_struct s ->
- fprintf fmt "\"kind\": \"struct\",@ \"fields\": [%a]"
+ fprintf
+ fmt
+ "\"kind\": \"struct\",@ \"fields\": [%a]"
(pp_comma_list (fun fmt (id, typ) ->
fprintf fmt "\"%s\": %a" id pp_emf_typ_dec typ))
s
| Tydec_array (dim, typ) ->
- fprintf fmt "\"kind\": \"array\",@ \"dim\": @[%a@],@ \"base\": %a"
- pp_emf_dim dim pp_emf_typ_dec typ);
+ fprintf
+ fmt
+ "\"kind\": \"array\",@ \"dim\": @[%a@],@ \"base\": %a"
+ pp_emf_dim
+ dim
+ pp_emf_typ_dec
+ typ);
fprintf fmt "}"
let pp_emf_typedef fmt typdef_top =
let typedef = Corelang.typedef_of_top typdef_top in
- fprintf fmt "{ \"%s\": @[%a@] }" typedef.tydef_id pp_emf_typ_dec
+ fprintf
+ fmt
+ "{ \"%s\": @[%a@] }"
+ typedef.tydef_id
+ pp_emf_typ_dec
typedef.tydef_desc
let pp_emf_top_const fmt const_top =
let const = Corelang.const_of_top const_top in
- fprintf fmt "{ \"%s\": %t }" const.const_id
+ fprintf
+ fmt
+ "{ \"%s\": %t }"
+ const.const_id
(pp_emf_cst const.const_value const.const_type)
(* Local Variables: *)
diff --git a/src/backends/EMF/EMF_common.mli b/src/backends/EMF/EMF_common.mli
index e1d7b4e6..e8ecbb75 100644
--- a/src/backends/EMF/EMF_common.mli
+++ b/src/backends/EMF/EMF_common.mli
@@ -9,7 +9,7 @@ val pp_emf_cst_or_var : machine_t -> formatter -> value_t -> unit
val pp_var_name : formatter -> var_decl -> unit
-val print_protect : formatter -> (formatter -> unit) -> unit
+val pp_protect : formatter -> (formatter -> unit) -> unit
val pp_var_string : formatter -> ident -> unit
diff --git a/src/backends/EMF/EMF_library_calls.ml b/src/backends/EMF/EMF_library_calls.ml
index ab77f057..355152a7 100644
--- a/src/backends/EMF/EMF_library_calls.ml
+++ b/src/backends/EMF/EMF_library_calls.ml
@@ -15,15 +15,22 @@ let pp_call fmt m f outputs inputs =
let inode = Corelang.imported_node_of_top decl in
match inode.nodei_id, Filename.basename decl.top_decl_owner with
| name, (("lustrec_math" | "simulink_math_fcn" | "conv") as lib) ->
- fprintf fmt
+ fprintf
+ fmt
"\"kind\": \"functioncall\",@ \"name\": \"%s\",@ \"library\": \"%s\",@ "
- name lib;
- fprintf fmt "\"lhs\": [@[%a@]],@ \"args\": [@[%a@]]"
+ name
+ lib;
+ fprintf
+ fmt
+ "\"lhs\": [@[%a@]],@ \"args\": [@[%a@]]"
(pp_comma_list (fun fmt v ->
fprintf fmt "\"%a\"" Printers.pp_var_name v))
- outputs (pp_emf_cst_or_var_list m) inputs
+ outputs
+ (pp_emf_cst_or_var_list m)
+ inputs
| _ ->
- Format.eprintf "Calls to function %s in library %s are not handled yet.@."
+ Format.eprintf
+ "Calls to function %s in library %s are not handled yet.@."
inode.nodei_id
(Filename.basename decl.top_decl_owner);
assert false)
diff --git a/src/backends/Horn/horn_backend.ml b/src/backends/Horn/horn_backend.ml
index d596f801..b143dc28 100644
--- a/src/backends/Horn/horn_backend.ml
+++ b/src/backends/Horn/horn_backend.ml
@@ -58,7 +58,10 @@ let print_type_definitions fmt =
match tdef.tydef_desc with
| Tydec_enum tl ->
incr cpt_type;
- fprintf fmt "(declare-datatypes () ((%s %a)));@.@." var
+ fprintf
+ fmt
+ "(declare-datatypes () ((%s %a)));@.@."
+ var
(pp_print_list pp_print_string)
tl
| _ ->
@@ -118,7 +121,8 @@ let preprocess machines =
}
:: res
else m :: res)
- machines []
+ machines
+ []
let translate fmt prog machines =
let machines = preprocess machines in
diff --git a/src/backends/Horn/horn_backend_collecting_sem.ml b/src/backends/Horn/horn_backend_collecting_sem.ml
index 570afe0a..d8aa8e7c 100644
--- a/src/backends/Horn/horn_backend_collecting_sem.ml
+++ b/src/backends/Horn/horn_backend_collecting_sem.ml
@@ -45,7 +45,10 @@ let collecting_semantics machines fmt node machine =
@ main_output_dummy
in
- fprintf fmt "(declare-rel MAIN (%a))@." (pp_print_list pp_type)
+ fprintf
+ fmt
+ "(declare-rel MAIN (%a))@."
+ (pp_print_list pp_type)
(List.map (fun v -> v.var_type) main_memory_next);
(* Init case *)
@@ -58,11 +61,17 @@ let collecting_semantics machines fmt node machine =
fprintf fmt "(rule INIT_STATE)@.";
fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>";
fprintf fmt "INIT_STATE@ ";
- fprintf fmt "(@[<v 0>%a %a@])" step_name node
+ fprintf
+ fmt
+ "(@[<v 0>%a %a@])"
+ step_name
+ node
(pp_print_list (pp_horn_var machine))
(step_vars_m_x machines machine);
fprintf fmt "@]@ )@ ";
- fprintf fmt "(MAIN %a)@]@.))@.@."
+ fprintf
+ fmt
+ "(MAIN %a)@]@.))@.@."
(pp_print_list (pp_horn_var machine))
main_memory_next)
else
@@ -72,15 +81,25 @@ let collecting_semantics machines fmt node machine =
fprintf fmt "(rule INIT_STATE)@.";
fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>";
fprintf fmt "INIT_STATE@ ";
- fprintf fmt "(@[<v 0>%a %a@])@ " reset_name node
+ fprintf
+ fmt
+ "(@[<v 0>%a %a@])@ "
+ reset_name
+ node
(pp_print_list (pp_horn_var machine))
(reset_vars machines machine);
- fprintf fmt "(@[<v 0>%a %a@])" step_name node
+ fprintf
+ fmt
+ "(@[<v 0>%a %a@])"
+ step_name
+ node
(pp_print_list (pp_horn_var machine))
(step_vars_m_x machines machine);
fprintf fmt "@]@ )@ ";
- fprintf fmt "(MAIN %a)@]@.))@.@."
+ fprintf
+ fmt
+ "(MAIN %a)@]@.))@.@."
(pp_print_list (pp_horn_var machine))
main_memory_next
in
@@ -92,12 +111,16 @@ let collecting_semantics machines fmt node machine =
fprintf fmt "; Inductive def@.";
(pp_print_list (fun fmt v -> fprintf fmt "%a@." pp_decl_var v))
- fmt main_output_dummy;
- fprintf fmt
+ fmt
+ main_output_dummy;
+ fprintf
+ fmt
"@[<v 2>(rule (=> @ (and @[<v 0>(MAIN %a)@ (@[<v 0>%a %a@])@]@ )@ (MAIN \
%a)@]@.))@.@."
(pp_print_list (pp_horn_var machine))
- main_memory_current step_name node
+ main_memory_current
+ step_name
+ node
(pp_print_list (pp_horn_var machine))
(step_vars machines machine)
(pp_print_list (pp_horn_var machine))
@@ -112,7 +135,9 @@ let check_prop machines fmt machine =
in
fprintf fmt "; Property def@.";
fprintf fmt "(declare-rel ERR ())@.";
- fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>(not %a)@ (MAIN %a)@])@ ERR))@."
+ fprintf
+ fmt
+ "@[<v 2>(rule (=> @ (and @[<v 0>(not %a)@ (MAIN %a)@])@ ERR))@."
(pp_conj (pp_horn_var machine))
main_output
(pp_print_list (pp_horn_var machine))
@@ -156,7 +181,10 @@ let cex_computation machines fmt node machine =
else pp_machine_reset_name, pp_machine_step_name
in
- fprintf fmt "(declare-rel CEX (Int %a))@.@." (pp_print_list pp_type)
+ fprintf
+ fmt
+ "(declare-rel CEX (Int %a))@.@."
+ (pp_print_list pp_type)
(List.map (fun v -> v.var_type) cex_memory_next);
fprintf fmt "; Initial set: Reset(c,m) + One Step(m,x) @.";
@@ -164,15 +192,25 @@ let cex_computation machines fmt node machine =
fprintf fmt "(rule INIT_STATE_CEX)@.";
fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>";
fprintf fmt "INIT_STATE_CEX@ ";
- fprintf fmt "(@[<v 0>%a %a@])@ " reset_name node
+ fprintf
+ fmt
+ "(@[<v 0>%a %a@])@ "
+ reset_name
+ node
(pp_print_list (pp_horn_var machine))
(reset_vars machines machine);
- fprintf fmt "(@[<v 0>%a %a@])" step_name node
+ fprintf
+ fmt
+ "(@[<v 0>%a %a@])"
+ step_name
+ node
(pp_print_list (pp_horn_var machine))
(step_vars_m_x machines machine);
fprintf fmt "@]@ )@ ";
- fprintf fmt "(CEX 0 %a)@]@.))@.@."
+ fprintf
+ fmt
+ "(CEX 0 %a)@]@.))@.@."
(pp_print_list (pp_horn_var machine))
cex_memory_next;
@@ -180,13 +218,17 @@ let cex_computation machines fmt node machine =
(* Declare dummy inputs. Outputs should have been declared previously with
collecting sem *)
(pp_print_list (fun fmt v -> fprintf fmt "%a@." pp_decl_var v))
- fmt cex_input_dummy;
+ fmt
+ cex_input_dummy;
fprintf fmt "(declare-var cexcpt Int)@.";
- fprintf fmt
+ fprintf
+ fmt
"@[<v 2>(rule (=> @ (and @[<v 0>(CEX cexcpt %a)@ (@[<v 0>%a %a@])@]@ )@ \
(CEX (+ 1 cexcpt) %a)@]@.))@.@."
(pp_print_list (pp_horn_var machine))
- cex_memory_current step_name node
+ cex_memory_current
+ step_name
+ node
(pp_print_list (pp_horn_var machine))
(step_vars machines machine)
(pp_print_list (pp_horn_var machine))
@@ -206,7 +248,8 @@ let get_cex machines fmt machine =
in
fprintf fmt "; Property def@.";
fprintf fmt "(declare-rel CEXTRACE ())@.";
- fprintf fmt
+ fprintf
+ fmt
"@[<v 2>(rule (=> @ (and @[<v 0>(not %a)@ (CEX cexcpt %a)@])@ CEXTRACE))@."
(pp_conj (pp_horn_var machine))
cex_output
diff --git a/src/backends/Horn/horn_backend_common.ml b/src/backends/Horn/horn_backend_common.ml
index a5bec90d..f2107000 100644
--- a/src/backends/Horn/horn_backend_common.ml
+++ b/src/backends/Horn/horn_backend_common.ml
@@ -49,7 +49,7 @@ let rec pp_type fmt t =
| Types.Tstatic (_, ty) ->
pp_type fmt ty
| Types.Tarrow _ | _ ->
- eprintf "internal error: pp_type %a@." Types.print_ty t;
+ eprintf "internal error: pp_type %a@." Types.pp t;
assert false
let pp_decl_var fmt id =
@@ -111,11 +111,13 @@ let instances_memory_vars ?(without_arrow = false) machines machine =
if without_arrow && name = "_arrow" then accu
else
let machine_n = get_machine machines name in
- aux false
+ aux
+ false
(concat prefix (if fst then id else concat m.mname.node_id id))
machine_n
@ accu)
- [] m.minstances
+ []
+ m.minstances
in
aux true machine.mname.node_id machine
@@ -128,17 +130,20 @@ let arrow_vars machines machine : Lustre_types.var_decl list =
if name = "_arrow" then
let arrow_machine = Machine_code_common.arrow_machine in
rename_machine_list
- (concat prefix
+ (concat
+ prefix
(concat (if fst then id else concat m.mname.node_id id) "_arrow"))
arrow_machine.mmemory
@ accu
else
let machine_n = get_machine machines name in
- aux false
+ aux
+ false
(concat prefix (if fst then id else concat m.mname.node_id id))
machine_n
@ accu)
- [] m.minstances
+ []
+ m.minstances
in
aux true machine.mname.node_id machine
diff --git a/src/backends/Horn/horn_backend_printers.ml b/src/backends/Horn/horn_backend_printers.ml
index 8911c454..eb758888 100644
--- a/src/backends/Horn/horn_backend_printers.ml
+++ b/src/backends/Horn/horn_backend_printers.ml
@@ -33,7 +33,8 @@ let pp_horn_var _ fmt id =
(* Used to print boolean constants *)
let pp_horn_tag fmt t =
- pp_print_string fmt
+ pp_print_string
+ fmt
(if t = tag_true then "true" else if t = tag_false then "false" else t)
(* Prints a constant value *)
@@ -61,7 +62,12 @@ let rec pp_default_val fmt t =
| Types.Tarray _ ->
(* TODO PL: this strange code has to be (heavily) checked *)
let valt = Types.array_element_type t in
- fprintf fmt "((as const (Array Int %a)) %a)" pp_type valt pp_default_val
+ fprintf
+ fmt
+ "((as const (Array Int %a)) %a)"
+ pp_type
+ valt
+ pp_default_val
valt
| Types.Tstruct _ ->
assert false
@@ -74,23 +80,48 @@ let pp_mod pp_val v1 v2 fmt =
if Types.is_int_type v1.value_type && not !Options.integer_div_euclidean then
(* C semantics: converting it from Euclidean operators (a mod_M b) - ((a
mod_M b > 0 && a < 0) ? abs(b) : 0) *)
- Format.fprintf fmt
- "(- (mod %a %a) (ite (and (> (mod %a %a) 0) (< %a 0)) (abs %a) 0))" pp_val
- v1 pp_val v2 pp_val v1 pp_val v2 pp_val v1 pp_val v2
+ Format.fprintf
+ fmt
+ "(- (mod %a %a) (ite (and (> (mod %a %a) 0) (< %a 0)) (abs %a) 0))"
+ pp_val
+ v1
+ pp_val
+ v2
+ pp_val
+ v1
+ pp_val
+ v2
+ pp_val
+ v1
+ pp_val
+ v2
else Format.fprintf fmt "(mod %a %a)" pp_val v1 pp_val v2
let pp_div pp_val v1 v2 fmt =
if Types.is_int_type v1.value_type && not !Options.integer_div_euclidean then
(* C semantics: converting it from Euclidean operators (a - (a mod_C b))
div_M b *)
- Format.fprintf fmt "(div (- %a %t) %a)" pp_val v1 (pp_mod pp_val v1 v2)
- pp_val v2
+ Format.fprintf
+ fmt
+ "(div (- %a %t) %a)"
+ pp_val
+ v1
+ (pp_mod pp_val v1 v2)
+ pp_val
+ v2
else Format.fprintf fmt "(div %a %a)" pp_val v1 pp_val v2
let pp_basic_lib_fun i pp_val fmt vl =
match i, vl with
| "ite", [ v1; v2; v3 ] ->
- Format.fprintf fmt "(@[<hov 2>ite %a@ %a@ %a@])" pp_val v1 pp_val v2 pp_val
+ Format.fprintf
+ fmt
+ "(@[<hov 2>ite %a@ %a@ %a@])"
+ pp_val
+ v1
+ pp_val
+ v2
+ pp_val
v3
| "uminus", [ v ] ->
Format.fprintf fmt "(- %a)" pp_val v
@@ -137,7 +168,10 @@ let rec pp_horn_val ?(is_lhs = false) m self pp_var fmt v =
| [] ->
pp_default_val fmt v.value_type (* (get_type v) *)
| h :: t ->
- fprintf fmt "(store %a %i %a)" print
+ fprintf
+ fmt
+ "(store %a %i %a)"
+ print
(t, x + 1)
x
(pp_horn_val ~is_lhs m self pp_var)
@@ -145,7 +179,9 @@ let rec pp_horn_val ?(is_lhs = false) m self pp_var fmt v =
in
print fmt (il, 0)
| Access (tab, index) ->
- fprintf fmt "(select %a %a)"
+ fprintf
+ fmt
+ "(select %a %a)"
(pp_horn_val ~is_lhs m self pp_var)
tab
(pp_horn_val ~is_lhs m self pp_var)
@@ -157,8 +193,10 @@ let rec pp_horn_val ?(is_lhs = false) m self pp_var fmt v =
if is_memory m v then
if Types.is_array_type v.var_type then assert false
else
- pp_var fmt
- (rename_machine self
+ pp_var
+ fmt
+ (rename_machine
+ self
((if is_lhs then rename_next else rename_current (* self *)) v))
else pp_var fmt (rename_machine self v)
| Fun (n, vl) ->
@@ -180,7 +218,9 @@ let rec pp_value_suffix m self pp_value fmt value =
[value]: assigned value - [pp_var]: printer for variables *)
let pp_assign m pp_var fmt var_name value =
let self = m.mname.node_id in
- fprintf fmt "(= %a %a)"
+ fprintf
+ fmt
+ "(= %a %a)"
(pp_horn_val ~is_lhs:true m self pp_var)
var_name
(pp_value_suffix m self pp_var)
@@ -194,11 +234,13 @@ let pp_no_reset machines m fmt i =
in
let m_list =
- rename_machine_list (concat m.mname.node_id i)
+ rename_machine_list
+ (concat m.mname.node_id i)
(rename_mid_list (full_memory_vars machines target_machine))
in
let c_list =
- rename_machine_list (concat m.mname.node_id i)
+ rename_machine_list
+ (concat m.mname.node_id i)
(rename_current_list (full_memory_vars machines target_machine))
in
match c_list, m_list with
@@ -209,7 +251,8 @@ let pp_no_reset machines m fmt i =
List.iter2
(fun mhd chd ->
fprintf fmt "(= %a %a)@ " (pp_horn_var m) mhd (pp_horn_var m) chd)
- m_list c_list;
+ m_list
+ c_list;
fprintf fmt ")@]@ @]"
let pp_instance_reset machines m fmt i =
@@ -218,11 +261,17 @@ let pp_instance_reset machines m fmt i =
List.find (fun m -> m.mname.node_id = node_name n) machines
in
- fprintf fmt "(%a @[<v 0>%a)@]" pp_machine_reset_name (node_name n)
+ fprintf
+ fmt
+ "(%a @[<v 0>%a)@]"
+ pp_machine_reset_name
+ (node_name n)
(pp_print_list (pp_horn_var m))
- (rename_machine_list (concat m.mname.node_id i)
+ (rename_machine_list
+ (concat m.mname.node_id i)
(rename_current_list (full_memory_vars machines target_machine))
- @ rename_machine_list (concat m.mname.node_id i)
+ @ rename_machine_list
+ (concat m.mname.node_id i)
(rename_mid_list (full_memory_vars machines target_machine)))
let pp_instance_call machines reset_instances m fmt i inputs outputs =
@@ -248,7 +297,9 @@ let pp_instance_call machines reset_instances m fmt i inputs outputs =
match node_name n, inputs, outputs, mid_mems, next_mems with
| "_arrow", [ i1; i2 ], [ o ], [ mem_m ], [ mem_x ] ->
fprintf fmt "@[<v 5>(and ";
- fprintf fmt "(= %a (ite %a %a %a))"
+ fprintf
+ fmt
+ "(= %a (ite %a %a %a))"
(pp_horn_val ~is_lhs:true m self (pp_horn_var m))
(mk_val (Var o) o.var_type)
(* output var *)
@@ -262,11 +313,17 @@ let pp_instance_call machines reset_instances m fmt i inputs outputs =
fprintf fmt "(= %a false)" (pp_horn_var m) mem_x;
fprintf fmt ")@]"
| _ ->
- fprintf fmt "(%a @[<v 0>%a%a%a)@]" pp_machine_step_name (node_name n)
- (pp_print_list ~pp_epilogue:pp_print_cut
+ fprintf
+ fmt
+ "(%a @[<v 0>%a%a%a)@]"
+ pp_machine_step_name
+ (node_name n)
+ (pp_print_list
+ ~pp_epilogue:pp_print_cut
(pp_horn_val m self (pp_horn_var m)))
inputs
- (pp_print_list ~pp_epilogue:pp_print_cut
+ (pp_print_list
+ ~pp_epilogue:pp_print_cut
(pp_horn_val m self (pp_horn_var m)))
(List.map (fun v -> mk_val (Var v) v.var_type) outputs)
(pp_print_list (pp_horn_var m))
@@ -274,8 +331,13 @@ let pp_instance_call machines reset_instances m fmt i inputs outputs =
with Not_found ->
(* stateless node instance *)
let n, _ = List.assoc i m.mcalls in
- fprintf fmt "(%a @[<v 0>%a%a)@]" pp_machine_stateless_name (node_name n)
- (pp_print_list ~pp_epilogue:pp_print_cut
+ fprintf
+ fmt
+ "(%a @[<v 0>%a%a)@]"
+ pp_machine_stateless_name
+ (node_name n)
+ (pp_print_list
+ ~pp_epilogue:pp_print_cut
(pp_horn_val m self (pp_horn_var m)))
inputs
(pp_print_list (pp_horn_val m self (pp_horn_var m)))
@@ -328,13 +390,17 @@ let rec pp_machine_instr machines reset_instances (m : machine_t) fmt instr :
of the branch, then all others have to have the mem_m = mem_c statement. *)
let self = m.mname.node_id in
let pp_branch fmt (tag, instrs) =
- fprintf fmt "@[<v 3>(or (not (= %a %a))@ "
+ fprintf
+ fmt
+ "@[<v 3>(or (not (= %a %a))@ "
(*"@[<v 3>(=> (= %a %s)@ "*)
(* Issues with some versions of Z3. It seems that => within Horn
predicate may cause trouble. I have hard time producing a MWE, so
I'll just keep the fix here as (not a) or b *)
(pp_horn_val m self (pp_horn_var m))
- g pp_horn_tag tag;
+ g
+ pp_horn_tag
+ tag;
let _ (* rs *) =
pp_machine_instrs machines reset_instances m fmt instrs
in
@@ -358,7 +424,8 @@ and pp_machine_instrs machines reset_instances m fmt instrs =
let rs = ppi rs fmt i in
fprintf fmt "@ ";
rs)
- reset_instances instrs
+ reset_instances
+ instrs
in
fprintf fmt "@])";
rs
@@ -372,9 +439,15 @@ let pp_machine_reset machines fmt m =
(* print "x_m = x_c" for each local memory *)
(pp_print_list (fun fmt v ->
- fprintf fmt "(= %a %a)" (pp_horn_var m) (rename_mid v) (pp_horn_var m)
+ fprintf
+ fmt
+ "(= %a %a)"
+ (pp_horn_var m)
+ (rename_mid v)
+ (pp_horn_var m)
(rename_current v)))
- fmt locals;
+ fmt
+ locals;
fprintf fmt "@ ";
(* print "child_reset ( associated vars _ {c,m} )" for each subnode. Special
@@ -385,12 +458,16 @@ let pp_machine_reset machines fmt m =
fprintf fmt "(= %s._arrow._first_m true)" (concat m.mname.node_id id)
else
let machine_n = get_machine machines name in
- fprintf fmt "(%s_reset @[<hov 0>%a@])" name
+ fprintf
+ fmt
+ "(%s_reset @[<hov 0>%a@])"
+ name
(pp_print_list (pp_horn_var m))
(rename_machine_list
(concat m.mname.node_id id)
(reset_vars machines machine_n))))
- fmt m.minstances;
+ fmt
+ m.minstances;
fprintf fmt "@]@ )"
@@ -406,7 +483,10 @@ let print_machine machines fmt m =
fprintf fmt "; %s@." m.mname.node_id;
(* Printing variables *)
- pp_print_list ~pp_open_box:pp_open_vbox0 pp_decl_var fmt
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ pp_decl_var
+ fmt
(inout_vars m
@ rename_current_list (full_memory_vars machines m)
@ rename_mid_list (full_memory_vars machines m)
@@ -416,8 +496,12 @@ let print_machine machines fmt m =
if is_stateless m then (
(* Declaring single predicate *)
- fprintf fmt "(declare-rel %a (%a))@." pp_machine_stateless_name
- m.mname.node_id (pp_print_list pp_type)
+ fprintf
+ fmt
+ "(declare-rel %a (%a))@."
+ pp_machine_stateless_name
+ m.mname.node_id
+ (pp_print_list pp_type)
(List.map (fun v -> v.var_type) (inout_vars m));
match m.mstep.step_asserts with
@@ -426,9 +510,16 @@ let print_machine machines fmt m =
fprintf fmt "; Stateless step rule @.";
fprintf fmt "@[<v 2>(rule (=> @ ";
ignore
- (pp_machine_instrs machines []
- (* No reset info for stateless nodes *) m fmt m.mstep.step_instrs);
- fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@." pp_machine_stateless_name
+ (pp_machine_instrs
+ machines
+ []
+ (* No reset info for stateless nodes *) m
+ fmt
+ m.mstep.step_instrs);
+ fprintf
+ fmt
+ "@ (%a @[<v 0>%a)@]@]@.))@.@."
+ pp_machine_stateless_name
m.mname.node_id
(pp_print_list (pp_horn_var m))
(inout_vars m)
@@ -441,26 +532,43 @@ let print_machine machines fmt m =
(*Rule for step*)
fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@. %a)@ (%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val)
- assertsl pp_machine_stateless_name m.mname.node_id
+ fprintf
+ fmt
+ "@. %a)@ (%a @[<v 0>%a)@]@]@.))@.@."
+ (pp_conj pp_val)
+ assertsl
+ pp_machine_stateless_name
+ m.mname.node_id
(pp_print_list (pp_horn_var m))
(step_vars machines m))
else (
(* Declaring predicate *)
- fprintf fmt "(declare-rel %a (%a))@." pp_machine_reset_name
- m.mname.node_id (pp_print_list pp_type)
+ fprintf
+ fmt
+ "(declare-rel %a (%a))@."
+ pp_machine_reset_name
+ m.mname.node_id
+ (pp_print_list pp_type)
(List.map (fun v -> v.var_type) (reset_vars machines m));
- fprintf fmt "(declare-rel %a (%a))@." pp_machine_step_name m.mname.node_id
+ fprintf
+ fmt
+ "(declare-rel %a (%a))@."
+ pp_machine_step_name
+ m.mname.node_id
(pp_print_list pp_type)
(List.map (fun v -> v.var_type) (step_vars machines m));
pp_print_newline fmt ();
(* Rule for reset *)
- fprintf fmt "@[<v 2>(rule (=> @ %a@ (%a @[<v 0>%a)@]@]@.))@.@."
+ fprintf
+ fmt
+ "@[<v 2>(rule (=> @ %a@ (%a @[<v 0>%a)@]@]@.))@.@."
(pp_machine_reset machines)
- m pp_machine_reset_name m.mname.node_id
+ m
+ pp_machine_reset_name
+ m.mname.node_id
(pp_print_list (pp_horn_var m))
(reset_vars machines m);
@@ -470,7 +578,10 @@ let print_machine machines fmt m =
(* Rule for step*)
fprintf fmt "@[<v 2>(rule (=> @ ";
ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@." pp_machine_step_name
+ fprintf
+ fmt
+ "@ (%a @[<v 0>%a)@]@]@.))@.@."
+ pp_machine_step_name
m.mname.node_id
(pp_print_list (pp_horn_var m))
(step_vars machines m)
@@ -484,8 +595,13 @@ let print_machine machines fmt m =
(*Rule for step*)
fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@. %a)@ (%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val)
- assertsl pp_machine_step_name m.mname.node_id
+ fprintf
+ fmt
+ "@. %a)@ (%a @[<v 0>%a)@]@]@.))@.@."
+ (pp_conj pp_val)
+ assertsl
+ pp_machine_step_name
+ m.mname.node_id
(pp_print_list (pp_horn_var m))
(step_vars machines m)))
@@ -510,7 +626,11 @@ let get_sf_info () =
in
Log.report ~level:1 (fun fmt ->
- fprintf fmt "... sf_name: %s@, .. flags: %s@ .. arity: %s@," sf_name flags
+ fprintf
+ fmt
+ "... sf_name: %s@, .. flags: %s@ .. arity: %s@,"
+ sf_name
+ flags
arity);
sf_name, flags, arity
@@ -525,12 +645,17 @@ let print_sfunction machines fmt m =
(* Check if there is annotation for s-function *)
if m.mannot != [] then
- Format.fprintf fmt "; @[%a@]@]@\n"
+ Format.fprintf
+ fmt
+ "; @[%a@]@]@\n"
(pp_print_list Printers.pp_s_function)
m.mannot;
(* Printing variables *)
- pp_print_list ~pp_open_box:pp_open_vbox0 pp_decl_var fmt
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ pp_decl_var
+ fmt
(step_vars machines m
@ rename_machine_list m.mname.node_id m.mstep.step_locals);
Format.pp_print_newline fmt ();
@@ -538,26 +663,42 @@ let print_sfunction machines fmt m =
if is_stateless m then (
(* Declaring single predicate *)
- Format.fprintf fmt "(declare-rel %a (%a))@." pp_machine_stateless_name
- m.mname.node_id (pp_print_list pp_type)
+ Format.fprintf
+ fmt
+ "(declare-rel %a (%a))@."
+ pp_machine_stateless_name
+ m.mname.node_id
+ (pp_print_list pp_type)
(List.map (fun v -> v.var_type) (reset_vars machines m));
Format.pp_print_newline fmt ();
(* Rule for single predicate *)
let str_flags = sf_name ^ " " ^ mk_flags (int_of_string flags) in
- Format.fprintf fmt "@[<v 2>(rule (=> @ (%s %a) (%a %a)@]@.))@.@."
+ Format.fprintf
+ fmt
+ "@[<v 2>(rule (=> @ (%s %a) (%a %a)@]@.))@.@."
str_flags
(pp_print_list (pp_horn_var m))
- (reset_vars machines m) pp_machine_stateless_name m.mname.node_id
+ (reset_vars machines m)
+ pp_machine_stateless_name
+ m.mname.node_id
(pp_print_list (pp_horn_var m))
(reset_vars machines m))
else (
(* Declaring predicate *)
- Format.fprintf fmt "(declare-rel %a (%a))@." pp_machine_reset_name
- m.mname.node_id (pp_print_list pp_type)
+ Format.fprintf
+ fmt
+ "(declare-rel %a (%a))@."
+ pp_machine_reset_name
+ m.mname.node_id
+ (pp_print_list pp_type)
(List.map (fun v -> v.var_type) (inout_vars m));
- Format.fprintf fmt "(declare-rel %a (%a))@." pp_machine_step_name
- m.mname.node_id (pp_print_list pp_type)
+ Format.fprintf
+ fmt
+ "(declare-rel %a (%a))@."
+ pp_machine_step_name
+ m.mname.node_id
+ (pp_print_list pp_type)
(List.map (fun v -> v.var_type) (step_vars machines m));
Format.pp_print_newline fmt ();
@@ -567,7 +708,10 @@ let print_sfunction machines fmt m =
(* Rule for step*)
fprintf fmt "@[<v 2>(rule (=> @ ";
ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@." pp_machine_step_name
+ fprintf
+ fmt
+ "@ (%a @[<v 0>%a)@]@]@.))@.@."
+ pp_machine_step_name
m.mname.node_id
(pp_print_list (pp_horn_var m))
(step_vars machines m)
@@ -581,8 +725,13 @@ let print_sfunction machines fmt m =
(*Rule for step*)
fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@. %a)(%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val) assertsl
- pp_machine_step_name m.mname.node_id
+ fprintf
+ fmt
+ "@. %a)(%a @[<v 0>%a)@]@]@.))@.@."
+ (pp_conj pp_val)
+ assertsl
+ pp_machine_step_name
+ m.mname.node_id
(pp_print_list (pp_horn_var m))
(step_vars machines m)))
@@ -593,7 +742,8 @@ let rec pp_xml_expr fmt expr =
| None ->
fprintf fmt "%t"
| Some ann ->
- fprintf fmt "@[(%a %t)@]" pp_xml_expr_annot ann) (fun fmt ->
+ fprintf fmt "@[(%a %t)@]" pp_xml_expr_annot ann)
+ (fun fmt ->
match expr.expr_desc with
| Expr_const c ->
Printers.pp_const fmt c
@@ -608,9 +758,15 @@ let rec pp_xml_expr fmt expr =
| Expr_tuple el ->
fprintf fmt "(%a)" pp_xml_tuple el
| Expr_ite (c, t, e) ->
- fprintf fmt
+ fprintf
+ fmt
"@[<hov 1>(if %a then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@])"
- pp_xml_expr c pp_xml_expr t pp_xml_expr e
+ pp_xml_expr
+ c
+ pp_xml_expr
+ t
+ pp_xml_expr
+ e
| Expr_arrow (e1, e2) ->
fprintf fmt "(%a -> %a)" pp_xml_expr e1 pp_xml_expr e2
| Expr_fby (e1, e2) ->
@@ -679,12 +835,15 @@ and pp_xml_call fmt id e =
fprintf fmt "%s (%a)" id pp_xml_expr e
and pp_xml_eexpr fmt e =
- fprintf fmt "%a%t %a"
+ fprintf
+ fmt
+ "%a%t %a"
(pp_print_list ~pp_sep:pp_print_semicolon Printers.pp_quantifiers)
e.eexpr_quantifiers
(fun fmt ->
match e.eexpr_quantifiers with [] -> () | _ -> fprintf fmt ";")
- pp_xml_expr e.eexpr_qfexpr
+ pp_xml_expr
+ e.eexpr_qfexpr
(* XXX: UNUSED *)
(* and pp_xml_sf_value fmt e =
@@ -714,7 +873,9 @@ and pp_xml_eexpr fmt e =
* pp_print_list pp_xml_annot fmt expr_ann.annots *)
and pp_xml_expr_annot fmt expr_ann =
let pp_xml_annot fmt (kwds, ee) =
- Format.fprintf fmt "(*! %t: %a; *)"
+ Format.fprintf
+ fmt
+ "(*! %t: %a; *)"
(fun fmt ->
match kwds with
| [] ->
@@ -722,12 +883,15 @@ and pp_xml_expr_annot fmt expr_ann =
| [ x ] ->
Format.pp_print_string fmt x
| _ ->
- Format.fprintf fmt "/%a/"
+ Format.fprintf
+ fmt
+ "/%a/"
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt "/")
pp_print_string)
kwds)
- pp_xml_eexpr ee
+ pp_xml_eexpr
+ ee
in
pp_print_list pp_xml_annot fmt expr_ann.annots
diff --git a/src/backends/Horn/horn_backend_traces.ml b/src/backends/Horn/horn_backend_traces.ml
index df4695ee..877c8177 100644
--- a/src/backends/Horn/horn_backend_traces.ml
+++ b/src/backends/Horn/horn_backend_traces.ml
@@ -37,7 +37,8 @@ let compute_mems machines m =
else
let machine_n = get_machine machines name in
aux ((id, machine_n) :: prefix) machine_n @ accu)
- [] m.minstances
+ []
+ m.minstances
in
aux [] m
@@ -117,8 +118,11 @@ let memories_next machines m =
false)
m.mname.node_stmts
with _ ->
- eprintf "Unable to find definition of %s in stmts %a@.prefix=%a@.@?"
- var_id Printers.pp_node_stmts m.mname.node_stmts
+ eprintf
+ "Unable to find definition of %s in stmts %a@.prefix=%a@.@?"
+ var_id
+ Printers.pp_node_stmts
+ m.mname.node_stmts
(pp_comma_list (fun fmt (id, n) ->
fprintf fmt "(%s,%s)" id n.mname.node_id))
(List.rev prefix);
@@ -138,10 +142,13 @@ let memories_next machines m =
in
prefix, def
| _ ->
- eprintf "Mem Failure: (prefix: %a, eexpr: %a)@.@?"
+ eprintf
+ "Mem Failure: (prefix: %a, eexpr: %a)@.@?"
(pp_comma_list (fun fmt (id, n) ->
fprintf fmt "(%s,%s)" id n.mname.node_id))
- (List.rev prefix) Printers.pp_expr ee;
+ (List.rev prefix)
+ Printers.pp_expr
+ ee;
assert false)
(memories_old machines m)
@@ -154,9 +161,12 @@ let memories_next machines m =
let traces_file fmt machines =
let pp_l = pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt " | ") in
fprintf fmt "<?xml version=\"1.0\"?>@.";
- fprintf fmt
+ fprintf
+ fmt
"<Traces xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\">@.";
- fprintf fmt "@[<v 5>@ %a@ @]@."
+ fprintf
+ fmt
+ "@[<v 5>@ %a@ @]@."
(pp_print_list (fun fmt m ->
let pp_var = pp_horn_var m in
let memories_old = memories_old machines m in
@@ -171,7 +181,9 @@ let traces_file fmt machines =
let output_vars =
rename_machine_list m.mname.node_id m.mstep.step_outputs
in
- fprintf fmt "<input name=\"%a\" type=\"%a\">%a</input>@ "
+ fprintf
+ fmt
+ "<input name=\"%a\" type=\"%a\">%a</input>@ "
(pp_l (pp_horn_var m))
input_vars
(pp_l (fun fmt id -> pp_type fmt id.var_type))
@@ -179,10 +191,15 @@ let traces_file fmt machines =
(pp_l (pp_horn_var m))
m.mstep.step_inputs;
- fprintf fmt "<output name=\"%a\" type=\"%a\">%a</output>@ "
- (pp_l pp_var) output_vars
+ fprintf
+ fmt
+ "<output name=\"%a\" type=\"%a\">%a</output>@ "
+ (pp_l pp_var)
+ output_vars
(pp_l (fun fmt id -> pp_type fmt id.var_type))
- output_vars (pp_l pp_var) m.mstep.step_outputs;
+ output_vars
+ (pp_l pp_var)
+ m.mstep.step_outputs;
let local_vars =
try full_memory_vars ~without_arrow:true machines m
@@ -193,8 +210,11 @@ let traces_file fmt machines =
let init_local_vars = rename_next_list local_vars in
let step_local_vars = rename_current_list local_vars in
- fprintf fmt "<localInit name=\"%a\" type=\"%a\">%t%a</localInit>@ "
- (pp_l pp_var) init_local_vars
+ fprintf
+ fmt
+ "<localInit name=\"%a\" type=\"%a\">%t%a</localInit>@ "
+ (pp_l pp_var)
+ init_local_vars
(pp_l (fun fmt id -> pp_type fmt id.var_type))
init_local_vars
(fun fmt ->
@@ -202,8 +222,11 @@ let traces_file fmt machines =
(pp_l (fun fmt (_, ee) -> fprintf fmt "%a" pp_xml_expr ee))
memories_next;
- fprintf fmt "<localStep name=\"%a\" type=\"%a\">%t%a</localStep>@ "
- (pp_l pp_var) step_local_vars
+ fprintf
+ fmt
+ "<localStep name=\"%a\" type=\"%a\">%t%a</localStep>@ "
+ (pp_l pp_var)
+ step_local_vars
(pp_l (fun fmt id -> pp_type fmt id.var_type))
step_local_vars
(fun fmt -> match memories_old with [] -> () | _ -> fprintf fmt "")
diff --git a/src/backends/Java/java_backend.ml b/src/backends/Java/java_backend.ml
index 680a9fe1..a64e5543 100644
--- a/src/backends/Java/java_backend.ml
+++ b/src/backends/Java/java_backend.ml
@@ -97,14 +97,22 @@ let rec pp_machine_instr m machines instance_out_list fmt instr =
fprintf fmt "%s = %a;" i0 (Basic_library.pp_java i (pp_val m)) vl
| MStep ([ i0 ], i, [ init; step ]) when List.assoc i m.minstances = "_arrow"
->
- fprintf fmt
+ fprintf
+ fmt
"@[<v 2>if (%s) {@,\
%s = false;@,\
%s = %a;@]@,\
@[<v 2>} else {@,\
%s = %a;@]@,\
};@,"
- i i i0 (pp_val m) init i0 (pp_val m) step
+ i
+ i
+ i0
+ (pp_val m)
+ init
+ i0
+ (pp_val m)
+ step
| MStep (il, i, vl) ->
let out =
try List.assoc i instance_out_list
@@ -112,10 +120,15 @@ let rec pp_machine_instr m machines instance_out_list fmt instr =
eprintf "impossible to find instance %s in the list@.@?" i;
assert false
in
- fprintf fmt "%s = %s.step (%a);@," out i
+ fprintf
+ fmt
+ "%s = %s.step (%a);@,"
+ out
+ i
(Utils.fprintf_list ~sep:", " (pp_val m))
vl;
- Utils.fprintf_list ~sep:"@,"
+ Utils.fprintf_list
+ ~sep:"@,"
(fun fmt (o, oname) -> fprintf fmt "%s = %s.%s;" o out oname)
fmt
(List.map2
@@ -123,14 +136,24 @@ let rec pp_machine_instr m machines instance_out_list fmt instr =
il
(get_output_of_machine machines (List.assoc i m.minstances)))
| MBranch (g, hl) ->
- Format.fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]" (pp_val m) g
- (Utils.fprintf_list ~sep:"@,"
+ Format.fprintf
+ fmt
+ "@[<v 2>switch(%a) {@,%a@,}@]"
+ (pp_val m)
+ g
+ (Utils.fprintf_list
+ ~sep:"@,"
(pp_machine_branch m machines instance_out_list))
hl
and pp_machine_branch m machines instance_out_list fmt (t, h) =
- Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_tag t
- (Utils.fprintf_list ~sep:"@,"
+ Format.fprintf
+ fmt
+ "@[<v 2>case %a:@,%a@,break;@]"
+ pp_tag
+ t
+ (Utils.fprintf_list
+ ~sep:"@,"
(pp_machine_instr m machines instance_out_list))
h
@@ -149,7 +172,9 @@ let pp_local_field_instances =
fprintf fmt "protected %s %s;" (get_class_name node_type) node_inst)
let pp_output_constructor fmt outputs =
- fprintf fmt "@[<v 2>public Output(%a) {@,%a@]@,}"
+ fprintf
+ fmt
+ "@[<v 2>public Output(%a) {@,%a@]@,}"
(fprintf_list ~sep:"; " pp_var)
outputs
(fprintf_list ~sep:"@," (fun fmt v ->
@@ -157,12 +182,19 @@ let pp_output_constructor fmt outputs =
outputs
let pp_output_class fmt step =
- fprintf fmt "@[<v 2>public class Output {@,%a@,@,%a@]@,}@,"
- (pp_local_fields "public") step.step_outputs pp_output_constructor
+ fprintf
+ fmt
+ "@[<v 2>public class Output {@,%a@,@,%a@]@,}@,"
+ (pp_local_fields "public")
+ step.step_outputs
+ pp_output_constructor
step.step_outputs
let pp_constructor fmt (name, instances) =
- fprintf fmt "@[<v 2>public %s () {@,%a@]@,}@," (String.capitalize name)
+ fprintf
+ fmt
+ "@[<v 2>public %s () {@,%a@]@,}@,"
+ (String.capitalize name)
(fprintf_list ~sep:"@," (fun fmt (node_inst, node_type) ->
match node_type with
| "_arrow" ->
@@ -172,7 +204,9 @@ let pp_constructor fmt (name, instances) =
instances
let pp_reset machines fmt m =
- fprintf fmt "@[<v 2>public void reset () {@,%a@]@,}@,"
+ fprintf
+ fmt
+ "@[<v 2>public void reset () {@,%a@]@,}@,"
(fprintf_list ~sep:"@," (pp_machine_instr m machines []))
m.minit
@@ -180,7 +214,9 @@ let pp_step machines fmt m : unit =
let out_assoc_list =
List.map (fun (node_inst, _) -> node_inst, "out_" ^ node_inst) m.minstances
in
- fprintf fmt "@[<v 2>public Output step (%a) {@,%a%t@,%a%a%t@,%a@,%t@]@,}@,"
+ fprintf
+ fmt
+ "@[<v 2>public Output step (%a) {@,%a%t@,%a%a%t@,%a@,%t@]@,}@,"
(Utils.fprintf_list ~sep:",@ " pp_var)
m.mstep.step_inputs
(* locals *)
@@ -199,7 +235,9 @@ let pp_step machines fmt m : unit =
m.mstep.step_instrs
(* create out object and return it *)
(fun fmt ->
- fprintf fmt "return new Output(%a);"
+ fprintf
+ fmt
+ "return new Output(%a);"
(fprintf_list ~sep:"," (fun fmt v -> pp_print_string fmt v.var_id))
m.mstep.step_outputs)
@@ -207,18 +245,22 @@ let print_machine machines fmt m =
if m.mname.node_id = "_arrow" then ()
else
(* We don't print arrow function *)
- fprintf fmt "@[<v 2>class %s {@,%a%t%a%t%t%a@,%a@,%a@,%a@]@,}@.@.@."
+ fprintf
+ fmt
+ "@[<v 2>class %s {@,%a%t%a%t%t%a@,%a@,%a@,%a@]@,}@.@.@."
(String.capitalize m.mname.node_id)
(* class name *)
(pp_local_fields "protected")
m.mmemory
(* fields *)
(pp_newline_if_non_empty m.mmemory)
- pp_local_field_instances m.minstances
+ pp_local_field_instances
+ m.minstances
(* object fields *)
(pp_newline_if_non_empty m.minstances)
(pp_newline_if_non_empty m.minstances)
- pp_output_class m.mstep
+ pp_output_class
+ m.mstep
(* class for output of step method *)
pp_constructor
(m.mname.node_id, m.minstances)
@@ -264,22 +306,38 @@ let read_input fmt typ =
let print_main_fun basename machines m fmt =
let m_class = String.capitalize m.mname.node_id in
- fprintf fmt "@[<v 2>class %s {@,@,@[<v 2>%s {@,%t@,%t@]@,}@,@]@,}@."
+ fprintf
+ fmt
+ "@[<v 2>class %s {@,@,@[<v 2>%s {@,%t@,%t@]@,}@,@]@,}@."
(String.capitalize basename)
"public static void main (String[] args)"
(fun fmt -> fprintf fmt "%s main_node = new %s();" m_class m_class)
(fun fmt ->
- fprintf fmt "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@,"
+ fprintf
+ fmt
+ "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@,"
(fprintf_list ~sep:"@," (fun fmt v ->
- fprintf fmt "System.out.println(\"%s?\");@,%a = %a;" v.var_id
- pp_var v read_input v.var_type))
+ fprintf
+ fmt
+ "System.out.println(\"%s?\");@,%a = %a;"
+ v.var_id
+ pp_var
+ v
+ read_input
+ v.var_type))
m.mstep.step_inputs
(fun fmt ->
- fprintf fmt "%s.Output out = main_node.step(%a);" m_class
+ fprintf
+ fmt
+ "%s.Output out = main_node.step(%a);"
+ m_class
(fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
m.mstep.step_inputs)
(fprintf_list ~sep:"@," (fun fmt v ->
- fprintf fmt "System.out.println(\"%s = \" + out.%s);" v.var_id
+ fprintf
+ fmt
+ "System.out.println(\"%s = \" + out.%s);"
+ v.var_id
v.var_id))
m.mstep.step_outputs)
@@ -373,7 +431,8 @@ let translate_to_java source_fmt basename prog machines =
res
| None ->
if m.mname.node_id = main_node then Some m else None)
- None machines
+ None
+ machines
in
match main_node_opt with
| None ->
diff --git a/src/backends/VHDL/vhdl_ast.ml b/src/backends/VHDL/vhdl_ast.ml
index f82444a5..08da000c 100644
--- a/src/backends/VHDL/vhdl_ast.ml
+++ b/src/backends/VHDL/vhdl_ast.ml
@@ -29,14 +29,19 @@ let rec pp_vhdl_type fmt t =
| Bit_vector (n, m) ->
Format.fprintf fmt "bit_vector(%i downto %i)" n m
| Range (base, n, m) ->
- Format.fprintf fmt "%trange %i to %i"
+ Format.fprintf
+ fmt
+ "%trange %i to %i"
(fun fmt ->
match base with Some s -> Format.fprintf fmt "%s " s | None -> ())
- n m
+ n
+ m
| Array (n, m, base) ->
Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
| Enumerated sl ->
- Format.fprintf fmt "(%a)"
+ Format.fprintf
+ fmt
+ "(%a)"
(Utils.fprintf_list ~sep:", " Format.pp_print_string)
sl
@@ -91,7 +96,12 @@ type vhdl_declaration_t =
let pp_vhdl_declaration fmt decl =
match decl with
| VarDecl v ->
- Format.fprintf fmt "variable %s : %a%t;" v.name pp_vhdl_type v.typ
+ Format.fprintf
+ fmt
+ "variable %s : %a%t;"
+ v.name
+ pp_vhdl_type
+ v.typ
(fun fmt ->
match v.init_val with
| Some initv ->
@@ -99,8 +109,14 @@ let pp_vhdl_declaration fmt decl =
| _ ->
())
| CstDecl v ->
- Format.fprintf fmt "constant %s : %a := %a;" v.name pp_vhdl_type v.typ
- pp_cst_val v.init_val
+ Format.fprintf
+ fmt
+ "constant %s : %a := %a;"
+ v.name
+ pp_vhdl_type
+ v.typ
+ pp_cst_val
+ v.init_val
| SigDecl v ->
Format.fprintf fmt "signal %s : %a%t;" v.name pp_vhdl_type v.typ (fun fmt ->
match v.init_val with
@@ -199,15 +215,26 @@ let rec pp_vhdl_expr fmt e =
Format.fprintf fmt "%s%t" s.name (fun fmt ->
match s.att with None -> () | Some att -> pp_signal_attribute fmt att)
| SuffixMod s ->
- Format.fprintf fmt "%a %a" pp_vhdl_expr s.expr pp_suffix_selection
+ Format.fprintf
+ fmt
+ "%a %a"
+ pp_vhdl_expr
+ s.expr
+ pp_suffix_selection
s.selection
| Op op -> (
match op.args with
| [] ->
assert false
| [ e1; e2 ] ->
- Format.fprintf fmt "@[<hov 3>%a %s %a@]" pp_vhdl_expr e1 op.id
- pp_vhdl_expr e2
+ Format.fprintf
+ fmt
+ "@[<hov 3>%a %s %a@]"
+ pp_vhdl_expr
+ e1
+ op.id
+ pp_vhdl_expr
+ e2
| _ ->
assert false
(* all ops are binary up to now *)
@@ -252,8 +279,13 @@ let rec pp_vhdl_sequential_stmt fmt stmt =
(fun idx ifcase ->
if idx = 0 then Format.fprintf fmt "@[<v 3>if"
else Format.fprintf fmt "@ @[<v 3>elsif";
- Format.fprintf fmt " %a then@ %a@]" pp_vhdl_expr ifcase.if_cond
- pp_vhdl_sequential_stmts ifcase.if_block)
+ Format.fprintf
+ fmt
+ " %a then@ %a@]"
+ pp_vhdl_expr
+ ifcase.if_cond
+ pp_vhdl_sequential_stmts
+ ifcase.if_block)
ifva.if_cases;
let _ =
match ifva.default with
@@ -264,7 +296,10 @@ let rec pp_vhdl_sequential_stmt fmt stmt =
in
Format.fprintf fmt "@ end if;"
| Case caseva ->
- Format.fprintf fmt "@[<v 3>case %a is@ %a@]@ end case;" pp_vhdl_expr
+ Format.fprintf
+ fmt
+ "@[<v 3>case %a is@ %a@]@ end case;"
+ pp_vhdl_expr
caseva.guard
(Utils.fprintf_list ~sep:"@ " pp_vhdl_case)
caseva.branches
@@ -273,8 +308,13 @@ and pp_vhdl_sequential_stmts fmt l =
Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt fmt l
and pp_vhdl_case fmt case =
- Format.fprintf fmt "when %a => %a" pp_vhdl_expr case.when_cond
- pp_vhdl_sequential_stmt case.when_stmt
+ Format.fprintf
+ fmt
+ "when %a => %a"
+ pp_vhdl_expr
+ case.when_cond
+ pp_vhdl_sequential_stmt
+ case.when_stmt
type signal_condition_t = {
expr : vhdl_expr_t;
@@ -332,12 +372,16 @@ let pp_vhdl_concurrent_stmt fmt stmt =
Format.fprintf fmt " else %a" pp_vhdl_expr else_case))
in
let pp_process fmt p =
- Format.fprintf fmt "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
+ Format.fprintf
+ fmt
+ "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
(fun fmt ->
match p.id with Some id -> Format.fprintf fmt "%s: " id | None -> ())
(fun fmt asigs ->
if asigs <> [] then
- Format.fprintf fmt "(@[<hov 0>%a)@]"
+ Format.fprintf
+ fmt
+ "(@[<hov 0>%a)@]"
(Utils.fprintf_list ~sep:",@ " Format.pp_print_string)
asigs)
p.active_sigs
@@ -345,9 +389,18 @@ let pp_vhdl_concurrent_stmt fmt stmt =
p.body
in
let pp_sig_sel fmt va =
- Format.fprintf fmt "@[<v 3>with %a select@ %a;@]" pp_vhdl_expr va.sel
+ Format.fprintf
+ fmt
+ "@[<v 3>with %a select@ %a;@]"
+ pp_vhdl_expr
+ va.sel
(Utils.fprintf_list ~sep:"@ " (fun fmt b ->
- Format.fprintf fmt "%s <= %a when %t" b.sel_lhs pp_vhdl_expr b.expr
+ Format.fprintf
+ fmt
+ "%s <= %a when %t"
+ b.sel_lhs
+ pp_vhdl_expr
+ b.expr
(fun fmt ->
match b.when_sel with
| None ->
@@ -389,7 +442,13 @@ let pp_vhdl_port_kind fmt p =
type vhdl_port_t = { name : string; kind : vhdl_port_kind_t; typ : vhdl_type_t }
let pp_vhdl_port fmt p =
- Format.fprintf fmt "%s : %a %a" p.name pp_vhdl_port_kind p.kind pp_vhdl_type
+ Format.fprintf
+ fmt
+ "%s : %a %a"
+ p.name
+ pp_vhdl_port_kind
+ p.kind
+ pp_vhdl_type
p.typ
type vhdl_entity_t = {
@@ -399,7 +458,10 @@ type vhdl_entity_t = {
}
let pp_vhdl_entity fmt e =
- Format.fprintf fmt "@[<v 3>entity %s is@ %t%t@]@ end %s;@ " e.name
+ Format.fprintf
+ fmt
+ "@[<v 3>entity %s is@ %t%t@]@ end %s;@ "
+ e.name
(fun fmt ->
List.iter
(fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g)
@@ -407,7 +469,9 @@ let pp_vhdl_entity fmt e =
(fun fmt ->
if e.ports = [] then ()
else
- Format.fprintf fmt "port (@[<hov 0>%a@]);"
+ Format.fprintf
+ fmt
+ "port (@[<hov 0>%a@]);"
(Utils.fprintf_list ~sep:",@ " pp_vhdl_port)
e.ports)
e.name
@@ -420,9 +484,13 @@ let pp_vhdl_entity fmt e =
type vhdl_package_t = { name : string; shared_defs : vhdl_definition_t list }
let pp_vhdl_package fmt p =
- Format.fprintf fmt "@[<v 3>package %s is@ %a@]@ end %s;@ " p.name
+ Format.fprintf
+ fmt
+ "@[<v 3>package %s is@ %a@]@ end %s;@ "
+ p.name
(Utils.fprintf_list ~sep:"@ " pp_vhdl_definition)
- p.shared_defs p.name
+ p.shared_defs
+ p.name
type vhdl_load_t = Library of string | Use of string list
@@ -431,7 +499,9 @@ let pp_vhdl_load fmt l =
| Library s ->
Format.fprintf fmt "library %s;@ " s
| Use sl ->
- Format.fprintf fmt "use %a;@ "
+ Format.fprintf
+ fmt
+ "use %a;@ "
(Utils.fprintf_list ~sep:"." Format.pp_print_string)
sl
@@ -447,13 +517,16 @@ type vhdl_architecture_t = {
}
let pp_vhdl_architecture fmt a =
- Format.fprintf fmt
- "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;" a.name
+ Format.fprintf
+ fmt
+ "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;"
+ a.name
a.entity
(Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration)
a.declarations
(Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt)
- a.body a.name
+ a.body
+ a.name
(* TODO. Configuraiton is optional *)
type vhdl_configuration_t = unit
@@ -469,7 +542,9 @@ type vhdl_design_t = {
}
let pp_vhdl_design fmt d =
- Format.fprintf fmt "@[<v 0>%a%t%a%t%a%t%a%t@]"
+ Format.fprintf
+ fmt
+ "@[<v 0>%a%t%a%t%a%t%a%t@]"
(Utils.fprintf_list ~sep:"@ " pp_vhdl_package)
d.packages
(fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ")
diff --git a/src/basic_library.ml b/src/basic_library.ml
index 74676522..2253e161 100644
--- a/src/basic_library.ml
+++ b/src/basic_library.ml
@@ -53,12 +53,14 @@ let clock_env =
let env' =
List.fold_right
(fun op env -> CE.add_value env op ck_nullary_univ)
- [ "true"; "false" ] init_env
+ [ "true"; "false" ]
+ init_env
in
let env' =
List.fold_right
(fun op env -> CE.add_value env op ck_unary_univ)
- [ "uminus"; "not" ] env'
+ [ "uminus"; "not" ]
+ env'
in
let env' =
List.fold_right
@@ -163,7 +165,8 @@ let eval_dim_env =
in
List.fold_left
(fun env (op, op_eval) -> VE.add_value env op op_eval)
- VE.initial defs
+ VE.initial
+ defs
let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "uminus" ]
diff --git a/src/causality.ml b/src/causality.ml
index 3ba5ca91..243447ff 100644
--- a/src/causality.ml
+++ b/src/causality.ml
@@ -54,7 +54,8 @@ let is_graph_root v g = IdentDepGraph.in_degree g v = 0
let graph_roots g =
IdentDepGraph.fold_vertex
(fun v roots -> if is_graph_root v g then v :: roots else roots)
- g []
+ g
+ []
let add_edges src tgt g =
(*List.iter (fun s -> List.iter (fun t -> Format.eprintf "add %s -> %s@." s t)
@@ -151,13 +152,15 @@ module ExprDep = struct
let node_local_variables nd =
List.fold_left
(fun locals v -> ISet.add v.var_id locals)
- ISet.empty nd.node_locals
+ ISet.empty
+ nd.node_locals
let node_constant_variables nd =
List.fold_left
(fun locals v ->
if v.var_dec_const then ISet.add v.var_id locals else locals)
- ISet.empty nd.node_locals
+ ISet.empty
+ nd.node_locals
(* XXX: UNUSED *)
(* let node_auxiliary_variables nd =
@@ -168,11 +171,13 @@ module ExprDep = struct
let inoutputs =
List.fold_left
(fun inoutputs v -> ISet.add v.var_id inoutputs)
- inputs nd.node_outputs
+ inputs
+ nd.node_outputs
in
List.fold_left
(fun vars v -> ISet.add v.var_id vars)
- inoutputs nd.node_locals
+ inoutputs
+ nd.node_locals
(* computes the equivalence relation relating variables in the same equation
lhs, under the form of a table of class representatives *)
@@ -220,7 +225,9 @@ module ExprDep = struct
(*Format.eprintf "add_clock %a@." Clocks.print_ck ck;*)
match (Clocks.repr ck).Clocks.cdesc with
| Clocks.Con (ck', cr, _) ->
- add_var lhs_is_mem lhs
+ add_var
+ lhs_is_mem
+ lhs
(Clocks.const_of_carrier cr)
(add_clock lhs_is_mem lhs ck' g)
| Clocks.Ccarrying (_, ck') ->
@@ -252,17 +259,26 @@ module ExprDep = struct
| Expr_ident x ->
add_var lhs_is_mem lhs x g
| Expr_access (e1, d) | Expr_power (e1, d) ->
- add_dep lhs_is_mem lhs e1
+ add_dep
+ lhs_is_mem
+ lhs
+ e1
(add_dep lhs_is_mem lhs (expr_of_dimension d) g)
| Expr_array a ->
List.fold_right (add_dep lhs_is_mem lhs) a g
| Expr_tuple t ->
List.fold_right2 (fun l r -> add_dep lhs_is_mem [ l ] r) lhs t g
| Expr_merge (c, hl) ->
- add_var lhs_is_mem lhs c
+ add_var
+ lhs_is_mem
+ lhs
+ c
(List.fold_right (fun (_, h) -> add_dep lhs_is_mem lhs h) hl g)
| Expr_ite (c, t, e) ->
- add_dep lhs_is_mem lhs c
+ add_dep
+ lhs_is_mem
+ lhs
+ c
(add_dep lhs_is_mem lhs t (add_dep lhs_is_mem lhs e g))
| Expr_arrow (e1, e2) ->
add_dep lhs_is_mem lhs e2 (add_dep lhs_is_mem lhs e1 g)
@@ -283,7 +299,8 @@ module ExprDep = struct
(fun g lhs ->
if ISet.mem lhs mems then add_vertices [ lhs; mk_read_var lhs ] g
else add_vertices [ lhs ] g)
- g eq.eq_lhs
+ g
+ eq.eq_lhs
in
add_dep false eq.eq_lhs eq.eq_rhs (g, g')
@@ -295,7 +312,8 @@ module ExprDep = struct
let g =
List.fold_right
(add_eq_dependencies mems inputs node_vars)
- (get_node_eqs n) g
+ (get_node_eqs n)
+ g
in
(* TODO Xavier: un essai ci dessous. Ca n'a pas l'air de résoudre le pb. Il
@@ -336,11 +354,13 @@ module NodeDep = struct
| Expr_array t | Expr_tuple t ->
List.fold_right
(fun x set -> ESet.union (get_expr_calls prednode x) set)
- t ESet.empty
+ t
+ ESet.empty
| Expr_merge (_, hl) ->
List.fold_right
(fun (_, h) set -> ESet.union (get_expr_calls prednode h) set)
- hl ESet.empty
+ hl
+ ESet.empty
| Expr_fby (e1, e2) | Expr_arrow (e1, e2) ->
ESet.union (get_expr_calls prednode e1) (get_expr_calls prednode e2)
| Expr_ite (c, t, e) ->
@@ -387,7 +407,8 @@ module NodeDep = struct
let calls =
accu
(fun a -> get_expr_calls prednode a.assert_expr)
- calls h.hand_asserts
+ calls
+ h.hand_asserts
in
(* let calls = accu xx calls h.hand_annots in *)
(* TODO: search for calls in eexpr *)
@@ -404,7 +425,9 @@ module NodeDep = struct
let get_contract_calls prednode c =
let deps = accu (get_stmt_calls prednode) ESet.empty c.stmts in
let deps =
- accu (get_eexpr_calls prednode) deps
+ accu
+ (get_eexpr_calls prednode)
+ deps
(c.assume @ c.guarantees
@ List.fold_left (fun accu m -> accu @ m.require @ m.ensure) [] c.modes
)
@@ -464,7 +487,8 @@ module NodeDep = struct
| _ ->
assert false
(* should not happen *))
- prog g
+ prog
+ g
in
g
@@ -619,7 +643,10 @@ module Disjunction = struct
let pp_ciset fmt t =
let open Format in
- pp_print_braced' ~pp_sep:pp_print_space Printers.pp_var_name fmt
+ pp_print_braced'
+ ~pp_sep:pp_print_space
+ Printers.pp_var_name
+ fmt
(CISet.elements t)
let clock_disjoint_map vdecls =
@@ -631,7 +658,8 @@ module Disjunction = struct
(fun res v2 ->
if Clocks.disjoint v1.var_clock v2.var_clock then CISet.add v2 res
else res)
- CISet.empty vdecls
+ CISet.empty
+ vdecls
in
(* disjoint vdecls are stored in increasing branch length order *)
Hashtbl.add map v1.var_id disj_v1)
@@ -680,7 +708,10 @@ module Disjunction = struct
fprintf fmt "@[<v 2>{ /* disjoint map */%t@] }" (fun fmt ->
Hashtbl.iter
(fun k v ->
- fprintf fmt "@,%s # %a" k
+ fprintf
+ fmt
+ "@,%s # %a"
+ k
(pp_print_braced' Printers.pp_var_name)
(CISet.elements v))
map))
@@ -696,14 +727,20 @@ let pp_error fmt err =
match err with
| NodeCycle trace ->
Format.(
- fprintf fmt "Causality error, cyclic node calls:@ @[<v 0>%a@]@ "
+ fprintf
+ fmt
+ "Causality error, cyclic node calls:@ @[<v 0>%a@]@ "
(pp_comma_list Format.pp_print_string)
trace)
| DataCycle traces ->
Format.(
- fprintf fmt "Causality error, cyclic data dependencies:@ @[<v 0>%a@]@ "
+ fprintf
+ fmt
+ "Causality error, cyclic data dependencies:@ @[<v 0>%a@]@ "
(pp_print_list ~pp_sep:pp_print_semicolon (fun fmt trace ->
- fprintf fmt "@[<v 0>{%a}@]"
+ fprintf
+ fmt
+ "@[<v 0>{%a}@]"
(pp_comma_list Format.pp_print_string)
trace))
traces)
@@ -769,7 +806,8 @@ module VarClockDep = struct
(fun g var_decl ->
let deps = get_clock_dep var_decl.var_clock in
add_edges [ var_decl.var_id ] deps g)
- g locals
+ g
+ locals
in
let sorted, no_deps =
TopologicalDepGraph.fold
@@ -777,7 +815,8 @@ module VarClockDep = struct
let select v = v.var_id = vid in
let selected, not_selected = List.partition select remaining in
selected @ accu, not_selected)
- g ([], locals)
+ g
+ ([], locals)
in
no_deps @ sorted
end
diff --git a/src/checks/access.ml b/src/checks/access.ml
index 80f8c57d..704d8aef 100644
--- a/src/checks/access.ml
+++ b/src/checks/access.ml
@@ -47,7 +47,8 @@ let rec check_expr checks expr =
| Expr_access (e1, d) ->
check_expr
(CSet.add
- (Dimension.check_access expr.expr_loc
+ (Dimension.check_access
+ expr.expr_loc
(Types.array_type_dimension e1.expr_type)
d)
checks)
@@ -74,7 +75,8 @@ let rec check_expr checks expr =
let rec check_var_decl_type loc checks ty =
if Types.is_array_type ty then
- check_var_decl_type loc
+ check_var_decl_type
+ loc
(CSet.add
(Dimension.check_bound loc (Types.array_type_dimension ty))
checks)
diff --git a/src/checks/algebraicLoop.ml b/src/checks/algebraicLoop.ml
index 1519656b..11642596 100644
--- a/src/checks/algebraicLoop.ml
+++ b/src/checks/algebraicLoop.ml
@@ -71,7 +71,8 @@ module CycleResolution = struct
(* We have a match: keep the eq and the expr to inline *)
call :: accu
else accu)
- [] calls
+ []
+ calls
end
(* Format.fprintf fmt "@[<v 2>Possible resolution:@ %a@]" pp_resolution
@@ -155,7 +156,8 @@ let inline_expr node expr =
program *)
let fast_stages_processing prog =
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"@[<v 2>Fast revalidation: normalization + schedulability@ ");
Options.verbose_level := !Options.verbose_level - 2;
@@ -348,7 +350,8 @@ let clean_al prog : program_t * bool * report =
(nd, al) :: al_list ))
| _ ->
max_inlines, top :: prog_accu, al_list)
- prog (max_inlines, [], [])
+ prog
+ (max_inlines, [], [])
in
prog, List.for_all al_is_solved al_list, al_list
@@ -356,10 +359,14 @@ let clean_al prog : program_t * bool * report =
let pp_al nd fmt (partition, calls, _) =
let open Format in
fprintf fmt "@[<v 0>";
- fprintf fmt "variables in the alg. loop: @[<hov 0>%a@]@ "
+ fprintf
+ fmt
+ "variables in the alg. loop: @[<hov 0>%a@]@ "
(pp_comma_list pp_print_string)
partition;
- fprintf fmt "@ involved node calls: @[<v 0>%a@]@ "
+ fprintf
+ fmt
+ "@ involved node calls: @[<v 0>%a@]@ "
(pp_comma_list (fun fmt ((funid, expr, _), status) ->
fprintf fmt "%s" funid;
if status && is_expr_inlined nd expr then
@@ -375,7 +382,8 @@ let pp_al nd fmt (partition, calls, _) =
let pp_report fmt report =
let open Format in
- pp_print_list ~pp_open_box:pp_open_vbox0
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
(fun _ (nd, als) ->
let top = Corelang.node_from_name nd.node_id in
let pp =
@@ -387,10 +395,14 @@ let pp_report fmt report =
(* solvable cases: warning only *)
in
pp top.top_decl_loc (fun fmt ->
- fprintf fmt "algebraic loop in node %s: {@[<v 0>%a@]}" nd.node_id
+ fprintf
+ fmt
+ "algebraic loop in node %s: {@[<v 0>%a@]}"
+ nd.node_id
(pp_print_list (pp_al nd))
als))
- fmt report;
+ fmt
+ report;
fprintf fmt "@."
let analyze cpt prog =
diff --git a/src/checks/liveness.ml b/src/checks/liveness.ml
index 3093b69e..1eea7712 100644
--- a/src/checks/liveness.ml
+++ b/src/checks/liveness.ml
@@ -36,7 +36,9 @@ let compute_fanin n g =
if ISet.mem v locals then
Hashtbl.add fanin v (IdentDepGraph.in_degree g v)
else if ExprDep.is_read_var v && not (ISet.mem v inputs) then
- Hashtbl.add fanin (ExprDep.undo_read_var v)
+ Hashtbl.add
+ fanin
+ (ExprDep.undo_read_var v)
(IdentDepGraph.in_degree g v))
g;
fanin
@@ -72,7 +74,8 @@ let compute_unused_variables n g =
let outputs = ExprDep.node_output_variables n in
ISet.fold
(fun var unused -> ISet.diff unused (cone_of_influence g var))
- (ISet.union outputs mems) (ISet.union inputs mems)
+ (ISet.union outputs mems)
+ (ISet.union inputs mems)
(* XXX: UNUSED *)
(* computes the set of potentially reusable variables. We don't reuse input
@@ -90,7 +93,8 @@ let kill_instance_variables ctx inst =
let kill_root ctx head =
IdentDepGraph.iter_succ
(IdentDepGraph.remove_edge ctx.dep_graph head.var_id)
- ctx.dep_graph head.var_id
+ ctx.dep_graph
+ head.var_id
(* Recursively removes useless variables, i.e. [ctx.evaluated] variables that
are current roots of the dep graph [ctx.dep_graph] - [evaluated] is the set
@@ -135,7 +139,8 @@ let is_aliasable_input node var =
| Some (_, args) ->
List.fold_right
(fun e r -> match e.expr_desc with Expr_ident id -> id :: r | _ -> r)
- args []
+ args
+ []
in
fun v -> is_aliasable v && List.mem v.var_id inputs_var
@@ -152,14 +157,21 @@ let pp_reuse_policy fmt policy =
Hashtbl.iter (fun s t -> fprintf fmt "@,%s -> %s" s t.var_id) policy))
let pp_context fmt ctx =
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"@[<v 2>{ /*BEGIN context */@,\
eval = %a;@,\
graph = %a;@,\
disjoint = %a;@,\
policy = %a;@,\
- /* END context */ }@]" Disjunction.pp_ciset ctx.evaluated pp_dep_graph
- ctx.dep_graph Disjunction.pp_disjoint_map ctx.disjoint pp_reuse_policy
+ /* END context */ }@]"
+ Disjunction.pp_ciset
+ ctx.evaluated
+ pp_dep_graph
+ ctx.dep_graph
+ Disjunction.pp_disjoint_map
+ ctx.disjoint
+ pp_reuse_policy
ctx.policy
(* computes the reusable dependencies of variable [var] in graph [g], once [var]
@@ -204,7 +216,9 @@ let compute_reuse node ctx heads var =
IdentDepGraph.fold_pred
(fun p r ->
r && Disjunction.CISet.exists (fun d -> p = d.var_id) disjoint)
- ctx.dep_graph v.var_id true
+ ctx.dep_graph
+ v.var_id
+ true
in
let eligibles =
if ISet.mem var.var_id (ExprDep.node_memory_variables node) then
@@ -221,14 +235,21 @@ let compute_reuse node ctx heads var =
quasi_dead
in
Log.report ~level:7 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"@[<v>eligibles : %a@,\
live : %a@,\
disjoint live: %a@,\
dead : %a@,\
@]"
- Disjunction.pp_ciset eligibles Disjunction.pp_ciset live
- Disjunction.pp_ciset disjoint_live Disjunction.pp_ciset dead);
+ Disjunction.pp_ciset
+ eligibles
+ Disjunction.pp_ciset
+ live
+ Disjunction.pp_ciset
+ disjoint_live
+ Disjunction.pp_ciset
+ dead);
(try
let reuse =
match Disjunction.CISet.max_elt_opt disjoint_live with
@@ -256,30 +277,46 @@ let compute_reuse_policy node schedule disjoint g =
let heads = List.map (fun v -> get_node_var v node) heads in
Log.report ~level:6 (fun fmt ->
Format.(
- fprintf fmt
+ fprintf
+ fmt
"@[<v>@[<v 2>new context:@,\
%a@]@,\
NEW HEADS:%a@,\
COMPUTE_DEPENDENCIES@,\
@]"
- pp_context ctx
- (pp_print_list ~pp_open_box:pp_open_hbox ~pp_sep:pp_print_space
+ pp_context
+ ctx
+ (pp_print_list
+ ~pp_open_box:pp_open_hbox
+ ~pp_sep:pp_print_space
(fun fmt head ->
- fprintf fmt "%s (%a)" head.var_id Printers.pp_node_eq
+ fprintf
+ fmt
+ "%s (%a)"
+ head.var_id
+ Printers.pp_node_eq
(get_node_eq head.var_id node)))
heads));
compute_dependencies heads ctx;
Log.report ~level:6 (fun fmt ->
- Format.fprintf fmt "@[<v>@[<v 2>new context:@,%a@]@,COMPUTE_REUSE@,@]"
- pp_context ctx);
+ Format.fprintf
+ fmt
+ "@[<v>@[<v 2>new context:@,%a@]@,COMPUTE_REUSE@,@]"
+ pp_context
+ ctx);
List.iter (compute_reuse node ctx heads) heads;
(*compute_evaluated heads ctx;*)
Log.report ~level:6 (fun fmt ->
Format.(
- fprintf fmt "@[<v>%a@,@]"
+ fprintf
+ fmt
+ "@[<v>%a@,@]"
(pp_print_list ~pp_open_box:pp_open_vbox0 (fun fmt head ->
- fprintf fmt "reuse %s instead of %s"
- (Hashtbl.find ctx.policy head.var_id).var_id head.var_id))
+ fprintf
+ fmt
+ "reuse %s instead of %s"
+ (Hashtbl.find ctx.policy head.var_id).var_id
+ head.var_id))
heads)))
schedule;
IdentDepGraph.clear ctx.dep_graph;
diff --git a/src/checks/stateless.ml b/src/checks/stateless.ml
index 32c67717..6f163714 100644
--- a/src/checks/stateless.ml
+++ b/src/checks/stateless.ml
@@ -45,14 +45,20 @@ let rec check_expr expr =
with Not_found ->
let loc = expr.expr_loc in
Error.pp_error loc (fun fmt ->
- Format.fprintf fmt "Unable to find node %s in expression %a" i
- Printers.pp_expr expr);
+ Format.fprintf
+ fmt
+ "Unable to find node %s in expression %a"
+ i
+ Printers.pp_expr
+ expr);
raise (Error.Error (loc, Error.Unbound_symbol i))
in
(* Warning message when trying to reset a stateless node *)
if stateless_node && not reset_opt then
Error.pp_warning expr.expr_loc (fun fmt ->
- Format.fprintf fmt "Trying to reset call the stateless node or op %s"
+ Format.fprintf
+ fmt
+ "Trying to reset call the stateless node or op %s"
i);
check_expr e' && reset_opt && stateless_node
@@ -127,13 +133,18 @@ let check_compat header = List.iter check_compat_decl header
let pp_error fmt err =
match err with
| Stateful_kwd nd ->
- Format.fprintf fmt "node %s should be stateless but is actually stateful.@."
+ Format.fprintf
+ fmt
+ "node %s should be stateless but is actually stateful.@."
nd
| Stateful_imp nd ->
- Format.fprintf fmt
- "node %s is declared stateless but is actually stateful.@." nd
+ Format.fprintf
+ fmt
+ "node %s is declared stateless but is actually stateful.@."
+ nd
| Stateful_ext_C nd ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"node %s with declared prototype C cannot be stateful, it has to be a \
function.@."
nd
diff --git a/src/clock_calculus.ml b/src/clock_calculus.ml
index 278a0a95..1f2bf34f 100644
--- a/src/clock_calculus.ml
+++ b/src/clock_calculus.ml
@@ -587,7 +587,8 @@ and clock_expr env expr =
let ckh = clock_uncarry (clock_expr env h) in
unify_tuple_clock
(Some (new_ck (Con (cvar, crvar, t)) true))
- ckh h.expr_loc)
+ ckh
+ h.expr_loc)
hl;
let cr = clock_carrier env c expr.expr_loc cvar in
try_unify_carrier cr crvar expr.expr_loc;
@@ -596,8 +597,13 @@ and clock_expr env expr =
cres
in
Log.report ~level:4 (fun fmt ->
- Format.fprintf fmt "Clock of expr %a: %a@ " Printers.pp_expr expr
- Clocks.pp resulting_ck);
+ Format.fprintf
+ fmt
+ "Clock of expr %a: %a@ "
+ Printers.pp_expr
+ expr
+ Clocks.pp
+ resulting_ck);
resulting_ck
let clock_of_vlist vars =
@@ -608,7 +614,8 @@ let clock_of_vlist vars =
environment [env] *)
let clock_eq env eq =
let expr_lhs =
- expr_of_expr_list eq.eq_loc
+ expr_of_expr_list
+ eq.eq_loc
(List.map (fun v -> expr_of_ident v eq.eq_loc) eq.eq_lhs)
in
let ck_rhs = clock_expr env eq.eq_rhs in
@@ -636,7 +643,8 @@ let clock_coreclock env cck id loc scoped =
expr_loc = loc;
expr_annot = None;
})
- dummy_id_expr cl
+ dummy_id_expr
+ cl
in
clock_expr temp_env when_expr
@@ -698,7 +706,11 @@ let clock_node env loc nd =
(* if (is_main && is_polymorphic ck_node) then raise (Error
(loc,(Cannot_be_polymorphic ck_node))); *)
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt "Generalized clock of %s: %a@ @ " nd.node_id Clocks.pp
+ Format.fprintf
+ fmt
+ "Generalized clock of %s: %a@ @ "
+ nd.node_id
+ Clocks.pp
ck_node);
nd.node_clock <- ck_node;
Env.add_value env nd.node_id ck_node
diff --git a/src/clocks.ml b/src/clocks.ml
index 1e37891c..6a04ed1d 100644
--- a/src/clocks.ml
+++ b/src/clocks.ml
@@ -98,7 +98,9 @@ let rec print_ck_long fmt ck =
| Carrow (ck1, ck2) ->
fprintf fmt "%a -> %a" print_ck_long ck1 print_ck_long ck2
| Ctuple cklist ->
- fprintf fmt "(%a)"
+ fprintf
+ fmt
+ "(%a)"
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt " * ")
print_ck_long)
@@ -222,8 +224,10 @@ let clock_current ck =
| Con (ck', _, _) ->
ck'
| _ ->
- Format.eprintf "internal error: Clocks.clock_current %a@."
- print_ck_long (repr ck);
+ Format.eprintf
+ "internal error: Clocks.clock_current %a@."
+ print_ck_long
+ (repr ck);
assert false)
(clock_list_of_clock ck))
@@ -362,7 +366,9 @@ let pp fmt ck =
| Carrow (ck1, ck2) ->
fprintf fmt "%a -> %a" aux ck1 aux ck2
| Ctuple cklist ->
- fprintf fmt "(%a)"
+ fprintf
+ fmt
+ "(%a)"
(pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt " * ") aux)
cklist
| Con (ck, c, l) ->
@@ -400,8 +406,13 @@ let pp_error fmt = function
reset_names ();
fprintf fmt "Expected clock %a, got clock %a@." pp ck1 pp ck2
| Carrier_mismatch (cr1, cr2) ->
- fprintf fmt "Name clash. Expected clock %a, got clock %a@." print_carrier
- cr1 print_carrier cr2
+ fprintf
+ fmt
+ "Name clash. Expected clock %a, got clock %a@."
+ print_carrier
+ cr1
+ print_carrier
+ cr2
| Cannot_be_polymorphic ck ->
reset_names ();
fprintf fmt "The main node cannot have a polymorphic clock: %a@." pp ck
@@ -414,15 +425,23 @@ let pp_error fmt = function
| Factor_zero ->
fprintf fmt "Cannot apply clock transformation with factor 0@."
| Carrier_extrusion (ck, cr) ->
- fprintf fmt
+ fprintf
+ fmt
"This node has clock@.%a@.It is invalid as the carrier %a escapes its \
scope@."
- pp ck print_carrier cr
+ pp
+ ck
+ print_carrier
+ cr
| Clock_extrusion (ck_node, ck) ->
- fprintf fmt
+ fprintf
+ fmt
"This node has clock@.%a@.It is invalid as the clock %a escapes its \
scope@."
- pp ck_node pp ck
+ pp
+ ck_node
+ pp
+ ck
let const_of_carrier cr =
match (carrier_repr cr).carrier_desc with
diff --git a/src/compiler_common.ml b/src/compiler_common.ml
index ce29bbdb..89a68947 100644
--- a/src/compiler_common.ml
+++ b/src/compiler_common.ml
@@ -75,7 +75,11 @@ let check_stateless_decls decls =
fprintf fmt "@ .. checking stateless/stateful status@ ");
try Stateless.check_prog decls
with Stateless.Error (loc, err) as exc ->
- eprintf "Stateless status error: %a%a@." Stateless.pp_error err Location.pp
+ eprintf
+ "Stateless status error: %a%a@."
+ Stateless.pp_error
+ err
+ Location.pp
loc;
raise exc
@@ -83,7 +87,11 @@ let force_stateful_decls decls =
Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. forcing stateful status@ ");
try Stateless.force_prog decls
with Stateless.Error (loc, err) as exc ->
- eprintf "Stateless status error: %a%a@." Stateless.pp_error err Location.pp
+ eprintf
+ "Stateless status error: %a%a@."
+ Stateless.pp_error
+ err
+ Location.pp
loc;
raise exc
@@ -143,7 +151,9 @@ let check_compatibility (_, computed_types_env, computed_clocks_env)
Typing.check_env_compat header declared_types_env computed_types_env;
(* checking clocks compatibility with computed clocks*)
- Clock_calculus.check_env_compat header declared_clocks_env
+ Clock_calculus.check_env_compat
+ header
+ declared_clocks_env
computed_clocks_env;
(* checking stateless status compatibility *)
@@ -153,19 +163,28 @@ let check_compatibility (_, computed_types_env, computed_clocks_env)
eprintf
"Type mismatch between computed type and declared type in lustre \
interface file: %a%a@."
- Types.pp_error err Location.pp loc;
+ Types.pp_error
+ err
+ Location.pp
+ loc;
raise exc
| Clocks.Error (loc, err) as exc ->
eprintf
"Clock mismatch between computed clock and declared clock in lustre \
interface file: %a%a@."
- Clocks.pp_error err Location.pp loc;
+ Clocks.pp_error
+ err
+ Location.pp
+ loc;
raise exc
| Stateless.Error (loc, err) as exc ->
eprintf
"Stateless status mismatch between defined status and declared status in \
lustre interface file: %a%a@."
- Stateless.pp_error err Location.pp loc;
+ Stateless.pp_error
+ err
+ Location.pp
+ loc;
raise exc
(* Process each node/imported node and introduce the associated contract node *)
@@ -202,9 +221,11 @@ let resolve_contracts prog =
(imp_c.imports = [] && imp_c.locals = []
&& imp_c.consts = [] && imp_c.stmts = [])
then (
- Format.eprintf "Invalid processed contract: %i %i %i %i@.@?"
+ Format.eprintf
+ "Invalid processed contract: %i %i %i %i@.@?"
(List.length imp_c.imports)
- (List.length imp_c.locals) (List.length imp_c.consts)
+ (List.length imp_c.locals)
+ (List.length imp_c.consts)
(List.length imp_c.stmts);
assert false (* should be processed *))
in
@@ -212,7 +233,8 @@ let resolve_contracts prog =
let imp_nd =
rename_node
(fun x -> x (* not changing node names *))
- name_prefix imp_nd
+ name_prefix
+ imp_nd
in
let imp_in = imp_nd.node_inputs in
let imp_out = imp_nd.node_outputs in
@@ -288,7 +310,10 @@ let resolve_contracts prog =
in
let new_nd_id = mk_new_name used (id ^ "_coco") in
let new_nd =
- mktop_decl c.spec_loc top.top_decl_owner top.top_decl_itf
+ mktop_decl
+ c.spec_loc
+ top.top_decl_owner
+ top.top_decl_itf
(Node
{
node_id = new_nd_id;
@@ -373,7 +398,8 @@ let resolve_contracts prog =
{ top with top_decl_desc = ImportedNode ind } :: accu_nodes ))
| _ ->
accu_contracts, top :: accu_nodes)
- ([], []) prog
+ ([], [])
+ prog
in
List.rev new_contracts @ List.rev prog
diff --git a/src/compiler_stages.ml b/src/compiler_stages.ml
index 93092726..01ae12b1 100644
--- a/src/compiler_stages.ml
+++ b/src/compiler_stages.ml
@@ -33,10 +33,12 @@ let compile_source_to_header prog computed_types_env computed_clocks_env dirname
then (
Log.report ~level:1 (fun fmt ->
fprintf fmt "@ .. generating compiled header file %s@," header_name);
- Lusic.write_lusic from_lusi
+ Lusic.write_lusic
+ from_lusi
(* is it a lusi file ? *)
(if from_lusi then prog else Lusic.extract_header dirname basename prog)
- destname lusic_ext;
+ destname
+ lusic_ext;
generate_c_header := !Options.output = Options.OutC)
else (
(* Lusic exists and is usable. Checking compatibility *)
@@ -60,7 +62,10 @@ let stage1 params prog dirname basename extension =
(* Removing automata *)
let prog = expand_automata prog in
Log.report ~level:4 (fun fmt ->
- fprintf fmt "@[<v 2>.. after automata expansion:@ %a@]@ " Printers.pp_prog
+ fprintf
+ fmt
+ "@[<v 2>.. after automata expansion:@ %a@]@ "
+ Printers.pp_prog
prog
(* Utils.Format.pp_print_nothing () *));
@@ -81,8 +86,11 @@ let stage1 params prog dirname basename extension =
let prog = resolve_contracts prog in
let prog = SortProg.sort prog in
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt "@ @[<v 2>.. contracts resolved:@ %a@ @]@ "
- Printers.pp_prog prog);
+ Format.fprintf
+ fmt
+ "@ @[<v 2>.. contracts resolved:@ %a@ @]@ "
+ Printers.pp_prog
+ prog);
(* Consolidating main node *)
let _ =
@@ -93,7 +101,9 @@ let stage1 params prog dirname basename extension =
Global.main_node := main_node;
try ignore (Corelang.node_from_name main_node)
with Not_found ->
- Format.eprintf "Code generation error: %a@." Error.pp
+ Format.eprintf
+ "Code generation error: %a@."
+ Error.pp
Error.Main_not_found;
raise (Error.Error (Location.dummy, Error.Main_not_found)))
in
@@ -184,8 +194,13 @@ let stage1 params prog dirname basename extension =
(* If compiling a lusi, generate the lusic. If this is a lus file, Check the
existence of a lusi (Lustre Interface file) *)
if !Options.compile_header then
- compile_source_to_header prog !Global.type_env !Global.clock_env dirname
- basename extension;
+ compile_source_to_header
+ prog
+ !Global.type_env
+ !Global.clock_env
+ dirname
+ basename
+ extension;
let prog =
if !Options.mpfr then (
@@ -241,8 +256,11 @@ let stage2 params prog =
Log.report ~level:1 (fun fmt -> fprintf fmt "@]");
Log.report ~level:3 (fun fmt ->
- fprintf fmt "@ @[<v 2>.. generated machines (unoptimized):@ %a@]@ "
- Machine_code_common.pp_machines machine_code);
+ fprintf
+ fmt
+ "@ @[<v 2>.. generated machines (unoptimized):@ %a@]@ "
+ Machine_code_common.pp_machines
+ machine_code);
(* Optimize machine code *)
Optimize_machine.optimize params prog node_schs machine_code
@@ -254,9 +272,13 @@ let stage3 prog machine_code dependencies basename extension =
match !output, extension with
| OutC, ".lus" ->
Log.report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,");
- C_backend.translate_to_c !generate_c_header
+ C_backend.translate_to_c
+ !generate_c_header
(* alloc_header_file source_lib_file source_main_file makefile_file *)
- basename prog machine_code dependencies
+ basename
+ prog
+ machine_code
+ dependencies
(* | "acsl", ".lus" -> begin Log.report ~level:1 (fun fmt -> fprintf fmt "..
ACSL annotations generation@,"); ACSL_backend.translate_to_acsl (*
alloc_header_file source_lib_file source_main_file makefile_file *)
@@ -276,7 +298,8 @@ let stage3 prog machine_code dependencies basename extension =
machine_code;*)
| OutAda, _ ->
Log.report ~level:1 (fun fmt -> fprintf fmt ".. Ada code generation@.");
- Ada_backend.translate_to_ada basename
+ Ada_backend.translate_to_ada
+ basename
(Machine_code_common.arrow_machine :: machine_code)
| OutHorn, _ ->
let destname = !Options.dest_dir ^ "/" ^ basename in
@@ -285,7 +308,9 @@ let stage3 prog machine_code dependencies basename extension =
let source_out = open_out source_file in
let fmt = formatter_of_out_channel source_out in
Log.report ~level:1 (fun fmt -> fprintf fmt ".. hornification@,");
- Horn_backend.translate fmt prog
+ Horn_backend.translate
+ fmt
+ prog
(Machine_code_common.arrow_machine :: machine_code);
(* Tracability file if option is activated *)
if !Options.traces then (
diff --git a/src/corelang.ml b/src/corelang.ml
index d8a00ec0..b20dd867 100644
--- a/src/corelang.ml
+++ b/src/corelang.ml
@@ -303,18 +303,22 @@ let (node_table : (ident, top_decl) Hashtbl.t) = Hashtbl.create 30
let consts_table = Hashtbl.create 30
-let print_node_table fmt () =
+let pp_node_table fmt () =
Format.fprintf fmt "{ /* node table */@.";
Hashtbl.iter
(fun id nd -> Format.fprintf fmt "%s |-> %a" id Printers.pp_short_decl nd)
node_table;
Format.fprintf fmt "}@."
-let print_consts_table fmt () =
+let pp_consts_table fmt () =
Format.fprintf fmt "{ /* consts table */@.";
Hashtbl.iter
(fun id const ->
- Format.fprintf fmt "%s |-> %a" id Printers.pp_const_decl
+ Format.fprintf
+ fmt
+ "%s |-> %a"
+ id
+ Printers.pp_const_decl
(const_of_top const))
consts_table;
Format.fprintf fmt "}@."
@@ -383,7 +387,8 @@ let top_real_type =
mktop (TypeDef { tydef_id = "real"; tydef_desc = Tydec_real })
let type_table =
- Utils.create_hashtable 20
+ Utils.create_hashtable
+ 20
[
Tydec_int, top_int_type;
Tydec_bool, top_bool_type;
@@ -391,12 +396,17 @@ let type_table =
Tydec_real, top_real_type;
]
-let print_type_table fmt () =
+let pp_type_table fmt () =
Format.fprintf fmt "{ /* type table */@.";
Hashtbl.iter
(fun tydec tdef ->
- Format.fprintf fmt "%a |-> %a" Printers.pp_var_type_dec_desc tydec
- Printers.pp_typedef (typedef_of_top tdef))
+ Format.fprintf
+ fmt
+ "%a |-> %a"
+ Printers.pp_var_type_dec_desc
+ tydec
+ Printers.pp_typedef
+ (typedef_of_top tdef))
type_table;
Format.fprintf fmt "}@."
@@ -507,7 +517,8 @@ let const_impl c1 c2 =
(* To guarantee uniqueness of tags in enum types *)
let tag_table =
- Utils.create_hashtable 20
+ Utils.create_hashtable
+ 20
[ tag_true, top_bool_type; tag_false, top_bool_type ]
(* To guarantee uniqueness of fields in struct types *)
@@ -613,10 +624,12 @@ let rec expr_of_dimension dim =
| Dident id ->
mkexpr dim.dim_loc (Expr_ident id)
| Dite (c, t, e) ->
- mkexpr dim.dim_loc
+ mkexpr
+ dim.dim_loc
(Expr_ite (expr_of_dimension c, expr_of_dimension t, expr_of_dimension e))
| Dappl (id, args) ->
- mkexpr dim.dim_loc
+ mkexpr
+ dim.dim_loc
(Expr_appl
( id,
expr_of_expr_list dim.dim_loc (List.map expr_of_dimension args),
@@ -624,8 +637,10 @@ let rec expr_of_dimension dim =
| Dlink dim' ->
expr_of_dimension dim'
| Dvar | Dunivar ->
- Format.eprintf "internal error: Corelang.expr_of_dimension %a@."
- Dimension.pp dim;
+ Format.eprintf
+ "internal error: Corelang.expr_of_dimension %a@."
+ Dimension.pp
+ dim;
assert false
in
{ expr with expr_type = Types.new_ty Types.type_int }
@@ -654,10 +669,15 @@ let rec dimension_of_expr expr =
Types.get_static_value (Env.lookup_value Basic_library.type_env f)
in
if k = None then raise InvalidDimension;
- mkdim_appl expr.expr_loc f
+ mkdim_appl
+ expr.expr_loc
+ f
(List.map dimension_of_expr (expr_list_of_expr args))
| Expr_ite (i, t, e) ->
- mkdim_ite expr.expr_loc (dimension_of_expr i) (dimension_of_expr t)
+ mkdim_ite
+ expr.expr_loc
+ (dimension_of_expr i)
+ (dimension_of_expr t)
(dimension_of_expr e)
| _ ->
raise InvalidDimension
@@ -673,7 +693,8 @@ let rec is_eq_const c1 c2 =
List.length lcl1 = List.length lcl2
&& List.for_all2
(fun (l1, c1) (l2, c2) -> l1 = l2 && is_eq_const c1 c2)
- lcl1 lcl2
+ lcl1
+ lcl2
| _ ->
c1 = c2
@@ -702,7 +723,8 @@ let rec is_eq_expr e1 e2 =
i = i'
&& List.for_all2
(fun (t, h) (t', h') -> t = t' && is_eq_expr h h')
- (sort_handlers hl) (sort_handlers hl')
+ (sort_handlers hl)
+ (sort_handlers hl')
| Expr_appl (i, e, r), Expr_appl (i', e', r') ->
i = i' && r = r' && is_eq_expr e e'
| Expr_power (e1, i1), Expr_power (e2, i2)
@@ -736,7 +758,8 @@ let get_node_eqs =
eq :: res_eq, res_aut
| Aut aut ->
res_eq, aut :: res_aut)
- stmts ([], [])
+ stmts
+ ([], [])
in
let table_eqs = Hashtbl.create 23 in
fun nd ->
@@ -762,7 +785,8 @@ let get_nodes prog =
decl :: nodes
| Const _ | ImportedNode _ | Include _ | Open _ | TypeDef _ ->
nodes)
- [] prog
+ []
+ prog
|> List.rev
let get_imported_nodes prog =
@@ -773,7 +797,8 @@ let get_imported_nodes prog =
decl :: nodes
| Const _ | Node _ | Include _ | Open _ | TypeDef _ ->
nodes)
- [] prog
+ []
+ prog
let get_consts prog =
List.fold_right
@@ -783,7 +808,8 @@ let get_consts prog =
decl :: consts
| Node _ | ImportedNode _ | Include _ | Open _ | TypeDef _ ->
consts)
- prog []
+ prog
+ []
let get_typedefs prog =
List.fold_right
@@ -793,7 +819,8 @@ let get_typedefs prog =
decl :: types
| Node _ | ImportedNode _ | Include _ | Open _ | Const _ ->
types)
- prog []
+ prog
+ []
let get_dependencies prog =
List.fold_right
@@ -803,7 +830,8 @@ let get_dependencies prog =
decl :: deps
| Node _ | ImportedNode _ | TypeDef _ | Include _ | Const _ ->
deps)
- prog []
+ prog
+ []
let get_node_interface nd =
{
@@ -823,7 +851,9 @@ let get_node_interface nd =
(* Renaming / Copying *)
let copy_var_decl vdecl =
- mkvar_decl vdecl.var_loc ~orig:vdecl.var_orig
+ mkvar_decl
+ vdecl.var_loc
+ ~orig:vdecl.var_orig
( vdecl.var_id,
vdecl.var_dec_type,
vdecl.var_dec_clock,
@@ -875,7 +905,7 @@ let rename_carrier rename cck =
| _ ->
cck
-(*Format.eprintf "Types.rename_static %a = %a@." print_ty ty print_ty res; res*)
+(*Format.eprintf "Types.rename_static %a = %a@." pp ty pp res; res*)
(* applies the renaming function [fvar] to all variables of expression [expr] *)
(* let rec expr_replace_var fvar expr = *)
@@ -1114,7 +1144,8 @@ let rename_prog f_node f_var f_const prog =
| ImportedNode _ | Include _ | Open _ ->
top)
:: accu)
- [] prog)
+ []
+ prog)
(* Applies the renaming function [fvar] to every rhs only when the corresponding
lhs satisfies predicate [pvar] *)
@@ -1175,11 +1206,11 @@ let pp_decl_type fmt tdecl =
| Node nd ->
fprintf fmt "%s: " nd.node_id;
Utils.reset_names ();
- fprintf fmt "%a" Types.print_ty nd.node_type
+ fprintf fmt "%a" Types.pp nd.node_type
| ImportedNode ind ->
fprintf fmt "%s: " ind.nodei_id;
Utils.reset_names ();
- fprintf fmt "%a" Types.print_ty ind.nodei_type
+ fprintf fmt "%a" Types.pp ind.nodei_type
| Const _ | Include _ | Open _ | TypeDef _ ->
()
@@ -1210,7 +1241,8 @@ let vdecls_of_typ_ck cpt ty =
(fun _ ->
incr cpt;
let name = sprintf "_var_%d" !cpt in
- mkvar_decl loc
+ mkvar_decl
+ loc
(name, mktyp loc Tydec_any, mkclock loc Ckdec_any, false, None, None))
(Types.type_list_of_type ty)
@@ -1336,7 +1368,8 @@ let rec get_expr_calls nodes e =
| Expr_tuple el | Expr_array el ->
List.fold_left
(fun accu e -> Utils.ISet.union accu (get_calls e))
- Utils.ISet.empty el
+ Utils.ISet.empty
+ el
| Expr_pre e1 | Expr_when (e1, _, _) | Expr_access (e1, _) | Expr_power (e1, _)
->
get_calls e1
@@ -1349,7 +1382,8 @@ let rec get_expr_calls nodes e =
| Expr_merge (_, hl) ->
List.fold_left
(fun accu (_, h) -> Utils.ISet.union accu (get_calls h))
- Utils.ISet.empty hl
+ Utils.ISet.empty
+ hl
| Expr_appl (i, e', _) ->
if Basic_library.is_expr_internal_fun e then get_calls e'
else
@@ -1375,23 +1409,27 @@ and get_aut_handler_calls nodes h =
Utils.ISet.union (get_eq_calls nodes eq) accu
| Aut aut' ->
Utils.ISet.union (get_aut_calls nodes aut') accu)
- Utils.ISet.empty h.hand_stmts
+ Utils.ISet.empty
+ h.hand_stmts
and get_aut_calls nodes aut =
List.fold_left
(fun accu h -> Utils.ISet.union (get_aut_handler_calls nodes h) accu)
- Utils.ISet.empty aut.aut_handlers
+ Utils.ISet.empty
+ aut.aut_handlers
and get_node_calls nodes node =
let eqs, auts = get_node_eqs node in
let aut_calls =
List.fold_left
(fun accu aut -> Utils.ISet.union (get_aut_calls nodes aut) accu)
- Utils.ISet.empty auts
+ Utils.ISet.empty
+ auts
in
List.fold_left
(fun accu eq -> Utils.ISet.union (get_eq_calls nodes eq) accu)
- aut_calls eqs
+ aut_calls
+ eqs
let get_expr_vars e =
let rec get_expr_vars vars e = get_expr_desc_vars vars e.expr_desc
@@ -1418,7 +1456,8 @@ let get_expr_vars e =
| Expr_merge (c, hl) ->
List.fold_left
(fun vars (_, h) -> get_expr_vars vars h)
- (Utils.ISet.add c vars) hl
+ (Utils.ISet.add c vars)
+ hl
| Expr_appl (_, arg, None) ->
get_expr_vars vars arg
| Expr_appl (_, arg, Some r) ->
@@ -1509,9 +1548,12 @@ let find_eq xl eqs =
let rec aux accu eqs =
match eqs with
| [] ->
- Format.eprintf "Looking for variables %a in the following equations@.%a@."
+ Format.eprintf
+ "Looking for variables %a in the following equations@.%a@."
(pp_comma_list (fun fmt v -> Format.fprintf fmt "%s" v))
- xl Printers.pp_node_eqs eqs;
+ xl
+ Printers.pp_node_eqs
+ eqs;
assert false
| hd :: tl ->
if List.exists (fun x -> List.mem x hd.eq_lhs) xl then hd, accu @ tl
@@ -1532,7 +1574,8 @@ let get_node name prog =
if nd.node_id = name then Some nd else res
| _ ->
None)
- None prog
+ None
+ prog
in
try Utils.desome node_opt with Utils.DeSome -> raise Not_found
diff --git a/src/corelang.mli b/src/corelang.mli
index 48f46d76..2bd3923a 100644
--- a/src/corelang.mli
+++ b/src/corelang.mli
@@ -85,7 +85,7 @@ val update_instr_desc :
Machine_code_types.instr_t
(*val node_table : (ident, top_decl) Hashtbl.t*)
-val print_node_table : Format.formatter -> unit -> unit
+val pp_node_table : Format.formatter -> unit -> unit
val node_name : top_decl -> ident
@@ -107,11 +107,11 @@ val get_node_contract : node_desc -> contract_desc
val consts_table : (ident, top_decl) Hashtbl.t
-val print_consts_table : Format.formatter -> unit -> unit
+val pp_consts_table : Format.formatter -> unit -> unit
val type_table : (type_dec_desc, top_decl) Hashtbl.t
-val print_type_table : Format.formatter -> unit -> unit
+val pp_type_table : Format.formatter -> unit -> unit
val is_clock_dec_type : type_dec_desc -> bool
diff --git a/src/error.ml b/src/error.ml
index fd35e33a..d225faaa 100644
--- a/src/error.ml
+++ b/src/error.ml
@@ -37,10 +37,14 @@ let return_code kind =
let pp fmt = function
| Main_not_found ->
- fprintf fmt "Could not find the definition of main node %s.@."
+ fprintf
+ fmt
+ "Could not find the definition of main node %s.@."
!Global.main_node
| Main_wrong_kind ->
- fprintf fmt "Node %s does not correspond to a valid main node definition.@."
+ fprintf
+ fmt
+ "Node %s does not correspond to a valid main node definition.@."
!Global.main_node
| No_main_specified ->
fprintf fmt "No main node specified (use -node option)@."
@@ -49,12 +53,14 @@ let pp fmt = function
| Already_bound_symbol sym ->
fprintf fmt "%s is already defined.@." sym
| Unknown_library sym ->
- fprintf fmt
+ fprintf
+ fmt
"impossible to load library %s.lusic.@.Please compile the corresponding \
interface or source file.@."
sym
| Wrong_number sym ->
- fprintf fmt
+ fprintf
+ fmt
"library %s.lusic has a different version number and may crash \
compiler.@.Please recompile the corresponding interface or source \
file.@."
diff --git a/src/features/machine_types/machine_types.ml b/src/features/machine_types/machine_types.ml
index c5e9d7a5..57745ad0 100644
--- a/src/features/machine_types/machine_types.ml
+++ b/src/features/machine_types/machine_types.ml
@@ -34,7 +34,7 @@ open Lustre_types
let is_active = false
-let keyword = [ "machine_types" ]
+let keywords = [ "machine_types" ]
module MT = struct
type int_typ =
@@ -221,7 +221,7 @@ module ConvTypes = struct
else if Types.BasicT.is_real_type b then MTypes.type_real
else if Types.BasicT.is_bool_type b then MTypes.type_bool
else (
- Format.eprintf "importing %a with issues!@.@?" Types.print_ty main_typ;
+ Format.eprintf "importing %a with issues!@.@?" Types.pp main_typ;
assert false)
in
map_type_basic import_basic main_typ
@@ -272,7 +272,10 @@ module ConvTypes = struct
Format.eprintf
"unhandled basic mtype is %a. Issues while dealing with basic type \
%a@.@?"
- MTypes.print_ty machine_type MTypes.BasicT.pp b;
+ MTypes.pp
+ machine_type
+ MTypes.BasicT.pp
+ b;
assert false)
in
map_mtype_basic export_basic machine_type
@@ -294,7 +297,7 @@ let pp_table fmt =
Format.fprintf fmt "@[<v 0>[";
Hashtbl.iter
(fun v typ ->
- Format.fprintf fmt "%a -> %a,@ " Printers.pp_var v MTypes.print_ty typ)
+ Format.fprintf fmt "%a -> %a,@ " Printers.pp_var v MTypes.pp typ)
machine_type_table;
Format.fprintf fmt "@]"
@@ -320,28 +323,29 @@ let is_exportable v =
(* could depend on the actual computed type *)
let type_name typ =
- MTypes.print_ty Format.str_formatter typ;
+ MTypes.pp Format.str_formatter typ;
Format.flush_str_formatter ()
let pp_var_type fmt v =
let typ = get_specified_type v in
- MTypes.print_ty fmt typ
+ MTypes.pp fmt typ
let pp_c_var_type fmt v =
let typ = get_specified_type v in
- MTypes.print_ty_param MT.pp_c fmt typ
+ MTypes.pp_ty_param MT.pp_c fmt typ
(************** Checking types ******************)
let erroneous_annotation loc =
- Format.eprintf "Invalid annotation for machine_type at loc %a@." Location.pp
+ Format.eprintf
+ "Invalid annotation for machine_type at loc %a@."
+ Location.pp
loc;
assert false
let valid_subtype subtype typ =
let mismatch subtyp typ =
- Format.eprintf "Subtype mismatch %a vs %a@." MTypes.print_ty subtyp
- Types.print_ty typ;
+ Format.eprintf "Subtype mismatch %a vs %a@." MTypes.pp subtyp Types.pp typ;
false
in
match (MTypes.dynamic_type subtype).MTypes.tdesc with
@@ -396,7 +400,7 @@ let register_node vars annots =
let annl = annot.annots in
List.fold_left
(fun accu (kwd, value) ->
- if kwd = keyword then
+ if kwd = keywords then
let expr = value.eexpr_qfexpr in
match Corelang.expr_list_of_expr expr with
| [ var_id; type_name ] -> (
@@ -404,9 +408,12 @@ let register_node vars annots =
| Expr_ident var_id, Expr_const (Const_string type_name) ->
let var = List.find (fun v -> v.var_id = var_id) vars in
Log.report ~level:2 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"Recorded type %s for variable %a (parent node is %s)@ "
- type_name Printers.pp_var var
+ type_name
+ Printers.pp_var
+ var
(match var.var_parent_nodeid with
| Some id ->
id
@@ -420,8 +427,10 @@ let register_node vars annots =
| _ ->
erroneous_annotation expr.expr_loc
else accu)
- accu annl)
- [] annots
+ accu
+ annl)
+ []
+ annots
let check_node nd vars =
(* TODO check that all access to vars are valid *)
@@ -441,7 +450,8 @@ let load prog =
let init_env =
Env.fold
(fun id typ env -> Env.add_value env id (ConvTypes.import typ))
- Basic_library.type_env Env.initial
+ Basic_library.type_env
+ Env.initial
in
let env =
List.fold_left
@@ -459,7 +469,7 @@ let load prog =
let ty_node = MTypes.new_ty (MTypes.Tarrow (ty_ins, ty_outs)) in
Typing.generalize ty_node;
let env = Env.add_value type_env nd.node_id ty_node in
- (* Format.eprintf "Env: %a" (Env.pp_env MTypes.print_ty) env; *)
+ (* Format.eprintf "Env: %a" (Env.pp_env MTypes.pp) env; *)
env
| _ ->
type_env
@@ -467,13 +477,14 @@ let load prog =
(* let vars = ind.nodei_inputs @ ind.nodei_outputs in *)
(* register_node ind.nodei_id vars ind.nodei_annot *)
(* | _ -> () TODO: shall we load something for Open statements? *))
- init_env prog
+ init_env
+ prog
in
typing_env := env
let type_expr (parentid, init_vars) expr =
let init_env = !typing_env in
- (* Format.eprintf "Init env: %a@." (Env.pp_env MTypes.print_ty) init_env; *)
+ (* Format.eprintf "Init env: %a@." (Env.pp_env MTypes.pp) init_env; *)
(* Rebuilding the variables environment from accumulated knowledge *)
let env, vars =
(* First, we add non specified variables *)
@@ -483,7 +494,8 @@ let type_expr (parentid, init_vars) expr =
let env = Env.add_value env v.var_id (ConvTypes.import v.var_type) in
env, v :: vars
else env, vars)
- (init_env, []) init_vars
+ (init_env, [])
+ init_vars
in
(* Then declared ones *)
@@ -496,18 +508,21 @@ let type_expr (parentid, init_vars) expr =
let env = Env.add_value env vdecl.var_id machine_type in
env, vdecl :: vds
else env, vds)
- machine_type_table (env, vars)
+ machine_type_table
+ (env, vars)
in
- (* Format.eprintf "env with local vars: %a@." (Env.pp_env MTypes.print_ty)
- env; *)
+ (* Format.eprintf "env with local vars: %a@." (Env.pp_env MTypes.pp) env; *)
(* Format.eprintf "expr = %a@." Printers.pp_expr expr; *)
(* let res = *)
- Typing.type_expr (env, vars) false (* not in main node *) false
+ Typing.type_expr
+ (env, vars)
+ false
+ (* not in main node *) false
(* no a constant *) expr
(* in *)
-(* Format.eprintf "typing ok = %a@." MTypes.print_ty res; *)
+(* Format.eprintf "typing ok = %a@." MTypes.pp res; *)
(* res *)
(* Typing the expression (vars = expr) in node *)
@@ -517,12 +532,12 @@ let type_def node vars expr =
(* Printers.pp_expr expr *)
(* ; *)
let typ = type_expr node expr in
- (* Format.eprintf "Type is %a. Saving stuff@.@." MTypes.print_ty typ; *)
+ (* Format.eprintf "Type is %a. Saving stuff@.@." MTypes.pp typ; *)
let typ = MTypes.type_list_of_type typ in
List.iter2 register_var vars typ
let has_machine_type () =
- let annl = Annotations.get_expr_annotations keyword in
+ let annl = Annotations.get_expr_annotations keywords in
(* Format.eprintf "has _mchine _type annotations: %i@." (List.length annl); *)
List.length annl > 0
diff --git a/src/features/machine_types/machine_types.mli b/src/features/machine_types/machine_types.mli
new file mode 100644
index 00000000..3301a70b
--- /dev/null
+++ b/src/features/machine_types/machine_types.mli
@@ -0,0 +1,28 @@
+open Utils
+open Format
+open Lustre_types
+
+val is_exportable : var_decl -> bool
+
+val has_machine_type : unit -> bool
+
+val is_specified : var_decl -> bool
+
+val is_active : bool
+
+val pp_var_type : formatter -> var_decl -> unit
+
+val pp_c_var_type : formatter -> var_decl -> unit
+
+val load : program_t -> unit
+
+(* Typing the expression (vars = expr) in node *)
+val type_def : ident * var_decl list -> var_decl list -> expr -> unit
+
+module ConvTypes : Typing.EXPR_TYPE_HUB
+
+val get_specified_type : var_decl -> ConvTypes.type_expr
+
+val type_name : ConvTypes.type_expr -> ident
+
+val keywords : string list
diff --git a/src/inliner.ml b/src/inliner.ml
index f731378f..42dd4de5 100644
--- a/src/inliner.ml
+++ b/src/inliner.ml
@@ -104,7 +104,8 @@ let inline_call node loc uid args reset locals caller =
let rename v =
if v = tag_true || v = tag_false || not (is_node_var node v) then v
else
- Corelang.mk_new_node_name caller
+ Corelang.mk_new_node_name
+ caller
(Format.sprintf "%s_%i_%s" node.node_id uid v)
in
let eqs, auts = get_node_eqs node in
@@ -142,7 +143,8 @@ let inline_call node loc uid args reset locals caller =
in
let rename_var v =
let vdecl =
- Corelang.mkvar_decl v.var_loc
+ Corelang.mkvar_decl
+ v.var_loc
( rename v.var_id,
{
v.var_dec_type with
@@ -199,7 +201,8 @@ let inline_call node loc uid args reset locals caller =
in
let assign_inputs =
Eq
- (mkeq loc
+ (mkeq
+ loc
( List.map (fun v -> v.var_id) inputs',
expr_of_expr_list args.expr_loc (List.map snd dynamic_inputs) ))
in
@@ -239,7 +242,8 @@ let rec inline_expr ?(selection_on_annotation = false) expr locals node nodes =
inline_expr e locals node nodes
in
e' :: el_tail, locals', eqs' @ eqs, asserts @ asserts', annots @ annots')
- el ([], locals, [], [], [])
+ el
+ ([], locals, [], [], [])
in
let inline_pair e1 e2 =
let el', l', eqs', asserts', annots' = inline_tuple [ e1; e2 ] in
@@ -529,7 +533,8 @@ let global_inline prog (*type_env clock_env*) =
main_opt, top :: nodes, others
| _ ->
main_opt, nodes, top :: others)
- prog (None, [], [])
+ prog
+ (None, [], [])
in
(* Recursively each call of a node in the top node is replaced *)
@@ -577,12 +582,15 @@ let local_inline prog (* type_env clock_env *) =
let nodes_with_anns =
List.fold_left
(fun accu (k, _) -> ISet.add k accu)
- ISet.empty local_anns
+ ISet.empty
+ local_anns
in
ISet.iter
(fun node_id ->
Log.report ~level:2 (fun fmt ->
- Format.fprintf fmt "Node %s has local expression annotations@ "
+ Format.fprintf
+ fmt
+ "Node %s has local expression annotations@ "
node_id))
nodes_with_anns;
List.fold_right
@@ -590,7 +598,9 @@ let local_inline prog (* type_env clock_env *) =
(match top.top_decl_desc with
| Node nd when ISet.mem nd.node_id nodes_with_anns ->
Log.report ~level:2 (fun fmt ->
- Format.fprintf fmt "[local inline] Processing node %s@ "
+ Format.fprintf
+ fmt
+ "[local inline] Processing node %s@ "
nd.node_id);
let inlined_node =
inline_node ~selection_on_annotation:true nd prog
@@ -602,7 +612,8 @@ let local_inline prog (* type_env clock_env *) =
| _ ->
top)
:: accu)
- prog [])
+ prog
+ [])
else (
Log.report ~level:2 (fun fmt ->
Format.fprintf fmt "No local inline information!@ ");
diff --git a/src/lusic.ml b/src/lusic.ml
index 0cf9d661..8772f93f 100644
--- a/src/lusic.ml
+++ b/src/lusic.ml
@@ -37,7 +37,8 @@ let extract_header dirname basename prog =
header
| Const _ | TypeDef _ | Include _ | Open _ ->
decl :: header)
- prog []
+ prog
+ []
let check_obsolete lusic basename =
if lusic.obsolete then
diff --git a/src/lustre_live.ml b/src/lustre_live.ml
index 913ab994..dd9a00ad 100644
--- a/src/lustre_live.ml
+++ b/src/lustre_live.ml
@@ -67,7 +67,8 @@ let set_live_of nid outputs locals sorted_eqs =
let occ, _ =
List.fold_left
(fun (s, j) eq -> if j <= i then s, j + 1 else occur s eq, j + 1)
- (empty, 0) sorted_eqs
+ (empty, 0)
+ sorted_eqs
in
diff locals occ
in
@@ -83,7 +84,10 @@ let set_live_of nid outputs locals sorted_eqs =
in
Log.report ~level:6 (fun fmt ->
Format.(
- fprintf fmt "Live variables of %s: %a@;@;" nid
+ fprintf
+ fmt
+ "Live variables of %s: %a@;@;"
+ nid
(pp_print_list ~pp_open_box:pp_open_vbox0 (fun fmt (i, l) ->
fprintf fmt "%i: %a" i ISet.pp l))
(Live.bindings l)));
diff --git a/src/machine_code.ml b/src/machine_code.ml
index 3c6ad318..b7c4ac4f 100644
--- a/src/machine_code.ml
+++ b/src/machine_code.ml
@@ -120,8 +120,11 @@ let rec translate_expr env expr =
removed for C or Java backends. *)
Fun ("ite", [ translate_expr g; translate_expr t; translate_expr e ])
| _ ->
- Format.eprintf "Normalization error for backend %t: %a@."
- Options.pp_output Printers.pp_expr expr;
+ Format.eprintf
+ "Normalization error for backend %t: %a@."
+ Options.pp_output
+ Printers.pp_expr
+ expr;
raise NormalizationError
in
mk_val value_desc expr.expr_type
@@ -226,7 +229,9 @@ let reset_instance env i r c =
| Some r ->
let r = translate_guard env r in
let _, inst =
- control_on_clock env c
+ control_on_clock
+ env
+ c
(mk_conditional r [ mkinstr (MSetReset i) ] [ mkinstr (MNoReset i) ])
in
Some r, [ inst ]
@@ -250,7 +255,9 @@ let translate_eq env ctx nd inputs locals outputs i eq =
( Lustre_live.existential_vars id i eq (locals @ outputs),
And
[
- mk_transition ~i:(i - 1) id
+ mk_transition
+ ~i:(i - 1)
+ id
(vdecls_to_vals (inputs @ locals_pi @ outputs_pi));
a;
] ) )
@@ -267,7 +274,9 @@ let translate_eq env ctx nd inputs locals outputs i eq =
(if fst (get_stateless_status_node nd) then []
else [ mk_memory_pack ~i id ])
@ [
- mk_transition ~i id
+ mk_transition
+ ~i
+ id
(vdecls_to_vals (inputs @ locals_i @ outputs_i));
];
}
@@ -334,14 +343,16 @@ let translate_eq env ctx nd inputs locals outputs i eq =
let env_cks =
List.fold_right
(fun arg cks -> arg.expr_clock :: cks)
- el [ eq.eq_rhs.expr_clock ]
+ el
+ [ eq.eq_rhs.expr_clock ]
in
let call_ck =
Clock_calculus.compute_root_clock (Clock_predef.ck_tuple env_cks)
in
let r, reset_inst = reset_instance inst r call_ck in
let ctx =
- ctl ~ck:call_ck
+ ctl
+ ~ck:call_ck
(MStep (var_p, inst, vl))
(mk_memory_pack ~inst (node_name node_f))
(mk_transition ?r ~inst (node_name node_f) (vl @ vdecls_to_vals var_p))
@@ -366,8 +377,10 @@ let translate_eq env ctx nd inputs locals outputs i eq =
let instr, spec = translate_act (var_x, eq.eq_rhs) in
control_on_clock eq.eq_rhs.expr_clock instr True spec ctx
| _ ->
- Format.eprintf "internal error: Machine_code.translate_eq %a@?"
- Printers.pp_node_eq eq;
+ Format.eprintf
+ "internal error: Machine_code.translate_eq %a@?"
+ Printers.pp_node_eq
+ eq;
assert false
let constant_equations locals =
@@ -381,14 +394,16 @@ let constant_equations locals =
}
:: eqs
else eqs)
- [] locals
+ []
+ locals
let translate_eqs env ctx nd inputs locals outputs eqs =
List.fold_left
(fun (ctx, i) eq ->
let ctx = translate_eq env ctx nd inputs locals outputs i eq in
ctx, i + 1)
- (ctx, 1) eqs
+ (ctx, 1)
+ eqs
|> fst
(****************************************************************)
@@ -407,7 +422,9 @@ let process_asserts nd =
let loc = expr.expr_loc in
let var_id = nd.node_id ^ "_assert_" ^ string_of_int i in
let assert_var =
- mkvar_decl loc ~orig:false
+ mkvar_decl
+ loc
+ ~orig:false
(* fresh var *)
( var_id,
mktyp loc Tydec_bool,
@@ -425,7 +442,8 @@ let process_asserts nd =
assert_var :: vars,
eq :: eqlist,
{ expr with expr_desc = Expr_ident var_id } :: assertlist ))
- (1, [], [], []) exprl
+ (1, [], [], [])
+ exprl
in
vars, eql, assertl
@@ -473,7 +491,9 @@ let transition_0 nd =
let transition_toplevel nd i =
let tr =
- mk_transition nd.node_id ~i
+ mk_transition
+ nd.node_id
+ ~i
(vdecls_to_vals (nd.node_inputs @ nd.node_outputs))
in
{
diff --git a/src/machine_code_common.ml b/src/machine_code_common.ml
index 8b652574..420c04f9 100644
--- a/src/machine_code_common.ml
+++ b/src/machine_code_common.ml
@@ -60,7 +60,11 @@ module PrintSpec = struct
in
match p with
| Transition (f, inst, i, vars, _r, _mems, _insts) ->
- fprintf fmt "Transition_%a<%a>%a%a" pp_print_string f
+ fprintf
+ fmt
+ "Transition_%a<%a>%a%a"
+ pp_print_string
+ f
(pp_print_option
~none:(fun fmt () -> pp_print_string fmt "SELF")
pp_print_string)
@@ -70,10 +74,21 @@ module PrintSpec = struct
(pp_print_parenthesized pp_expr)
vars
| Reset (f, inst, r) ->
- fprintf fmt "Reset_%a<%a> on %a" pp_print_string f pp_print_string inst
- (pp_val m) r
+ fprintf
+ fmt
+ "Reset_%a<%a> on %a"
+ pp_print_string
+ f
+ pp_print_string
+ inst
+ (pp_val m)
+ r
| MemoryPack (f, inst, i) ->
- fprintf fmt "MemoryPack_%a<%a>%a" pp_print_string f
+ fprintf
+ fmt
+ "MemoryPack_%a<%a>%a"
+ pp_print_string
+ f
(pp_print_option
~none:(fun fmt () -> pp_print_string fmt "SELF")
pp_print_string)
@@ -101,25 +116,42 @@ module PrintSpec = struct
pp_print_list
~pp_sep:(fun fmt () -> fprintf fmt "@ ∧ ")
(fun fmt spec -> fprintf fmt "@[%a@]" pp_spec spec)
- fmt fs
+ fmt
+ fs
| Or fs ->
pp_print_list
~pp_sep:(fun fmt () -> fprintf fmt "@ ∨ ")
(fun fmt spec -> fprintf fmt "@[%a@]" pp_spec spec)
- fmt fs
+ fmt
+ fs
| Imply (a, b) ->
fprintf fmt "%a@ -> %a" pp_spec a pp_spec b
| Exists (xs, a) ->
- fprintf fmt "@[<hv 2>∃ @[<h>%a,@]@ %a@]"
+ fprintf
+ fmt
+ "@[<hv 2>∃ @[<h>%a,@]@ %a@]"
(pp_comma_list Printers.pp_var)
- xs pp_spec a
+ xs
+ pp_spec
+ a
| Forall (xs, a) ->
- fprintf fmt "@[<hv 2>∀ @[<h>%a,@]@ %a@]"
+ fprintf
+ fmt
+ "@[<hv 2>∀ @[<h>%a,@]@ %a@]"
(pp_comma_list Printers.pp_var)
- xs pp_spec a
+ xs
+ pp_spec
+ a
| Ternary (e, a, b) ->
- fprintf fmt "If %a Then (@[<hov>%a@]) Else (@[<hov>%a@])" pp_expr e
- pp_spec a pp_spec b
+ fprintf
+ fmt
+ "If %a Then (@[<hov>%a@]) Else (@[<hov>%a@])"
+ pp_expr
+ e
+ pp_spec
+ a
+ pp_spec
+ b
| Predicate p ->
pp_predicate m fmt p
| StateVarPack r ->
@@ -135,7 +167,9 @@ let pp_spec m =
| Options.SpecNo ->
pp_print_nothing
| _ ->
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:pp_print_cut
(fun fmt -> fprintf fmt "@[<h>--%@ %a@]" (PrintSpec.pp_spec m))
let rec pp_instr m fmt i =
@@ -155,11 +189,20 @@ let rec pp_instr m fmt i =
| MNoReset i ->
fprintf fmt "noreset %s" i
| MStep (il, i, vl) ->
- fprintf fmt "%a := %s%a" (pp_comma_list pp_vdecl) il i
+ fprintf
+ fmt
+ "%a := %s%a"
+ (pp_comma_list pp_vdecl)
+ il
+ i
(pp_print_parenthesized pp_val)
vl
| MBranch (g, hl) ->
- fprintf fmt "@[<v 2>case(%a) {@,%a@]@,}" pp_val g
+ fprintf
+ fmt
+ "@[<v 2>case(%a) {@,%a@]@,}"
+ pp_val
+ g
(pp_print_list ~pp_open_box:pp_open_vbox0 pp_branch)
hl
| MComment s ->
@@ -179,7 +222,10 @@ let rec pp_instr m fmt i =
pp_spec m fmt i.instr_spec
and pp_branch m fmt (t, h) =
- fprintf fmt "@[<v 2>%s:@,%a@]" t
+ fprintf
+ fmt
+ "@[<v 2>%s:@,%a@]"
+ t
(pp_print_list ~pp_open_box:pp_open_vbox0 (pp_instr m))
h
@@ -204,7 +250,8 @@ let machine_vars m =
m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs @ m.mmemory
let pp_step m fmt s =
- fprintf fmt
+ fprintf
+ fmt
"@[<v>inputs : %a@ outputs: %a@ locals : %a@ checks : %a@ instrs : @[%a@]@ \
asserts : @[%a@]@]@ "
(pp_comma_list Printers.pp_var)
@@ -214,7 +261,9 @@ let pp_step m fmt s =
(pp_comma_list Printers.pp_var)
s.step_locals
(pp_comma_list (fun fmt (_, c) -> pp_val m fmt c))
- s.step_checks (pp_instrs m) s.step_instrs
+ s.step_checks
+ (pp_instrs m)
+ s.step_instrs
(pp_comma_list (pp_val m))
s.step_asserts
@@ -224,10 +273,15 @@ let pp_static_call fmt (node, args) =
let pp_instance fmt (o1, o2) = fprintf fmt "(%s, %a)" o1 pp_static_call o2
let pp_memory_pack m fmt mp =
- fprintf fmt "@[<v 2>MemoryPack_%a<SELF>%a =@ %a@]" pp_print_string
+ fprintf
+ fmt
+ "@[<v 2>MemoryPack_%a<SELF>%a =@ %a@]"
+ pp_print_string
mp.mpname.node_id
(pp_print_option pp_print_int)
- mp.mpindex (PrintSpec.pp_spec m) mp.mpformula
+ mp.mpindex
+ (PrintSpec.pp_spec m)
+ mp.mpformula
let pp_memory_packs m fmt =
match !Options.spec with
@@ -237,12 +291,17 @@ let pp_memory_packs m fmt =
fprintf fmt "@[<v 2>memory_packs:@ %a@]" (pp_print_list (pp_memory_pack m))
let pp_transition m fmt t =
- fprintf fmt "@[<v 2>Transition_%a<SELF>%a%a =@ %a@]" pp_print_string
+ fprintf
+ fmt
+ "@[<v 2>Transition_%a<SELF>%a%a =@ %a@]"
+ pp_print_string
t.tname.node_id
(pp_print_option pp_print_int)
t.tindex
(pp_print_parenthesized pp_vdecl)
- t.tvars (PrintSpec.pp_spec m) t.tformula
+ t.tvars
+ (PrintSpec.pp_spec m)
+ t.tformula
let pp_transitions m fmt =
match !Options.spec with
@@ -252,7 +311,8 @@ let pp_transitions m fmt =
fprintf fmt "@[<v 2>transitions:@ %a@]" (pp_print_list (pp_transition m))
let pp_machine fmt m =
- fprintf fmt
+ fprintf
+ fmt
"@[<v 2>machine %s@ mem : %a@ instances: %a@ init : %a@ const \
: %a@ step :@ @[<v 2>%a@]@ spec : @[<v>%t@ %a@ @ %a@]@ annot \
: @[%a@]@]@ "
@@ -260,7 +320,12 @@ let pp_machine fmt m =
(pp_comma_list Printers.pp_var)
m.mmemory
(pp_comma_list pp_instance)
- m.minstances (pp_instrs m) m.minit (pp_instrs m) m.mconst (pp_step m)
+ m.minstances
+ (pp_instrs m)
+ m.minit
+ (pp_instrs m)
+ m.mconst
+ (pp_step m)
m.mstep
(fun fmt ->
match m.mspec.mnode_spec with
@@ -270,7 +335,9 @@ let pp_machine fmt m =
fprintf fmt "cocospec: %s" id
| Some (Contract spec) ->
Printers.pp_spec fmt spec)
- (pp_memory_packs m) m.mspec.mmemory_packs (pp_transitions m)
+ (pp_memory_packs m)
+ m.mspec.mmemory_packs
+ (pp_transitions m)
m.mspec.mtransitions
(pp_print_list Printers.pp_expr_annot)
m.mannot
@@ -362,12 +429,14 @@ let arrow_machine =
[
mk_conditional
(mk_val (Var var_state) Type_predef.type_bool)
- (List.map mkinstr
+ (List.map
+ mkinstr
[
MStateAssign (var_state, cst false);
MLocalAssign (var_output, mk_val (Var var_input1) t_arg);
])
- (List.map mkinstr
+ (List.map
+ mkinstr
[ MLocalAssign (var_output, mk_val (Var var_input2) t_arg) ]);
];
step_asserts = [];
@@ -425,13 +494,16 @@ let new_instance =
let o =
if Stateless.check_node callee then node_name callee
else
- Printf.sprintf "ni_%d"
+ Printf.sprintf
+ "ni_%d"
(incr cpt;
!cpt)
in
let o =
if !Options.ansi && is_generic_node callee then
- Printf.sprintf "%s_inst_%d" o
+ Printf.sprintf
+ "%s_inst_%d"
+ o
(incr cpt;
!cpt)
else o
@@ -446,12 +518,15 @@ let get_machine_opt machines name =
res
| None ->
if m.mname.node_id = name then Some m else None)
- None machines
+ None
+ machines
let get_machine machines node_name =
try desome (get_machine_opt machines node_name)
with DeSome ->
- eprintf "Unable to find machine %s in machines %a@.@?" node_name
+ eprintf
+ "Unable to find machine %s in machines %a@.@?"
+ node_name
(pp_comma_list (fun fmt m -> pp_print_string fmt m.mname.node_id))
machines;
assert false
diff --git a/src/main_lustre_compiler.ml b/src/main_lustre_compiler.ml
index 52138e89..0c6ce419 100644
--- a/src/main_lustre_compiler.ml
+++ b/src/main_lustre_compiler.ml
@@ -72,8 +72,11 @@ let compile dirname basename extension =
let prog, machine_code = Compiler_stages.stage2 params prog in
Log.report ~level:3 (fun fmt ->
- fprintf fmt "@ @[<v 2>.. Generated machines:@ %a@]"
- Machine_code_common.pp_machines machine_code);
+ fprintf
+ fmt
+ "@ @[<v 2>.. Generated machines:@ %a@]"
+ Machine_code_common.pp_machines
+ machine_code);
if Scopes.Plugin.show_scopes () then (
let all_scopes = Scopes.compute_scopes prog !Options.main_node in
@@ -103,7 +106,8 @@ let anonymous filename =
(fun (ok, ext) ext' ->
if (not ok) && Filename.check_suffix filename ext' then true, ext'
else ok, ext)
- (false, "") extensions
+ (false, "")
+ extensions
in
if ok_ext then (
Options_management.setup ();
diff --git a/src/main_lustre_testgen.ml b/src/main_lustre_testgen.ml
index 1b958e7a..75c1af08 100644
--- a/src/main_lustre_testgen.ml
+++ b/src/main_lustre_testgen.ml
@@ -24,10 +24,17 @@ let pp_trace trace_filename mutation_list =
let trace_file = open_out trace_filename in
let trace_fmt = formatter_of_out_channel trace_file in
Format.(
- fprintf trace_fmt "@[<v 2>{@ %a@ }@]@.@?"
+ fprintf
+ trace_fmt
+ "@[<v 2>{@ %a@ }@]@.@?"
(pp_comma_list (fun fmt (mutation, mutation_loc, mutant_name) ->
- fprintf fmt "\"%s\": { @[<v 0>%a,@ %a@ }@]" mutant_name
- Mutation.pp_directive_json mutation Mutation.pp_loc_json
+ fprintf
+ fmt
+ "\"%s\": { @[<v 0>%a,@ %a@ }@]"
+ mutant_name
+ Mutation.pp_directive_json
+ mutation
+ Mutation.pp_loc_json
mutation_loc))
mutation_list)
@@ -110,14 +117,19 @@ let testgen_source dirname basename extension =
let mutant_out =
try open_out mutant_filename
with Sys_error _ ->
- Format.eprintf "Unable to open file %s for writing.@."
+ Format.eprintf
+ "Unable to open file %s for writing.@."
mutant_filename;
exit 1
in
let mutant_fmt = formatter_of_out_channel mutant_out in
report ~level:1 (fun fmt ->
- fprintf fmt ".. generating mutant %s: %a@,@?" mutant_filename
- Mutation.pp_directive mutation);
+ fprintf
+ fmt
+ ".. generating mutant %s: %a@,@?"
+ mutant_filename
+ Mutation.pp_directive
+ mutation);
Format.fprintf mutant_fmt "%a@." Printers.pp_prog mutant;
mutation, mutation_loc, mutant_basename)
mutants
@@ -144,9 +156,13 @@ let testgen_source dirname basename extension =
let cmake_file = open_out cmakelists in
let cmake_fmt = formatter_of_out_channel cmake_file in
Format.fprintf cmake_fmt "cmake_minimum_required(VERSION 3.5)@.";
- Format.fprintf cmake_fmt "include(\"%s/helpful_functions.cmake\")@."
+ Format.fprintf
+ cmake_fmt
+ "include(\"%s/helpful_functions.cmake\")@."
Version.testgen_path;
- Format.fprintf cmake_fmt "include(\"%s/FindLustre.cmake\")@."
+ Format.fprintf
+ cmake_fmt
+ "include(\"%s/FindLustre.cmake\")@."
Version.testgen_path;
Format.fprintf cmake_fmt "LUSTREFILES(LFILES ${CMAKE_CURRENT_SOURCE_DIR} )@.";
Format.fprintf cmake_fmt "@[<v 2>FOREACH(lus_file ${LFILES})@ ";
@@ -174,7 +190,8 @@ let anonymous filename =
(fun (ok, ext) ext' ->
if (not ok) && Filename.check_suffix filename ext' then true, ext'
else ok, ext)
- (false, "") extensions
+ (false, "")
+ extensions
in
if ok_ext then
let dirname = Filename.dirname filename in
diff --git a/src/main_lustre_verifier.ml b/src/main_lustre_verifier.ml
index 2d2c30ce..8d490b56 100644
--- a/src/main_lustre_verifier.ml
+++ b/src/main_lustre_verifier.ml
@@ -77,7 +77,10 @@ let verify dirname basename extension =
Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
Log.report ~level:3 (fun fmt ->
- fprintf fmt ".. Generated machines:@ %a@ " Machine_code_common.pp_machines
+ fprintf
+ fmt
+ ".. Generated machines:@ %a@ "
+ Machine_code_common.pp_machines
machine_code);
if Scopes.Plugin.show_scopes () then (
@@ -105,7 +108,8 @@ let anonymous filename =
(fun (ok, ext) ext' ->
if (not ok) && Filename.check_suffix filename ext' then true, ext'
else ok, ext)
- (false, "") extensions
+ (false, "")
+ extensions
in
if ok_ext then
let dirname = Filename.dirname filename in
diff --git a/src/modules.ml b/src/modules.ml
index 8ef27827..7b1f4956 100644
--- a/src/modules.ml
+++ b/src/modules.ml
@@ -211,7 +211,9 @@ let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
| Const c ->
get_envs_from_const c (ty_env, ck_env)
| TypeDef _ ->
- List.fold_left get_envs_from_top_decl (ty_env, ck_env)
+ List.fold_left
+ get_envs_from_top_decl
+ (ty_env, ck_env)
(consts_of_enum_type top_decl)
| Include _ | Open _ ->
ty_env, ck_env
@@ -249,7 +251,9 @@ let rec load_rec ~is_header accu program =
List.exists
(fun dep ->
basename
- = name_dependency decl.top_decl_loc (dep.local, dep.name)
+ = name_dependency
+ decl.top_decl_loc
+ (dep.local, dep.name)
".lusic")
accu_dep
then (* Library already imported. Just skip *)
@@ -317,7 +321,8 @@ let rec load_rec ~is_header accu program =
| TypeDef tdef ->
add_type is_header tdef.tydef_id decl;
decl :: accu_prog, accu_dep, typ_env', clk_env')
- accu program
+ accu
+ program
(* Iterates through lusi definitions and records them in the hashtbl. Open
instructions are evaluated and update these hashtbl as well.
@@ -325,7 +330,8 @@ let rec load_rec ~is_header accu program =
let load ~is_header program =
try
let prog, deps, typ_env, clk_env =
- load_rec ~is_header
+ load_rec
+ ~is_header
( [],
(* accumulator for program elements *)
[],
diff --git a/src/mutation.ml b/src/mutation.ml
index b250d156..7f6ab582 100644
--- a/src/mutation.ml
+++ b/src/mutation.ml
@@ -121,7 +121,8 @@ let merge_records records_list =
r1opt
| Some x, Some y ->
Some (x + y))
- r1.nb_op r2.nb_op;
+ r1.nb_op
+ r2.nb_op;
}
in
List.fold_left merge_record empty_records records_list
@@ -459,8 +460,11 @@ let pp_directive_json fmt d =
| Boolexpr _ ->
Format.fprintf fmt "\"mutation\": \"not\""
| Op (o, _, d) ->
- Format.fprintf fmt
- "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d
+ Format.fprintf
+ fmt
+ "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\""
+ o
+ d
| IncrIntCst _ ->
Format.fprintf fmt "\"mutation\": \"cst_incr\""
| DecrIntCst _ ->
@@ -470,9 +474,13 @@ let pp_directive_json fmt d =
let pp_loc_json fmt (n, eqlhs, l) =
Format.(
- fprintf fmt "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\"" n
+ fprintf
+ fmt
+ "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\""
+ n
(pp_comma_list (fun fmt -> fprintf fmt "\"%s\""))
- eqlhs (Location.line_of l))
+ eqlhs
+ (Location.line_of l))
(* XXX: UNUSED *)
(* let fold_mutate_int i =
@@ -632,7 +640,8 @@ let fold_mutate_node nd =
node_stmts =
List.fold_right
(fun stmt res -> fold_mutate_stmt stmt :: res)
- nd.node_stmts [];
+ nd.node_stmts
+ [];
}
in
rename_node rename_app (fun x -> x) nd
@@ -658,8 +667,10 @@ let create_mutant prog directive =
| None, Some mi ->
mi
| _ ->
- Format.eprintf "Failed when creating mutant for directive %a@.@?"
- pp_directive directive;
+ Format.eprintf
+ "Failed when creating mutant for directive %a@.@?"
+ pp_directive
+ directive;
let _ =
match !target with
| Some dir' ->
@@ -792,8 +803,10 @@ let fold_mutate nb prog =
(fun cst_id set ->
IntSet.fold
(fun ith_cst set -> DblIntSet.add (cst_id, ith_cst) set)
- !records.consts set)
- possible_const_id DblIntSet.empty
+ !records.consts
+ set)
+ possible_const_id
+ DblIntSet.empty
in
let create_new_switch registered build =
@@ -865,7 +878,8 @@ let fold_mutate nb prog =
in
let op_mut = op_mutation op in
let new_op =
- List.nth op_mut
+ List.nth
+ op_mut
(try Random.int (List.length op_mut) with _ -> 0)
in
true, Op (op, (try Random.int nb_op with _ -> 0), new_op)
@@ -887,9 +901,11 @@ let fold_mutate nb prog =
let ok, random_mutation = apply_transform transforms in
let stop_process () =
report ~level:1 (fun fmt ->
- fprintf fmt
+ fprintf
+ fmt
"Only %i mutants directives generated out of %i expected@ "
- (nb - rnb) nb);
+ (nb - rnb)
+ nb);
mutants
in
if not ok then stop_process ()
@@ -897,8 +913,11 @@ let fold_mutate nb prog =
try
let new_mutant = find_next_new mutants random_mutation in
report ~level:2 (fun fmt ->
- fprintf fmt " %i mutants directive generated out of %i expected@ "
- (nb - rnb) nb);
+ fprintf
+ fmt
+ " %i mutants directive generated out of %i expected@ "
+ (nb - rnb)
+ nb);
create_mutants_directives (rnb - 1) (new_mutant :: mutants)
with Not_found -> stop_process ()
else create_mutants_directives (rnb - 1) (random_mutation :: mutants)
diff --git a/src/normalization.ml b/src/normalization.ml
index 6b5a86b7..2226e942 100644
--- a/src/normalization.ml
+++ b/src/normalization.ml
@@ -124,7 +124,7 @@ let replace_expr locals expr =
(* IS IT USED ? TODO
(* Create an alias for [expr], if none exists yet *)
let mk_expr_alias (parentid, vars) (defs, vars) expr =
-(*Format.eprintf "mk_expr_alias %a %a %a@." Printers.pp_expr expr Types.print_ty expr.expr_type Clocks.print_ck expr.expr_clock;*)
+(*Format.eprintf "mk_expr_alias %a %a %a@." Printers.pp_expr expr Types.pp expr.expr_type Clocks.pp_ck expr.expr_clock;*)
match get_expr_alias defs expr with
| Some eq ->
let aliases = List.map (fun id -> List.find (fun v -> v.var_id = id) vars) eq.eq_lhs in
@@ -151,7 +151,7 @@ let mk_expr_alias_opt opt norm_ctx (defs, vars) expr =
if !debug then
Log.report ~plugin:"normalization" ~level:2 (fun fmt ->
Format.fprintf fmt "mk_expr_alias_opt %B %a %a %a@." opt
- Printers.pp_expr expr Types.print_ty expr.expr_type Clocks.pp
+ Printers.pp_expr expr Types.pp expr.expr_type Clocks.pp
expr.expr_clock);
match expr.expr_desc with
| Expr_ident _ -> (defs, vars), expr
@@ -171,7 +171,7 @@ let mk_expr_alias_opt opt norm_ctx (defs, vars) expr =
* Format.eprintf "existing defs are: @[[%a@]]@."
* (fprintf_list ~sep:"@ "(fun fmt eq ->
* Format.fprintf fmt "ck:%a isckeq=%b, , iseq=%b, eq=%a"
- * Clocks.print_ck eq.eq_rhs.expr_clock
+ * Clocks.pp_ck eq.eq_rhs.expr_clock
* (Clocks.eq_clock expr.expr_clock eq.eq_rhs.expr_clock)
* (is_eq_expr eq.eq_rhs expr)
* Printers.pp_node_eq eq))
@@ -213,7 +213,7 @@ let mk_dim_alias opt norm_ctx (defs, vars) dim =
let unfold_offsets norm_ctx defvars e offsets =
let add_offset (defvars, e) d =
- (*Format.eprintf "add_offset %a(%a) %a @." Printers.pp_expr e Types.print_ty e.expr_type Dimension.pp_dimension d; *)
+ (*Format.eprintf "add_offset %a(%a) %a @." Printers.pp_expr e Types.pp e.expr_type Dimension.pp_dimension d; *)
let defvars, d =
mk_dim_alias !params.force_alias_internal_fun norm_ctx defvars d
in
@@ -255,7 +255,7 @@ let normalize_list alias norm_ctx offsets norm_element defvars elist =
let rec normalize_expr ?(alias = true) ?(alias_basic = false) norm_ctx offsets
defvars expr =
- (* Format.eprintf "normalize %B %a:%a [%a]@." alias Printers.pp_expr expr Types.print_ty expr.expr_type (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets; *)
+ (* Format.eprintf "normalize %B %a:%a [%a]@." alias Printers.pp_expr expr Types.pp expr.expr_type (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets; *)
match expr.expr_desc with
| Expr_const _ | Expr_ident _ -> unfold_offsets norm_ctx defvars expr offsets
| Expr_array elist ->
@@ -452,7 +452,7 @@ let decouple_outputs norm_ctx defvars eq =
defvars', { eq with eq_lhs = lhs' }
let normalize_eq norm_ctx defvars eq =
- (*Format.eprintf "normalize_eq %a@." Types.print_ty eq.eq_rhs.expr_type;*)
+ (*Format.eprintf "normalize_eq %a@." Types.pp eq.eq_rhs.expr_type;*)
match eq.eq_rhs.expr_desc with
| Expr_pre _ | Expr_fby _ ->
let defvars', eq' = decouple_outputs norm_ctx defvars eq in
@@ -564,9 +564,9 @@ let normalize_pred_eexpr norm_ctx (def, vars) ee =
(*
let env = Typing.type_var_decl [] !Global.type_env xxxx output_var in (* typing the variable *)
- (* Format.eprintf "typing var %s: %a@." output_id Types.print_ty output_var.var_type; *)
+ (* Format.eprintf "typing var %s: %a@." output_id Types.pp output_var.var_type; *)
let env = Typing.type_var_decl_list (vars@node.node_outputs@node.node_inputs) env (vars@node.node_outputs@node.node_inputs) in
- (*Format.eprintf "Env: %a@.@?" (Env.pp_env Types.print_ty) env;*)
+ (*Format.eprintf "Env: %a@.@?" (Env.pp_env Types.pp) env;*)
let undefined_vars = List.fold_left (Typing.type_eq (env, quant_vars@vars) false) todefine defs in
(* check that table is empty *)
if (not (ISet.is_empty undefined_vars)) then
@@ -611,9 +611,9 @@ let normalize_pred_eexpr norm_ctx (def, vars) ee =
try
let env = Typing.type_var_decl_list quant_vars !Global.type_env quant_vars in
let env = Typing.type_var_decl [] env output_var in (* typing the variable *)
- (* Format.eprintf "typing var %s: %a@." output_id Types.print_ty output_var.var_type; *)
+ (* Format.eprintf "typing var %s: %a@." output_id Types.pp output_var.var_type; *)
let env = Typing.type_var_decl_list (vars@node.node_outputs@node.node_inputs) env (vars@node.node_outputs@node.node_inputs) in
- (*Format.eprintf "Env: %a@.@?" (Env.pp_env Types.print_ty) env;*)
+ (*Format.eprintf "Env: %a@.@?" (Env.pp_env Types.pp) env;*)
let undefined_vars = List.fold_left (Typing.type_eq (env, quant_vars@vars) false) todefine defs in
(* check that table is empty *)
if (not (ISet.is_empty undefined_vars)) then
@@ -855,8 +855,8 @@ let normalize_node node =
(expr_of_expr_list loc [ expr_of_vdecl v; typ_as_string ])
in
Annotations.add_expr_ann node.node_id pair.eexpr_tag
- Machine_types.keyword;
- { annots = [ Machine_types.keyword, pair ]; annot_loc = loc }
+ Machine_types.keywords;
+ { annots = [ Machine_types.keywords, pair ]; annot_loc = loc }
:: annots)
else annots)
new_annots new_locals
diff --git a/src/optimize_machine.ml b/src/optimize_machine.ml
index f2a09aa7..7fe096b6 100644
--- a/src/optimize_machine.ml
+++ b/src/optimize_machine.ml
@@ -41,7 +41,8 @@ let rec eliminate m elim instr =
| MStep (il, i, vl) ->
update_instr_desc instr (MStep (il, i, List.map e_expr vl))
| MBranch (g, hl) ->
- update_instr_desc instr
+ update_instr_desc
+ instr
(MBranch
( e_expr g,
List.map (fun (l, il) -> l, List.map (eliminate m elim) il) hl ))
@@ -90,7 +91,8 @@ let unfold_expr_offset m offset expr =
| Field _ ->
Format.eprintf "internal error: not yet implemented !";
assert false)
- expr offset
+ expr
+ offset
let rec simplify_cst_expr m offset typ cst =
match offset, cst with
@@ -101,14 +103,18 @@ let rec simplify_cst_expr m offset typ cst =
simplify_cst_expr m q elt_typ (List.nth cl (Dimension.size_const i))
| Index i :: q, Const_array cl ->
let elt_typ = Types.array_element_type typ in
- unfold_expr_offset m [ Index i ]
+ unfold_expr_offset
+ m
+ [ Index i ]
(mk_val (Array (List.map (simplify_cst_expr m q elt_typ) cl)) typ)
| Field f :: q, Const_struct fl ->
let fld_typ = Types.struct_field_type typ f in
simplify_cst_expr m q fld_typ (List.assoc f fl)
| _ ->
- Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@."
- Printers.pp_const cst;
+ Format.eprintf
+ "internal error: Optimize_machine.simplify_cst_expr %a@."
+ Printers.pp_const
+ cst;
assert false
let simplify_expr_offset m expr =
@@ -133,7 +139,9 @@ let simplify_expr_offset m expr =
| Index i :: q, Array vl when Dimension.is_const i ->
simplify q (List.nth vl (Dimension.size_const i))
| Index i :: q, Array vl ->
- unfold_expr_offset m [ Index i ]
+ unfold_expr_offset
+ m
+ [ Index i ]
(mk_val (Array (List.map (simplify q) vl)) expr.value_type)
(*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr
(Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res)
@@ -156,10 +164,12 @@ let rec simplify_instr_offset m instr =
| MComment _ ->
instr
| MStep (outputs, id, inputs) ->
- update_instr_desc instr
+ update_instr_desc
+ instr
(MStep (outputs, id, List.map (simplify_expr_offset m) inputs))
| MBranch (cond, brl) ->
- update_instr_desc instr
+ update_instr_desc
+ instr
(MBranch
( simplify_expr_offset m cond,
List.map (fun (l, il) -> l, simplify_instrs_offset m il) brl ))
@@ -252,7 +262,8 @@ let rec instrs_unfold m fanin elim instrs =
(* if instr is a simple local assign, then (a) elim is simplified with
it (b) it is stored as the elim set *)
instr_unfold m fanin instrs elim instr)
- (elim, []) instrs
+ (elim, [])
+ instrs
in
elim, List.rev rev_instrs
@@ -264,15 +275,21 @@ and instr_unfold m fanin instrs (elim : (value_t * eq) IMap.t) instr =
| MStep ([ v ], id, vl)
when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
->
- instr_unfold m fanin instrs elim
- (update_instr_desc instr
+ instr_unfold
+ m
+ fanin
+ instrs
+ elim
+ (update_instr_desc
+ instr
(MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)))
| MLocalAssign (v, expr)
when (not (is_clock_dec_type v.var_dec_type.ty_dec_desc))
&& unfoldable_assign fanin v expr ->
(* we don't eliminate clock definitions *)
let new_eq =
- Corelang.mkeq (desome instr.lustre_eq).eq_loc
+ Corelang.mkeq
+ (desome instr.lustre_eq).eq_loc
([ v.var_id ], (desome instr.lustre_eq).eq_rhs)
in
IMap.add v.var_id (expr, new_eq) elim, instrs
@@ -284,7 +301,8 @@ and instr_unfold m fanin instrs (elim : (value_t * eq) IMap.t) instr =
List.fold_right
(fun (h, (e, l)) (elim, branches) ->
merge_elim elim e, (h, l) :: branches)
- elim_branches (elim, [])
+ elim_branches
+ (elim, [])
in
elim, update_instr_desc instr (MBranch (g, branches)) :: instrs
| _ ->
@@ -306,8 +324,12 @@ let static_call_unfold elim (inst, (n, args)) =
and remove simple local assigns *)
let machine_unfold fanin elim machine =
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt "machine_unfold %s %a@ " machine.mname.node_id
- (pp_elim machine) (IMap.map fst elim));
+ Format.fprintf
+ fmt
+ "machine_unfold %s %a@ "
+ machine.mname.node_id
+ (pp_elim machine)
+ (IMap.map fst elim));
let elim_consts, mconst = instrs_unfold machine fanin elim machine.mconst in
let elim_vars, instrs =
instrs_unfold machine fanin elim_consts machine.mstep.step_instrs
@@ -349,7 +371,8 @@ let instr_of_const top_const =
let loc = const.const_loc in
let id = const.const_id in
let vdecl =
- mkvar_decl loc
+ mkvar_decl
+ loc
( id,
mktyp Location.dummy Tydec_any,
mkclock loc Ckdec_any,
@@ -361,7 +384,8 @@ let instr_of_const top_const =
let lustre_eq =
mkeq loc ([ const.const_id ], mkexpr loc (Expr_const const.const_value))
in
- mkinstr ~lustre_eq
+ mkinstr
+ ~lustre_eq
(MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type))
(* We do not perform this optimization on contract nodes since there is not
@@ -382,7 +406,8 @@ let machines_unfold consts node_schs machines =
in
let m, removed_m = machine_unfold fanin elim_consts m in
m :: machines, IMap.add m.mname.node_id removed_m removed)
- machines ([], IMap.empty)
+ machines
+ ([], IMap.empty)
let get_assign_lhs instr =
match get_instr_desc instr with
@@ -466,7 +491,9 @@ let subst_instr m subst instrs instr =
if not (is_memory m v') then
(* We define v' = v. Don't need to update the records. *)
let instr =
- eliminate m subst
+ eliminate
+ m
+ subst
(update_instr_desc instr (mk_assign m instr_v instr'_v))
in
subst, instr :: instrs
@@ -488,7 +515,8 @@ let subst_instr m subst instrs instr =
if ok then instr :: instrs
else if instr = instr' then instrs
else eliminate m subst_v' instr :: instrs ))
- instrs (false, []))
+ instrs
+ (false, []))
in
IMap.add v'.var_id instr_v subst, instr :: instrs'
| _ ->
@@ -511,8 +539,11 @@ let rec instr_cse m (subst, instrs) instr =
| MStep ([ v ], id, vl)
when Basic_library.is_internal_fun id (List.map (fun v -> v.value_type) vl)
->
- instr_cse m (subst, instrs)
- (update_instr_desc instr
+ instr_cse
+ m
+ (subst, instrs)
+ (update_instr_desc
+ instr
(MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)))
| MLocalAssign (v, expr) when is_unfoldable_expr 2 expr ->
IMap.add v.var_id expr subst, instr :: instrs
@@ -684,7 +715,8 @@ let step_replace_var fvar step =
let l' = fvar l in
if List.exists (fun o -> o.var_id = l'.var_id) outputs' then res
else Utils.add_cons l' res)
- [] step.step_locals
+ []
+ step.step_locals
in
{
step with
@@ -737,7 +769,8 @@ and instrs_constant_assign var instrs =
if Disjunction.CISet.mem var (instr_assign Disjunction.CISet.empty i) then
instr_constant_assign var i
else res)
- false instrs
+ false
+ instrs
let rec instr_reduce branches instr1 cont =
match get_instr_desc instr1 with
@@ -746,7 +779,8 @@ let rec instr_reduce branches instr1 cont =
| MStateAssign (_, { value_desc = Cst (Const_tag c); _ }) ->
instr1 :: (List.assoc c branches @ cont)
| MBranch (g, hl) ->
- update_instr_desc instr1
+ update_instr_desc
+ instr1
(MBranch (g, List.map (fun (h, b) -> h, instrs_reduce branches b []) hl))
:: cont
| _ ->
@@ -810,7 +844,8 @@ let elim_prog_variables prog removed_table =
e.expr_loc } in *)
let defs = eq :: accu_defs in
locals, defs)
- nd_elim_map ([], [])
+ nd_elim_map
+ ([], [])
in
let node_locals, node_stmts =
@@ -841,7 +876,8 @@ let elim_prog_variables prog removed_table =
substitute_expr vars_to_replace defs eq.eq_rhs
in
locals, Eq { eq with eq_rhs = eq_rhs' } :: res_stmts))
- nd.node_stmts (nd.node_locals, [])
+ nd.node_stmts
+ (nd.node_locals, [])
in
let nd' = { nd with node_locals; node_stmts } in
{ t with top_decl_desc = Node nd' }
@@ -867,12 +903,15 @@ let optimize params prog node_schs machine_code =
let machine_code =
if !Options.optimization >= 4 (* && !Options.output <> "horn" *) then (
Log.report ~level:1 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"@ @[<v 2>.. machines optimization: sub-expression elimination@ ");
let machine_code = machines_cse machine_code in
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt
- "@[<v 2>.. generated machines (sub-expr elim):@ %a@]@ " pp_machines
+ Format.fprintf
+ fmt
+ "@[<v 2>.. generated machines (sub-expr elim):@ %a@]@ "
+ pp_machines
machine_code);
Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@]");
machine_code)
@@ -885,20 +924,25 @@ let optimize params prog node_schs machine_code =
(*&& !Options.output <> "horn"*)
then (
Log.report ~level:1 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"@ @[<v 2>.. machines optimization: const. inlining (partial eval. \
with const)@ ");
let machine_code, removed_table =
machines_unfold (Corelang.get_consts prog) node_schs machine_code
in
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt "@ Eliminated flows: %a@ "
+ Format.fprintf
+ fmt
+ "@ Eliminated flows: %a@ "
(IMap.pp (fun fmt m -> pp_elim empty_machine fmt (IMap.map fst m)))
removed_table);
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"@ @[<v 2>.. generated machines (const inlining):@ %a@]@ "
- pp_machines machine_code);
+ pp_machines
+ machine_code);
(* If variables were eliminated, relaunch the normalization/machine
generation *)
let prog, machine_code, removed_table =
@@ -928,7 +972,8 @@ let optimize params prog node_schs machine_code =
let machine_code =
if !Options.optimization >= 3 && not (Backends.is_functional ()) then (
Log.report ~level:1 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
".. machines optimization: minimize stack usage by reusing \
variables@,");
let node_schs =
diff --git a/src/options.ml b/src/options.ml
index 10eace28..f843223d 100644
--- a/src/options.ml
+++ b/src/options.ml
@@ -36,7 +36,8 @@ type option_output = OutC | OutAda | OutJava | OutEMF | OutHorn | OutLustre
let output = ref OutC
let pp_output fmt =
- Format.pp_print_string fmt
+ Format.pp_print_string
+ fmt
(match !output with
| OutC ->
"C"
@@ -114,6 +115,9 @@ let al_nb_max = ref 15
(* Printer options *)
let kind2_print = ref false
+(* C main options *)
+let c_main_options = ref false
+
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/options.mli b/src/options.mli
index 9e50c772..a801b8a0 100644
--- a/src/options.mli
+++ b/src/options.mli
@@ -84,3 +84,5 @@ val no_mutation_suffix : bool ref
val compile_header : bool ref
val track_exceptions : bool ref
+
+val c_main_options : bool ref
diff --git a/src/options_management.ml b/src/options_management.ml
index 6339b1ac..79a37000 100644
--- a/src/options_management.ml
+++ b/src/options_management.ml
@@ -17,8 +17,10 @@ let print_version () =
printf
"@[<v>Lustrec compiler, version %s (%s)@,\
Standard lib: %s@,\
- User provided include directory: @[<h>%a@]@]@." Version.number
- Version.codename Version.include_path
+ User provided include directory: @[<h>%a@]@]@."
+ Version.number
+ Version.codename
+ Version.include_path
(pp_print_list ~pp_sep:pp_print_space pp_print_string)
!include_dirs
@@ -47,11 +49,14 @@ let search_lib_path (local, full_file_name) =
| None ->
let path_to_lib = dir ^ "/" ^ full_file_name in
if Sys.file_exists path_to_lib then Some dir else None)
- paths None
+ paths
+ None
in
match name with
| None ->
- Format.eprintf "Unable to find library %s in paths %a@.@?" full_file_name
+ Format.eprintf
+ "Unable to find library %s in paths %a@.@?"
+ full_file_name
(Utils.Format.pp_comma_list Format.pp_print_string)
paths;
raise Not_found
@@ -217,6 +222,9 @@ let lustrec_options =
cpp := true;
static_mem := false),
"generates the mauve code" );
+ ( "-c_main_options",
+ Arg.Set c_main_options,
+ "instrument the main C code with command line options" );
]
let lustret_options =
diff --git a/src/pathConditions.ml b/src/pathConditions.ml
index 1a533203..68d6de05 100644
--- a/src/pathConditions.ml
+++ b/src/pathConditions.ml
@@ -109,7 +109,8 @@ let rec compute_neg_expr cpt_pre (expr : Lustre_types.expr) =
(fun e (vl, el) ->
let vl', e' = compute_neg_expr cpt_pre e in
vl' @ vl, e' :: el)
- l ([], [])
+ l
+ ([], [])
in
match expr.expr_desc with
| Expr_tuple l ->
@@ -126,7 +127,8 @@ let rec compute_neg_expr cpt_pre (expr : Lustre_types.expr) =
{ expr with expr_desc = Expr_ite (i', t', e') }
| _ ->
assert false)
- neg list )
+ neg
+ list )
| Expr_ite (i, t, e) ->
(* We return the guard as a new guard *)
let vl = gen_mcdc_cond_guard i in
@@ -140,7 +142,8 @@ let rec compute_neg_expr cpt_pre (expr : Lustre_types.expr) =
{ expr with expr_desc = Expr_ite (i', t', e') }
| _ ->
assert false)
- neg list )
+ neg
+ list )
| Expr_arrow (e1, e2) ->
let vl1, e1' = compute_neg_expr cpt_pre e1 in
let vl2, e2' = compute_neg_expr cpt_pre e2 in
@@ -152,7 +155,8 @@ let rec compute_neg_expr cpt_pre (expr : Lustre_types.expr) =
{ expr with expr_desc = Expr_arrow (x, y) }
| _ ->
assert false)
- [ e1'; e2' ] [ e1; e2 ] )
+ [ e1'; e2' ]
+ [ e1; e2 ] )
| Expr_pre e ->
let vl, e' = compute_neg_expr (cpt_pre + 1) e in
( vl,
@@ -174,29 +178,37 @@ let rec compute_neg_expr cpt_pre (expr : Lustre_types.expr) =
and gen_mcdc_cond_var v expr =
report ~level:1 (fun fmt ->
- Format.fprintf fmt
- ".. Generating MC/DC cond for boolean flow %s and expression %a@." v
- Printers.pp_expr expr);
+ Format.fprintf
+ fmt
+ ".. Generating MC/DC cond for boolean flow %s and expression %a@."
+ v
+ Printers.pp_expr
+ expr);
let vl, leafs_n_neg_expr = compute_neg_expr 0 expr in
let len = List.length leafs_n_neg_expr in
if len >= 1 then
List.fold_left
(fun accu ((vi, nb_pre), expr_neg_vi) ->
mcdc_var (mk_pre nb_pre vi) len expr expr_neg_vi :: accu)
- vl leafs_n_neg_expr
+ vl
+ leafs_n_neg_expr
else vl
and gen_mcdc_cond_guard expr =
report ~level:1 (fun fmt ->
- Format.fprintf fmt ".. Generating MC/DC cond for guard %a@."
- Printers.pp_expr expr);
+ Format.fprintf
+ fmt
+ ".. Generating MC/DC cond for guard %a@."
+ Printers.pp_expr
+ expr);
let vl, leafs_n_neg_expr = compute_neg_expr 0 expr in
let len = List.length leafs_n_neg_expr in
if len >= 1 then
List.fold_left
(fun accu ((vi, nb_pre), expr_neg_vi) ->
mcdc_var (mk_pre nb_pre vi) len expr expr_neg_vi :: accu)
- vl leafs_n_neg_expr
+ vl
+ leafs_n_neg_expr
else vl
let rec mcdc_expr cpt_pre expr =
@@ -207,7 +219,8 @@ let rec mcdc_expr cpt_pre expr =
(fun e accu_v ->
let vl = mcdc_expr cpt_pre e in
vl @ accu_v)
- l []
+ l
+ []
in
vl
| Expr_ite (i, t, e) ->
@@ -256,7 +269,9 @@ let mcdc_node_eq eq =
(* we don't care about the expression it. We focus on the coverage
expressions in v *)
v @ accu)
- eq.eq_lhs rhs []
+ eq.eq_lhs
+ rhs
+ []
in
vl
| _ ->
@@ -280,7 +295,8 @@ let mcdc_top_decl td =
(fun s accu_v ->
let vl' = mcdc_node_stmt s in
vl' @ accu_v)
- nd.node_stmts []
+ nd.node_stmts
+ []
in
(* We add coverage vars as boolean internal flows. *)
let fresh_cov_defs =
@@ -298,7 +314,8 @@ let mcdc_top_decl td =
Format.fprintf Format.str_formatter "__cov_%i_%i" i nb_total;
let cov_id = Format.flush_str_formatter () in
let cov_var =
- mkvar_decl loc
+ mkvar_decl
+ loc
( cov_id,
mktyp loc Tydec_bool,
mkclock loc Ckdec_any,
@@ -313,7 +330,8 @@ let mcdc_top_decl td =
let fresh_vars, fresh_eqs =
List.fold_right
(fun (v, eq, _, _) (accuv, accueq) -> v :: accuv, eq :: accueq)
- fresh_cov_vars ([], [])
+ fresh_cov_vars
+ ([], [])
in
let fresh_annots =
(* We produce two sets of annotations: PROPERTY ones for kind2, and
@@ -341,7 +359,9 @@ let mcdc_top_decl td =
})
fresh_cov_vars
in
- Format.printf "%i coverage criteria generated for node %s@ " nb_total
+ Format.printf
+ "%i coverage criteria generated for node %s@ "
+ nb_total
nd.node_id;
(* And add them as annotations --%PROPERTY: var TODO *)
{
diff --git a/src/plugins/mpfr/lustrec_mpfr.ml b/src/plugins/mpfr/lustrec_mpfr.ml
index 849faa9a..334886c5 100644
--- a/src/plugins/mpfr/lustrec_mpfr.ml
+++ b/src/plugins/mpfr/lustrec_mpfr.ml
@@ -48,7 +48,14 @@ let unfoldable_value value =
* { e with expr_type = Type_predef.type_real; expr_clock = expr.expr_clock } *)
let pp_inject_real pp_var pp_val fmt (var, value) =
- Format.fprintf fmt "%s(%a, %a, %s);" inject_real_id pp_var var pp_val value
+ Format.fprintf
+ fmt
+ "%s(%a, %a, %s);"
+ inject_real_id
+ pp_var
+ var
+ pp_val
+ value
(mpfr_rnd ())
(* XXX: UNUSED *)
@@ -57,7 +64,14 @@ let pp_inject_real pp_var pp_val fmt (var, value) =
* { e with expr_type = Type_predef.type_real; expr_clock = expr.expr_clock } *)
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
+ 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 ((_, value) as vv) =
@@ -173,7 +187,8 @@ let inject_op id =
let homomorphic_funs =
List.fold_right
(fun id res -> try base_inject_op id :: res with Not_found -> res)
- Basic_library.internal_funs []
+ Basic_library.internal_funs
+ []
let is_homomorphic_fun id = List.mem id homomorphic_funs
@@ -211,7 +226,8 @@ let inject_list alias node inject_element defvars elist =
(fun t (defvars, qlist) ->
let defvars, norm_t = inject_element alias node defvars t in
defvars, norm_t :: qlist)
- elist (defvars, [])
+ elist
+ (defvars, [])
let rec inject_expr ?(alias = true) node defvars expr =
let res =
@@ -285,7 +301,8 @@ and inject_branches node defvars hl =
(fun (t, h) (defvars, norm_q) ->
let defvars, norm_h = inject_expr node defvars h in
defvars, (t, norm_h) :: norm_q)
- hl (defvars, [])
+ hl
+ (defvars, [])
let inject_eq node defvars eq =
let (defs', vars'), norm_rhs =
@@ -329,14 +346,18 @@ let inject_node node =
(fun (vars, def_accu, assert_accu) assert_ ->
let assert_expr = assert_.assert_expr in
let (defs, vars'), expr =
- inject_expr ~alias:false norm_ctx ([], vars)
+ inject_expr
+ ~alias:false
+ norm_ctx
+ ([], vars)
(* defvar only contains vars *)
assert_expr
in
( vars',
defs @ def_accu,
{ assert_ with assert_expr = expr } :: assert_accu ))
- (vars, [], []) node.node_asserts
+ (vars, [], [])
+ node.node_asserts
in
let new_locals = List.filter is_local vars in
(* Compute traceability info: - gather newly bound variables - compute the
diff --git a/src/plugins/plugins.ml b/src/plugins/plugins.ml
index 9b16e882..26d4b064 100644
--- a/src/plugins/plugins.ml
+++ b/src/plugins/plugins.ml
@@ -5,7 +5,8 @@ let () = Sites.Plugins.Plugins.load_all ()
let options () =
List.flatten
- (List.map Options_management.plugin_opt
+ (List.map
+ Options_management.plugin_opt
(List.map
(fun m ->
let module M = (val m : PluginType.S) in
@@ -31,7 +32,8 @@ let refine_machine_code prog machine_code =
(fun accu m ->
let module M = (val m : PluginType.S) in
M.refine_machine_code prog accu)
- machine_code (plugins ())
+ machine_code
+ (plugins ())
let c_backend_main_loop_body_prefix basename mname fmt () =
List.iter
@@ -71,7 +73,8 @@ let inline_annots rename_var_fun annot_list =
assert false
in
items @ accu)
- [] ann.annots;
+ []
+ ann.annots;
})
annot_list
diff --git a/src/plugins/salsa/machine_salsa_opt.ml b/src/plugins/salsa/machine_salsa_opt.ml
index 0a6b32bd..c898696c 100644
--- a/src/plugins/salsa/machine_salsa_opt.ml
+++ b/src/plugins/salsa/machine_salsa_opt.ml
@@ -22,7 +22,8 @@ let fun_types node =
Format.eprintf "%a is not a node@.@?" Printers.pp_decl node;
assert false
with Not_found ->
- Format.eprintf "Unable to find type def for function %s@.@?"
+ Format.eprintf
+ "Unable to find type def for function %s@.@?"
(Corelang.node_name node);
assert false
@@ -45,7 +46,8 @@ let rec get_expr_real_vars e =
| Fun (_, args) ->
List.fold_left
(fun acc e -> Vars.union acc (get_expr_real_vars e))
- Vars.empty args
+ Vars.empty
+ args
| Array _ | Access _ | Power _ ->
assert false
@@ -63,12 +65,14 @@ let rec get_read_vars instrs =
| MStep (_, _, el) ->
List.fold_left
(fun accu e -> Vars.union (get_expr_real_vars e) accu)
- vars_tl el
+ vars_tl
+ el
| MBranch (e, branches) ->
let vars = Vars.union (get_expr_real_vars e) vars_tl in
List.fold_left
(fun vars (_, b) -> Vars.union vars (get_read_vars b))
- vars branches
+ vars
+ branches
| MReset _ | MNoReset _ | MSpec _ | MComment _ ->
Vars.empty)
@@ -87,7 +91,8 @@ let rec get_written_vars instrs =
| MBranch (_, branches) ->
List.fold_left
(fun vars (_, b) -> Vars.union vars (get_written_vars b))
- vars_tl branches
+ vars_tl
+ branches
| MReset _ | MNoReset _ | MSpec _ | MComment _ ->
Vars.empty)
@@ -110,13 +115,17 @@ let opt_num_expr_sliced ranges e_salsa =
(* TODO more meaningful name *)
let abstractEnv = RangesInt.to_abstract_env ranges in
report ~level:2 (fun fmt ->
- Format.fprintf fmt "Launching analysis: %s@ "
+ Format.fprintf
+ fmt
+ "Launching analysis: %s@ "
(Salsa.Print.printExpression e_salsa));
let new_e_salsa, e_val =
Salsa.MainEPEG.transformExpression fresh_id e_salsa abstractEnv
in
report ~level:2 (fun fmt ->
- Format.fprintf fmt " Analysis done: %s@ "
+ Format.fprintf
+ fmt
+ " Analysis done: %s@ "
(Salsa.Print.printExpression new_e_salsa));
(* (\* Debug *\) *)
@@ -135,8 +144,11 @@ let opt_num_expr_sliced ranges e_salsa =
| true, true ->
if !debug then
report ~level:2 (fun fmt ->
- Format.fprintf fmt "No improvement on abstract value %a@ "
- RangesInt.pp_val e_val);
+ Format.fprintf
+ fmt
+ "No improvement on abstract value %a@ "
+ RangesInt.pp_val
+ e_val);
e_salsa, Some old_val
| false, true ->
if !debug then
@@ -144,16 +156,23 @@ let opt_num_expr_sliced ranges e_salsa =
new_e_salsa, Some e_val
| true, false ->
report ~level:2 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"CAREFUL --- new range is worse!. Restoring provided expression@ ");
e_salsa, Some old_val
| false, false ->
report ~level:2 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"Error; new range is not comparable with old end. It may need \
some investigation!@. ";
- Format.fprintf fmt "old: %a@.new: %a@ " RangesInt.pp_val old_val
- RangesInt.pp_val e_val);
+ Format.fprintf
+ fmt
+ "old: %a@.new: %a@ "
+ RangesInt.pp_val
+ old_val
+ RangesInt.pp_val
+ e_val);
new_e_salsa, Some e_val
(* assert false *)
@@ -162,20 +181,24 @@ let opt_num_expr_sliced ranges e_salsa =
if !debug then
report ~level:2 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
" @[<v>old_expr: @[<v 0>%s@ range: %a@]@ new_expr: @[<v 0>%s@ \
range: %a@]@ @]@ "
(Salsa.Print.printExpression e_salsa)
(* MC.pp_val e *)
- RangesInt.pp_val old_val
+ RangesInt.pp_val
+ old_val
(Salsa.Print.printExpression new_e_salsa)
(* MC.pp_val new_e *)
- RangesInt.pp_val e_val);
+ RangesInt.pp_val
+ e_val);
expr, expr_range
with (* Not_found -> *)
| Salsa.Epeg_types.EPEGError _ ->
report ~level:2 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"BECAUSE OF AN ERROR, Expression %s was not optimized@ "
(Salsa.Print.printExpression e_salsa)
(* MC.pp_val e *));
@@ -224,7 +247,8 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
opt_expr m vars_env ranges formalEnv arg
in
arg' :: al, arg_il @ il, Vars.union arg_nl nl)
- args ([], [], Vars.empty)
+ args
+ ([], [], Vars.empty)
in
{ e with value_desc = Fun (fun_id, args') }, None, il, new_locals
| Array _ | Access _ | Power _ ->
@@ -232,7 +256,10 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
and opt_num_expr m vars_env ranges formalEnv e =
if !debug then
report ~level:2 (fun fmt ->
- Format.fprintf fmt "Optimizing expression @[<hov>%a@]@ " (MC.pp_val m)
+ Format.fprintf
+ fmt
+ "Optimizing expression @[<hov>%a@]@ "
+ (MC.pp_val m)
e);
(* if !debug then Format.eprintf "Optimizing expression %a with Salsa@ "
MC.pp_val e; *)
@@ -272,9 +299,11 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
(* Format.eprintf "avant evalpart: %a@." MC.pp_val (salsa_expr2value_t
vars_env constEnv e_salsa); *)
let e_salsa =
- Salsa.Analyzer.evalPartExpr e_salsa
+ Salsa.Analyzer.evalPartExpr
+ e_salsa
(Salsa.Analyzer.valEnv2ExprEnv abstractEnv)
- [] (* no blacklisted variables *) []
+ []
+ (* no blacklisted variables *) []
(* no arrays *)
in
@@ -284,7 +313,8 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
let free_vars = get_salsa_free_vars vars_env constEnv abstractEnv e_salsa in
if Vars.cardinal free_vars > 0 then (
report ~level:2 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"Warning: unbounded free vars (%a) in expression %a. We do not \
optimize it.@ "
Vars.pp
@@ -297,7 +327,8 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
}
in
Vars.add v' accu)
- free_vars Vars.empty)
+ free_vars
+ Vars.empty)
(MC.pp_val m)
(salsa_expr2value_t vars_env constEnv e_salsa));
if !debug then
@@ -317,9 +348,12 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
else (
if !debug then
report ~level:3 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"@[<v 2>Analyzing expression %a@ with ranges: @[<v>%a@ @]@ @]@ "
- (C_backend_common.pp_c_val m ""
+ (C_backend_common.pp_c_val
+ m
+ ""
(C_backend_common.pp_c_var_read m))
(salsa_expr2value_t vars_env constEnv e_salsa)
(Utils.fprintf_list ~sep:",@ " (fun fmt (l, r) ->
@@ -329,10 +363,13 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
(* Slicing expression *)
let e_salsa, seq =
try
- Salsa.Rewrite.sliceExpr e_salsa 0
+ Salsa.Rewrite.sliceExpr
+ e_salsa
+ 0
(Salsa.Types.Nop (Salsa.Types.Lab 0))
with _ ->
- Format.eprintf "Issues rewriting express %s@.@?"
+ Format.eprintf
+ "Issues rewriting express %s@.@?"
(Salsa.Print.printExpression e_salsa);
assert false
in
@@ -342,30 +379,46 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
List.fold_left
(fun (vs, vars) (id, _) ->
let vdecl =
- Corelang.mk_fresh_var (nodename.node_id, [])
+ Corelang.mk_fresh_var
+ (nodename.node_id, [])
(* TODO check that the empty env is ok. One may need to build or
access to the current env *)
- Location.dummy_loc e.MT.value_type (Clocks.new_var true)
+ Location.dummy_loc
+ e.MT.value_type
+ (Clocks.new_var true)
in
let vs' = VarEnv.add id { vdecl; is_local = true } vs in
let vars' = Vars.add vdecl vars in
vs', vars')
- (vars_env, Vars.empty) def_tmps
+ (vars_env, Vars.empty)
+ def_tmps
in
(* Debug *)
if !debug then
report ~level:3 (fun fmt ->
- Format.fprintf fmt "List of slices: @[<v 0>%a@]@ "
+ Format.fprintf
+ fmt
+ "List of slices: @[<v 0>%a@]@ "
(Utils.fprintf_list ~sep:"@ " (fun fmt (id, e_id) ->
- Format.fprintf fmt "(%s,%a) -> %a" id Printers.pp_var
+ Format.fprintf
+ fmt
+ "(%s,%a) -> %a"
+ id
+ Printers.pp_var
(get_var vars_env' id).vdecl
- (C_backend_common.pp_c_val m ""
+ (C_backend_common.pp_c_val
+ m
+ ""
(C_backend_common.pp_c_var_read m))
(salsa_expr2value_t vars_env' constEnv e_id)))
def_tmps;
- Format.fprintf fmt "Sliced expression: %a@ "
- (C_backend_common.pp_c_val m ""
+ Format.fprintf
+ fmt
+ "Sliced expression: %a@ "
+ (C_backend_common.pp_c_val
+ m
+ ""
(C_backend_common.pp_c_var_read m))
(salsa_expr2value_t vars_env' constEnv e_salsa));
@@ -413,7 +466,8 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
RangesInt.add_def ranges id e_range
in
new_local_assign :: accu_instrs, new_ranges)
- ([], ranges) def_tmps
+ ([], ranges)
+ def_tmps
in
if !debug && List.length def_tmps >= 1 then
report ~level:3 (fun fmt -> Format.fprintf fmt "@]@ ");
@@ -462,7 +516,9 @@ let assign_vars nodename m constEnv vars_env printed_vars ranges formalEnv
in
if !debug then
report ~level:4 (fun fmt ->
- Format.fprintf fmt "Printing vars in the following order: [%a]@ "
+ Format.fprintf
+ fmt
+ "Printing vars in the following order: [%a]@ "
(Utils.fprintf_list ~sep:", " Printers.pp_var)
ordered_vars);
@@ -475,8 +531,15 @@ let assign_vars nodename m constEnv vars_env printed_vars ranges formalEnv
(* Obtaining unfold expression of v in formalEnv *)
let v_def = FormalEnv.get_def formalEnv v in
let e, r, il, new_v_locals =
- optimize_expr nodename m constEnv printed_vars vars_env ranges
- formalEnv v_def
+ optimize_expr
+ nodename
+ m
+ constEnv
+ printed_vars
+ vars_env
+ ranges
+ formalEnv
+ v_def
in
let instr_desc =
if
@@ -501,7 +564,8 @@ let assign_vars nodename m constEnv vars_env printed_vars ranges formalEnv
else (
Format.eprintf "@?";
assert false))
- ordered_vars ([], ranges, Vars.empty)
+ ordered_vars
+ ([], ranges, Vars.empty)
(* Main recursive function: modify the instructions list while preserving the
order of assigns for state variables. Returns a quintuple: (new_instrs,
@@ -636,9 +700,15 @@ let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv
in
let vt', _, il, expr_new_locals =
- optimize_expr nodename m constEnv
+ optimize_expr
+ nodename
+ m
+ constEnv
(Vars.union required_vars printed_vars)
- vars_env ranges formalEnv vt
+ vars_env
+ ranges
+ formalEnv
+ vt
in
let new_instr =
match Corelang.get_instr_desc hd_instr with
@@ -686,15 +756,24 @@ let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv
(fun e typ_e (exprl, range_l, il_l, new_locals) ->
if Types.is_real_type typ_e then
let e', r', il, new_expr_locals =
- optimize_expr nodename m constEnv printed_vars vars_env ranges
- formalEnv e
+ optimize_expr
+ nodename
+ m
+ constEnv
+ printed_vars
+ vars_env
+ ranges
+ formalEnv
+ e
in
( e' :: exprl,
r' :: range_l,
il @ il_l,
Vars.union new_locals new_expr_locals )
else e :: exprl, None :: range_l, il_l, new_locals)
- vtl tin ([], [], [], Vars.empty)
+ vtl
+ tin
+ ([], [], [], Vars.empty)
in
(* if !debug then Format.eprintf "... done@ @]@ "; *)
@@ -746,8 +825,15 @@ let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv
let required_vars = Vars.diff required_vars printed_vars in
(* remove already produced variables *)
let vt', _, prefix_instr, prefix_new_locals =
- optimize_expr nodename m constEnv printed_vars vars_env ranges
- formalEnv vt
+ optimize_expr
+ nodename
+ m
+ constEnv
+ printed_vars
+ vars_env
+ ranges
+ formalEnv
+ vt
in
let new_locals = prefix_new_locals in
@@ -775,8 +861,17 @@ let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv
b_printed,
b_vars,
b_new_locals ) =
- rewrite_instrs nodename m constEnv vars_env m b_instrs ranges
- b_fe printed_vars b_vars_to_print
+ rewrite_instrs
+ nodename
+ m
+ constEnv
+ vars_env
+ m
+ b_instrs
+ ranges
+ b_fe
+ printed_vars
+ b_vars_to_print
in
(* b_vars should be empty *)
let _ = if b_vars != [] then assert false in
@@ -826,8 +921,17 @@ let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv
let tl_instrs, ranges, formalEnv, printed_vars, vars_to_print, tl_new_locals
=
- rewrite_instrs nodename m constEnv vars_env m tl_instrs ranges formalEnv
- printed_vars vars_to_print
+ rewrite_instrs
+ nodename
+ m
+ constEnv
+ vars_env
+ m
+ tl_instrs
+ ranges
+ formalEnv
+ printed_vars
+ vars_to_print
in
( hd_instrs @ tl_instrs,
@@ -854,8 +958,10 @@ let salsaStep constEnv m s =
(var, range) :: accu
| _ ->
accu)
- accu annl.LT.annots)
- [] m.MT.mannot
+ accu
+ annl.LT.annots)
+ []
+ m.MT.mannot
in
let ranges =
List.fold_left
@@ -871,21 +977,28 @@ let salsaStep constEnv m s =
Format.eprintf
"Invalid salsa range: %a. It should be a pair of constant \
floats and %a is not a float.@."
- Printers.pp_expr value.LT.eexpr_qfexpr Printers.pp_expr e;
+ Printers.pp_expr
+ value.LT.eexpr_qfexpr
+ Printers.pp_expr
+ e;
assert false
in
(* let minv = Salsa.Float.Domain.of_num (get_cst minv) and *)
(* maxv = Salsa.Float.Domain.of_num (get_cst maxv) in *)
(* if !debug then Format.eprintf "variable %s in [%s, %s]@ " v
(Num.string_of_num minv) (Num.string_of_num maxv); *)
- RangesInt.enlarge ranges v
+ RangesInt.enlarge
+ ranges
+ v
(Salsa.Float.Domain.inject_nums (get_cst minv) (get_cst maxv))
| _ ->
Format.eprintf
"Invalid salsa range: %a. It should be a pair of floats.@."
- Printers.pp_expr value.LT.eexpr_qfexpr;
+ Printers.pp_expr
+ value.LT.eexpr_qfexpr;
assert false)
- ranges annots
+ ranges
+ annots
in
let formal_env = FormalEnv.empty () in
let vars_to_print =
@@ -897,7 +1010,14 @@ let salsaStep constEnv m s =
let vars_env = compute_vars_env m in
(* if !debug then Format.eprintf "@[<v 2>Registering node equations@ "; *)
let new_instrs, _, _, printed_vars, _, new_locals =
- rewrite_instrs m.MT.mname m constEnv vars_env m s.MT.step_instrs ranges
+ rewrite_instrs
+ m.MT.mname
+ m
+ constEnv
+ vars_env
+ m
+ s.MT.step_instrs
+ ranges
formal_env
(Vars.real_vars
(Vars.of_list
@@ -912,8 +1032,11 @@ let salsaStep constEnv m s =
if not (Vars.is_empty unused) then (
if !debug then
report ~level:2 (fun fmt ->
- Format.fprintf fmt "Unused local vars: [%a]. Removing them.@ "
- Vars.pp unused);
+ Format.fprintf
+ fmt
+ "Unused local vars: [%a]. Removing them.@ "
+ Vars.pp
+ unused);
List.filter (fun v -> not (Vars.mem v unused)) s.MT.step_locals)
else s.MT.step_locals
in
@@ -925,7 +1048,9 @@ let machine_t2machine_t_optimized_by_salsa constEnv mt =
try
if !debug then
report ~level:2 (fun fmt ->
- Format.fprintf fmt "@[<v 3>Optimizing machine %s@ "
+ Format.fprintf
+ fmt
+ "@[<v 3>Optimizing machine %s@ "
mt.MT.mname.LT.node_id);
let new_step = salsaStep constEnv mt mt.MT.mstep in
if !debug then report ~level:2 (fun fmt -> Format.fprintf fmt "@]@ ");
diff --git a/src/plugins/salsa/salsaDatatypes.ml b/src/plugins/salsa/salsaDatatypes.ml
index ecbd8b0b..e8e3d9c9 100644
--- a/src/plugins/salsa/salsaDatatypes.ml
+++ b/src/plugins/salsa/salsaDatatypes.ml
@@ -44,9 +44,11 @@ functor
let pp fmt r =
if Hashtbl.length r = 0 then Format.fprintf fmt "empty"
else
- pp_hash ~sep:";"
+ pp_hash
+ ~sep:";"
(fun k v fmt -> Format.fprintf fmt "%s -> %a" k Value.pp v)
- fmt r
+ fmt
+ r
let pp_val = Value.pp
@@ -251,7 +253,9 @@ end)
let get_var vars_env v =
try VarEnv.find v vars_env
with Not_found ->
- Format.eprintf "Impossible to find var %s in var env %a@ " v
+ Format.eprintf
+ "Impossible to find var %s in var env %a@ "
+ v
(Utils.fprintf_list ~sep:", " (fun fmt (id, _) ->
Format.pp_print_string fmt id))
(VarEnv.bindings vars_env);
@@ -263,7 +267,8 @@ let compute_vars_env m =
List.fold_left
(fun accu v ->
VarEnv.add v.LT.var_id { vdecl = v; is_local = false } accu)
- env m.MT.mmemory
+ env
+ m.MT.mmemory
in
let env =
List.fold_left
@@ -391,7 +396,8 @@ module FormalEnv = struct
let to_salsa constEnv formalEnv =
fold
(fun id expr accu -> (id, value_t2salsa_expr constEnv expr) :: accu)
- formalEnv []
+ formalEnv
+ []
let def constEnv vars_env (env : fe_t) d expr =
incr cpt;
@@ -400,7 +406,10 @@ module FormalEnv = struct
let salsa_env = to_salsa constEnv env in
let expr_salsa, _ = Salsa.Rewrite.substVars expr_salsa salsa_env 0 in
let expr_salsa =
- Salsa.Analyzer.evalPartExpr expr_salsa salsa_env []
+ Salsa.Analyzer.evalPartExpr
+ expr_salsa
+ salsa_env
+ []
(* no blacklisted vars *)
[]
(*no arrays *)
@@ -412,9 +421,11 @@ module FormalEnv = struct
let empty () : fe_t = Hashtbl.create 13
let pp m fmt env =
- pp_hash ~sep:";@ "
+ pp_hash
+ ~sep:";@ "
(fun k (_, v) fmt -> Format.fprintf fmt "%s -> %a" k (MC.pp_val m) v)
- fmt env
+ fmt
+ env
let get_sort_fun env =
let order = Hashtbl.fold (fun k (cpt, _) accu -> (k, cpt) :: accu) env [] in
diff --git a/src/plugins/salsa/salsa_plugin.ml b/src/plugins/salsa/salsa_plugin.ml
index 0345dc6d..92e24712 100644
--- a/src/plugins/salsa/salsa_plugin.ml
+++ b/src/plugins/salsa/salsa_plugin.ml
@@ -42,7 +42,8 @@ module Plugin : PluginType.S = struct
(c.const_id, c.const_value) :: accu
| _ ->
accu)
- [] (Corelang.get_consts prog)
+ []
+ (Corelang.get_consts prog)
in
let res =
List.map
diff --git a/src/plugins/scopes/scopes.ml b/src/plugins/scopes/scopes.ml
index a5fb18b1..67ed0fd4 100644
--- a/src/plugins/scopes/scopes.ml
+++ b/src/plugins/scopes/scopes.ml
@@ -11,7 +11,8 @@ type scope_t = (var_decl * string * string option) list * var_decl
let scope_to_sl ((sl, v) : scope_t) : string list =
List.fold_right
(fun (v, nodename, _) accu -> v.var_id :: nodename :: accu)
- sl [ v.var_id ]
+ sl
+ [ v.var_id ]
let rec compute_scopes ?(first = true) prog root_node : scope_t list =
let compute_scopes = compute_scopes ~first:false in
@@ -37,7 +38,10 @@ let rec compute_scopes ?(first = true) prog root_node : scope_t list =
let vid = List.find query all_vars in
(nodeid, vid) :: res
with Not_found ->
- Format.eprintf "eq=%a@.local_vars=%a@." Printers.pp_node_eq eq
+ Format.eprintf
+ "eq=%a@.local_vars=%a@."
+ Printers.pp_node_eq
+ eq
(Format.pp_comma_list Printers.pp_var)
local_vars;
assert false)
@@ -46,7 +50,8 @@ let rec compute_scopes ?(first = true) prog root_node : scope_t list =
| _ ->
assert false
(* TODO deal with Automaton *))
- [] node.node_stmts
+ []
+ node.node_stmts
in
List.map
(fun (nodeid, vid) ->
@@ -61,13 +66,17 @@ let rec compute_scopes ?(first = true) prog root_node : scope_t list =
let pp_scopes =
Format.(
pp_print_list (fun fmt ((_, v) as s) ->
- fprintf fmt "%a: %a"
+ fprintf
+ fmt
+ "%a: %a"
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt ".")
pp_print_string)
- (scope_to_sl s) Types.print_ty v.var_type))
+ (scope_to_sl s)
+ Types.pp
+ v.var_type))
-(* let print_path fmt p = *)
+(* let pp_path fmt p = *)
(* Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt
id) fmt p *)
@@ -139,7 +148,7 @@ let check_scope all_scopes =
(* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ; *)
let main_node = get_node main_node_name prog in
let path, flow, mid = get_path prog machines main_node sl [] in
- (* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *)
+ (* Format.eprintf "computed path: %a.%s@." pp_path path flow.var_id; *)
path, flow, mid
(* Build the two maps - (scope_name, variable) - (machine_name, list of selected
@@ -158,7 +167,8 @@ let check_scopes main_node_name prog machines all_scopes scopes =
else (mid, [ flow_id ]) :: accu_m
in
accu_sl, accu_m)
- ([], []) scopes
+ ([], [])
+ scopes
let scope_var_name vid = vid ^ "__scope"
@@ -195,7 +205,10 @@ let pp_scopes_files _basename _mname fmt scopes =
(fun idx (id, (_, var)) ->
let file = C_backend_common.pp_file_open fmt "out_scopes" idx in
Format.fprintf fmt "fprintf(%s, \"# scope: %s\\n\");@ " file id;
- Format.fprintf fmt "fprintf(%s, \"# node: %s\\n\");@ " file
+ Format.fprintf
+ fmt
+ "fprintf(%s, \"# node: %s\\n\");@ "
+ file
(Utils.desome var.var_parent_nodeid);
Format.fprintf fmt "fprintf(%s, \"# variable: %s\\n\");@ " file var.var_id)
scopes_vars;
@@ -206,9 +219,12 @@ let pp_full_scopes fmt scopes =
List.iteri
(fun idx (id, (var_path, var)) ->
Format.fprintf fmt "@ %t;" (fun fmt ->
- C_backend_common.pp_put_var fmt
+ C_backend_common.pp_put_var
+ fmt
("_scopes" ^ string_of_int (idx + 1))
- id (*var*) var.var_type var_path))
+ id
+ (*var*) var.var_type
+ var_path))
scopes_vars
(**********************************************************************)
@@ -323,7 +339,8 @@ let process_scopes main_node prog machines =
let res = is_valid_path sl main_node prog machines in
(if not res then
Format.(
- eprintf "Scope %a is cancelled due to variable removal@."
+ eprintf
+ "Scope %a is cancelled due to variable removal@."
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt ".")
pp_print_string)
@@ -405,7 +422,8 @@ end = struct
let usage fmt =
let open Format in
- fprintf fmt
+ fprintf
+ fmt
"@[<hov 0>Scopes@ enrich@ the@ internal@ memories@ to@ record@ all@ or@ \
a@ selection@ of@ internals.@ In@ conjunction@ with@ the@ trace@ \
option@ of@ the@ produced@ binary@ it@ can@ also@ record@ these@ flow@ \
diff --git a/src/printers.ml b/src/printers.ml
index 1b206f5b..597c4231 100644
--- a/src/printers.ml
+++ b/src/printers.ml
@@ -60,22 +60,27 @@ and pp_var_type_dec_desc fmt tdesc =
let pp_var_type_dec fmt ty = pp_var_type_dec_desc fmt ty.ty_dec_desc
let pp_var_name fmt id =
- fprintf fmt "%s"
+ fprintf
+ fmt
+ "%s"
(if !Options.kind2_print then kind2_protect id.var_id else id.var_id)
let pp_var_type fmt id =
if !Options.print_dec_types then pp_var_type_dec fmt id.var_dec_type
- else Types.print_node_ty fmt id.var_type
+ else Types.pp_node_ty fmt id.var_type
let pp_var_clock fmt id = Clocks.pp_suffix fmt id.var_clock
let pp_eq_lhs = pp_comma_list pp_print_string
let pp_var fmt id =
- fprintf fmt "%s%s: %a"
+ fprintf
+ fmt
+ "%s%s: %a"
(if id.var_dec_const then "const " else "")
(if !Options.kind2_print then kind2_protect id.var_id else id.var_id)
- pp_var_type id
+ pp_var_type
+ id
let pp_vars fmt vars = pp_print_list ~pp_sep:pp_print_semicolon pp_var fmt vars
@@ -101,7 +106,9 @@ and pp_const fmt c =
| Const_tag t ->
pp_print_string fmt t
| Const_array ca ->
- fprintf fmt "[%a]"
+ fprintf
+ fmt
+ "[%a]"
(pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ",") pp_const)
ca
| Const_struct fl ->
@@ -119,7 +126,9 @@ let pp_annot_key fmt kwds =
| [ x ] ->
pp_print_string fmt x
| _ ->
- fprintf fmt "/%a/"
+ fprintf
+ fmt
+ "/%a/"
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt "/")
pp_print_string)
@@ -135,13 +144,16 @@ let rec pp_expr fmt expr =
| None ->
fprintf fmt "%t"
| Some ann ->
- fprintf fmt "@[(%a %t)@]" pp_expr_annot ann) (fun fmt ->
+ fprintf fmt "@[(%a %t)@]" pp_expr_annot ann)
+ (fun fmt ->
let pp fmt =
match expr.expr_desc with
| Expr_const c ->
pp_const fmt c
| Expr_ident id ->
- fprintf fmt "%s"
+ fprintf
+ fmt
+ "%s"
(if !Options.kind2_print then kind2_protect id else id)
| Expr_array a ->
fprintf fmt "[%a]" pp_tuple a
@@ -152,9 +164,15 @@ let rec pp_expr fmt expr =
| Expr_tuple el ->
fprintf fmt "(%a)" pp_tuple el
| Expr_ite (c, t, e) ->
- fprintf fmt
+ fprintf
+ fmt
"@[<hov 1>(if %a then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@])"
- pp_expr c pp_expr t pp_expr e
+ pp_expr
+ c
+ pp_expr
+ t
+ pp_expr
+ e
| Expr_arrow (e1, e2) ->
fprintf fmt "(%a -> %a)" pp_expr e1 pp_expr e2
| Expr_fby (e1, e2) ->
@@ -171,7 +189,7 @@ let rec pp_expr fmt expr =
pp_app fmt id e r
in
if false (* extra debug *) then
- Format.fprintf fmt "%t: %a" pp Types.print_ty expr.expr_type
+ Format.fprintf fmt "%t: %a" pp Types.pp expr.expr_type
else pp fmt)
and pp_tuple fmt el =
@@ -207,7 +225,8 @@ and pp_app fmt id e r =
| _ ->
assert false
(* If this is not even, there should be a clocking problem*))
- init_when (List.tl un_when_ed_el)
+ init_when
+ (List.tl un_when_ed_el)
in
match common_when with
| None ->
@@ -227,8 +246,16 @@ and pp_app fmt id e r =
| Some r, None ->
fprintf fmt "(restart %s every (%a)) (%a)" id pp_expr r pp_expr e
| Some r, Some w ->
- fprintf fmt "(activate %s every (%a) restart every (%a)) (%a)" id
- pp_kind2_when w pp_expr r pp_expr e
+ fprintf
+ fmt
+ "(activate %s every (%a) restart every (%a)) (%a)"
+ id
+ pp_kind2_when
+ w
+ pp_expr
+ r
+ pp_expr
+ e
else
match r with
| None ->
@@ -278,24 +305,32 @@ and pp_call fmt id e =
fprintf fmt "%s (%a)" id pp_expr e
and pp_eexpr fmt e =
- fprintf fmt "%a%t %a"
+ fprintf
+ fmt
+ "%a%t %a"
(pp_print_list ~pp_sep:pp_print_semicolon pp_quantifiers)
e.eexpr_quantifiers
(fun fmt ->
match e.eexpr_quantifiers with [] -> () | _ -> fprintf fmt ";")
- pp_expr e.eexpr_qfexpr
+ pp_expr
+ e.eexpr_qfexpr
and pp_sf_value fmt e =
- fprintf fmt "%a"
+ fprintf
+ fmt
+ "%a"
(* (Utils.fprintf_list ~sep:"; " pp_quantifiers) e.eexpr_quantifiers *)
(* (fun fmt -> match e.eexpr_quantifiers *)
(* with [] -> () *)
(* | _ -> fprintf fmt ";") *)
- pp_expr e.eexpr_qfexpr
+ pp_expr
+ e.eexpr_qfexpr
and pp_s_function fmt expr_ann =
let pp_annot fmt (kwds, ee) =
- fprintf fmt " %t : %a"
+ fprintf
+ fmt
+ " %t : %a"
(fun fmt ->
match kwds with
| [] ->
@@ -303,12 +338,15 @@ and pp_s_function fmt expr_ann =
| [ x ] ->
pp_print_string fmt x
| _ ->
- fprintf fmt "%a"
+ fprintf
+ fmt
+ "%a"
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt "/")
pp_print_string)
kwds)
- pp_sf_value ee
+ pp_sf_value
+ ee
in
pp_print_list pp_annot fmt expr_ann.annots
@@ -326,18 +364,24 @@ let pp_asserts fmt asserts =
(fun fmt assert_ ->
let expr = assert_.assert_expr in
fprintf fmt "assert %a;" pp_expr expr)
- fmt asserts
+ fmt
+ asserts
| _ ->
()
(* let pp_node_var fmt id = fprintf fmt "%s%s: %a(%a)%a" (if id.var_dec_const
then "const " else "") id.var_id print_dec_ty id.var_dec_type.ty_dec_desc
- Types.print_ty id.var_type Clocks.print_ck_suffix id.var_clock *)
+ Types.pp id.var_type Clocks.pp_ck_suffix id.var_clock *)
let pp_node_var fmt id =
- fprintf fmt "%s%s: %a%a"
+ fprintf
+ fmt
+ "%s%s: %a%a"
(if id.var_dec_const then "const " else "")
(if !Options.kind2_print then kind2_protect id.var_id else id.var_id)
- pp_var_type id pp_var_clock id;
+ pp_var_type
+ id
+ pp_var_clock
+ id;
match id.var_dec_value with
| None ->
()
@@ -359,31 +403,50 @@ let pp_until fmt (_, expr, restart, st) =
fprintf fmt "until %a %a %s" pp_expr expr pp_restart restart st
let rec pp_handler fmt handler =
- fprintf fmt "state %s:@ @[<v 2> %a%t%alet@,@[<v 2> %a@ %a@ %a@]@,tel@ %a@]"
- handler.hand_state (pp_print_list pp_unless) handler.hand_unless
+ fprintf
+ fmt
+ "state %s:@ @[<v 2> %a%t%alet@,@[<v 2> %a@ %a@ %a@]@,tel@ %a@]"
+ handler.hand_state
+ (pp_print_list pp_unless)
+ handler.hand_unless
(fun fmt -> if not ([] = handler.hand_unless) then fprintf fmt "@ ")
(fun fmt locals ->
match locals with
| [] ->
()
| _ ->
- fprintf fmt "@[<v 4>var %a@]@ "
+ fprintf
+ fmt
+ "@[<v 4>var %a@]@ "
(pp_print_list ~pp_sep:pp_print_semicolon pp_node_var)
locals)
handler.hand_locals
(pp_print_list pp_expr_annot)
- handler.hand_annots pp_node_stmts handler.hand_stmts pp_asserts
- handler.hand_asserts (pp_print_list pp_until) handler.hand_until
+ handler.hand_annots
+ pp_node_stmts
+ handler.hand_stmts
+ pp_asserts
+ handler.hand_asserts
+ (pp_print_list pp_until)
+ handler.hand_until
and pp_node_stmt fmt stmt =
match stmt with Eq eq -> pp_node_eq fmt eq | Aut aut -> pp_node_aut fmt aut
and pp_node_stmts fmt stmts =
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_cut pp_node_stmt fmt
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:pp_print_cut
+ pp_node_stmt
+ fmt
stmts
and pp_node_aut fmt aut =
- fprintf fmt "@[<v 0>automaton %s@,%a@]" aut.aut_id (pp_print_list pp_handler)
+ fprintf
+ fmt
+ "@[<v 0>automaton %s@,%a@]"
+ aut.aut_id
+ (pp_print_list pp_handler)
aut.aut_handlers
and pp_node_eqs fmt eqs = pp_print_list pp_node_eq fmt eqs
@@ -415,8 +478,15 @@ let pp_typedef fmt ty =
[] -> () | _ -> fprintf fmt ";") pp_expr e.eexpr_qfexpr *)
let pp_spec_eq fmt eq =
- fprintf fmt "var %a : %a = %a;" pp_eq_lhs eq.eq_lhs Types.print_node_ty
- eq.eq_rhs.expr_type pp_expr eq.eq_rhs
+ fprintf
+ fmt
+ "var %a : %a = %a;"
+ pp_eq_lhs
+ eq.eq_lhs
+ Types.pp_node_ty
+ eq.eq_rhs.expr_type
+ pp_expr
+ eq.eq_rhs
let pp_spec_stmt fmt stmt =
match stmt with Eq eq -> pp_spec_eq fmt eq | Aut _ -> assert false
@@ -433,28 +503,42 @@ let pp_spec fmt spec =
assert false
| Some e ->
pp_expr fmt e))
- fmt spec.consts;
+ fmt
+ spec.consts;
pp_print_list (fun fmt s -> pp_spec_stmt fmt s) fmt spec.stmts;
pp_print_list
(fun fmt r -> fprintf fmt "assume %a;" pp_eexpr r)
- fmt spec.assume;
+ fmt
+ spec.assume;
pp_print_list
(fun fmt r -> fprintf fmt "guarantee %a;" pp_eexpr r)
- fmt spec.guarantees;
+ fmt
+ spec.guarantees;
pp_print_list
(fun fmt mode ->
- fprintf fmt "mode %s (@[<v 0>%a@ %a@]);" mode.mode_id
+ fprintf
+ fmt
+ "mode %s (@[<v 0>%a@ %a@]);"
+ mode.mode_id
(pp_print_list (fun fmt r -> fprintf fmt "require %a;" pp_eexpr r))
mode.require
(pp_print_list (fun fmt r -> fprintf fmt "ensure %a;" pp_eexpr r))
mode.ensure)
- fmt spec.modes;
+ fmt
+ spec.modes;
pp_print_list
(fun fmt import ->
- fprintf fmt "import %s (%a) returns (%a);" import.import_nodeid pp_expr
- import.inputs pp_expr import.outputs)
- fmt spec.imports
+ fprintf
+ fmt
+ "import %s (%a) returns (%a);"
+ import.import_nodeid
+ pp_expr
+ import.inputs
+ pp_expr
+ import.outputs)
+ fmt
+ spec.imports
(* Project the contract node as a pure contract: local memories are pushed back
in the contract definition. Should mainly be used to print it *)
@@ -479,9 +563,15 @@ let node_as_contract nd =
(* Printing top contract as comments in regular output and as contract in kind2 *)
let pp_contract fmt nd =
let c = node_as_contract nd in
- fprintf fmt "@[<v 2>%scontract %s(%a) returns (%a);@ "
+ fprintf
+ fmt
+ "@[<v 2>%scontract %s(%a) returns (%a);@ "
(if !Options.kind2_print then "" else "(*@")
- nd.node_id pp_node_args nd.node_inputs pp_node_args nd.node_outputs;
+ nd.node_id
+ pp_node_args
+ nd.node_inputs
+ pp_node_args
+ nd.node_outputs;
fprintf fmt "@[<v 2>let@ ";
pp_spec fmt c;
fprintf fmt "@]@ tel@ @]%s@ " (if !Options.kind2_print then "" else "*)")
@@ -497,19 +587,34 @@ let pp_spec_as_comment fmt (inl, outl, spec) =
(* Pushing stmts in contract. We update the original information with the
computed one in nd. *)
let pp_l = pp_comma_list pp_var_name in
- fprintf fmt "@[<hov 2>(*@contract import %s(%a) returns (%a); @]*)@ " name
- pp_l inl pp_l outl
+ fprintf
+ fmt
+ "@[<hov 2>(*@contract import %s(%a) returns (%a); @]*)@ "
+ name
+ pp_l
+ inl
+ pp_l
+ outl
let pp_node_vs_function fmt nd =
fprintf fmt "%s" (if nd.node_dec_stateless then "function" else "node")
let pp_node fmt nd =
(* Prototype *)
- fprintf fmt "%a @[<hov 0>%s (@[%a)@]@ returns (@[%a)@]@]@ "
- pp_node_vs_function nd nd.node_id pp_node_args nd.node_inputs pp_node_args
+ fprintf
+ fmt
+ "%a @[<hov 0>%s (@[%a)@]@ returns (@[%a)@]@]@ "
+ pp_node_vs_function
+ nd
+ nd.node_id
+ pp_node_args
+ nd.node_inputs
+ pp_node_args
nd.node_outputs;
(* Contracts *)
- fprintf fmt "%a"
+ fprintf
+ fmt
+ "%a"
(fun fmt s ->
match s with
| Some s ->
@@ -520,24 +625,32 @@ let pp_node fmt nd =
(* (fun fmt -> match nd.node_spec with None -> () | Some _ -> fprintf fmt "@
") *);
(* Locals *)
- fprintf fmt "%a"
+ fprintf
+ fmt
+ "%a"
(fun fmt locals ->
match locals with
| [] ->
()
| _ ->
- fprintf fmt "@[<v 4>var %a@]@ "
+ fprintf
+ fmt
+ "@[<v 4>var %a@]@ "
(pp_print_list (fun fmt v -> fprintf fmt "%a;" pp_node_var v))
locals)
nd.node_locals;
(* Checks *)
- fprintf fmt "%a"
+ fprintf
+ fmt
+ "%a"
(fun fmt checks ->
match checks with
| [] ->
()
| _ ->
- fprintf fmt "@[<v 4>check@ %a@]@ "
+ fprintf
+ fmt
+ "@[<v 4>check@ %a@]@ "
(pp_print_list (fun fmt d -> fprintf fmt "%a" Dimension.pp d))
checks)
nd.node_checks;
@@ -569,11 +682,19 @@ let pp_node fmt nd =
let pp_imported_node fmt ind =
fprintf fmt "@[<v 0>";
(* Prototype *)
- fprintf fmt "%s @[<hov 0>%s (@[%a)@]@ returns (@[%a)@]@]@ "
+ fprintf
+ fmt
+ "%s @[<hov 0>%s (@[%a)@]@ returns (@[%a)@]@]@ "
(if ind.nodei_stateless then "function" else "node")
- ind.nodei_id pp_node_args ind.nodei_inputs pp_node_args ind.nodei_outputs;
+ ind.nodei_id
+ pp_node_args
+ ind.nodei_inputs
+ pp_node_args
+ ind.nodei_outputs;
(* Contracts *)
- fprintf fmt "%a%t"
+ fprintf
+ fmt
+ "%a%t"
(fun fmt s ->
match s with
| Some s ->
@@ -622,7 +743,11 @@ let pp_prog pp_decl fmt prog =
match decl.top_decl_desc with TypeDef _ -> true | _ -> false)
prog
in
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_cutcut pp_decl fmt
+ pp_print_list
+ ~pp_open_box:pp_open_vbox0
+ ~pp_sep:pp_print_cutcut
+ pp_decl
+ fmt
(open_decl @ type_decl @ prog)
(* Gives a short overview of model content. Do not print all node content *)
@@ -665,10 +790,14 @@ let pp_lusi fmt decl =
let pp_lusi_header fmt basename prog =
fprintf fmt "@[<v 0>";
fprintf fmt "(* Generated Lustre Interface file from %s.lus *)@ " basename;
- fprintf fmt "(* by Lustre-C compiler version %s, %a *)@ " Version.number
+ fprintf
+ fmt
+ "(* by Lustre-C compiler version %s, %a *)@ "
+ Version.number
pp_date
(Unix.gmtime (Unix.time ()));
- fprintf fmt
+ fprintf
+ fmt
"(* Feel free to mask some of the definitions by removing them from this \
file. *)@ @ ";
List.iter (fprintf fmt "%a@ " pp_lusi) prog;
@@ -683,7 +812,9 @@ let pp_lusi_header fmt basename prog =
* fprintf fmt ".%s" f *)
let pp_node_list fmt prog =
- Format.fprintf fmt "@[<h 2>%a@]"
+ Format.fprintf
+ fmt
+ "@[<h 2>%a@]"
(pp_print_list (fun fmt decl ->
match decl.top_decl_desc with
| Node nd ->
diff --git a/src/real.ml b/src/real.ml
index 28805c73..653ea621 100644
--- a/src/real.ml
+++ b/src/real.ml
@@ -2,7 +2,10 @@
type t = Q.t * int * string
let pp fmt (_, _, s) =
- Format.fprintf fmt "%s%s" s
+ Format.fprintf
+ fmt
+ "%s%s"
+ s
(if String.get s (-1 + String.length s) = '.' then "0" else "")
let pp_ada fmt (c, e, _) = Format.fprintf fmt "%s.0*1.0e-%i" (Q.to_string c) e
diff --git a/src/scheduling.ml b/src/scheduling.ml
index 726f9201..bcdbd9ae 100644
--- a/src/scheduling.ml
+++ b/src/scheduling.ml
@@ -126,7 +126,10 @@ let schedule_node n =
let compute_node_reuse_table report =
let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in
let reuse =
- Liveness.compute_reuse_policy report.node report.schedule disjoint
+ Liveness.compute_reuse_policy
+ report.node
+ report.schedule
+ disjoint
report.dep_graph
in
(* if !Options.print_reuse then begin Log.report ~level:0 (fun fmt ->
@@ -148,7 +151,8 @@ let schedule_prog prog =
IMap.add nd.node_id report sch_map )
| _ ->
top_decl :: accu_prog, sch_map)
- prog ([], IMap.empty)
+ prog
+ ([], IMap.empty)
let compute_prog_reuse_table report = IMap.map compute_node_reuse_table report
@@ -160,7 +164,8 @@ let remove_node_inlined_locals locals report =
(fun heads q ->
let heads' = List.filter (fun v -> not (is_inlined v)) heads in
if heads' = [] then q else heads' :: q)
- report.schedule []
+ report.schedule
+ []
in
IMap.iter (fun v _ -> Hashtbl.remove report.fanin_table v) locals;
IMap.iter
@@ -186,7 +191,10 @@ let pp_schedule fmt node_schs =
IMap.iter
(fun nd report ->
Format.(
- fprintf fmt "%s schedule: %a@ " nd
+ fprintf
+ fmt
+ "%s schedule: %a@ "
+ nd
(pp_print_list ~pp_sep:pp_print_semicolon pp_eq_schedule)
report.schedule))
node_schs
@@ -200,7 +208,11 @@ let pp_fanin_table fmt node_schs =
let pp_dep_graph fmt node_schs =
IMap.iter
(fun nd report ->
- Format.fprintf fmt "%s dependency graph: %a@ " nd pp_dep_graph
+ Format.fprintf
+ fmt
+ "%s dependency graph: %a@ "
+ nd
+ pp_dep_graph
report.dep_graph)
node_schs
@@ -220,8 +232,11 @@ let pp_warning_unused fmt node_schs =
(fun u ->
let vu = get_node_var u nd in
if vu.var_orig then
- Format.fprintf fmt
- " Warning: variable '%s' seems unused@, %a@,@," u Location.pp
+ Format.fprintf
+ fmt
+ " Warning: variable '%s' seems unused@, %a@,@,"
+ u
+ Location.pp
vu.var_loc)
unused)
node_schs
@@ -231,7 +246,9 @@ let pp_warning_unused fmt node_schs =
[sch] *)
let sort_equations_from_schedule eqs sch =
Log.report ~level:10 (fun fmt ->
- Format.fprintf fmt "schedule: %a@ "
+ Format.fprintf
+ fmt
+ "schedule: %a@ "
(Format.pp_print_list ~pp_sep:Format.pp_print_semicolon pp_eq_schedule)
sch);
let split_eqs = Splitting.tuple_split_eq_list eqs in
@@ -251,20 +268,27 @@ let sort_equations_from_schedule eqs sch =
else
let eq_v, remainder = find_eq vl node_eqs_remainder in
eq_v :: accu, remainder)
- ([], split_eqs) sch
+ ([], split_eqs)
+ sch
in
let eqs = List.rev eqs_rev in
let unused =
if List.length remainder > 0 then (
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"[Warning] Equations not used are@ %a@ Full equation set is:@ %a@ "
- Printers.pp_node_eqs remainder Printers.pp_node_eqs eqs);
+ Printers.pp_node_eqs
+ remainder
+ Printers.pp_node_eqs
+ eqs);
let vars =
List.fold_left (fun accu eq -> eq.eq_lhs @ accu) [] remainder
in
Log.report ~level:1 (fun fmt ->
- Format.fprintf fmt "[Warning] Unused variables: %a@ "
+ Format.fprintf
+ fmt
+ "[Warning] Unused variables: %a@ "
(Format.pp_comma_list Format.pp_print_string)
vars);
vars)
diff --git a/src/sortProg.ml b/src/sortProg.ml
index d36d91f0..2a386c6a 100644
--- a/src/sortProg.ml
+++ b/src/sortProg.ml
@@ -42,14 +42,17 @@ let sort prog =
else (
Format.eprintf "Impossible to find node %s@.@?" x;
failwith x))
- g []
+ g
+ []
with Causality.Error err as exc ->
Causality.pp_error Format.err_formatter err;
raise exc
in
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt "@ @[<v 2>.. ordered list of declarations:@ %a@]@ "
+ Format.fprintf
+ fmt
+ "@ @[<v 2>.. ordered list of declarations:@ %a@]@ "
(Format.pp_print_list Printers.pp_short_decl)
sorted);
not_nodes @ sorted
diff --git a/src/splitting.ml b/src/splitting.ml
index 7b41af1f..aff87947 100644
--- a/src/splitting.ml
+++ b/src/splitting.ml
@@ -63,7 +63,8 @@ let rec tuple_split_expr expr =
expr_tag = Utils.new_tag ();
expr_desc = Expr_arrow (e1, e2);
})
- (tuple_split_expr e1) (tuple_split_expr e2)
+ (tuple_split_expr e1)
+ (tuple_split_expr e2)
| Expr_pre e ->
List.map
(fun e ->
@@ -91,7 +92,8 @@ let rec tuple_split_expr expr =
expr_tag = Utils.new_tag ();
expr_desc = Expr_ite (c, t, e);
})
- (tuple_split_expr t) (tuple_split_expr e)
+ (tuple_split_expr t)
+ (tuple_split_expr e)
| Expr_merge (c, hl) ->
let tl, hl =
List.split (List.map (fun (t, h) -> t, tuple_split_expr h) hl)
diff --git a/src/tools/importer/main_lustre_importer.ml b/src/tools/importer/main_lustre_importer.ml
index d4181bc3..e5e6de69 100644
--- a/src/tools/importer/main_lustre_importer.ml
+++ b/src/tools/importer/main_lustre_importer.ml
@@ -52,7 +52,8 @@ let () =
Format.printf "Error: %s\n" e; *)
match vhdl_file_t_of_yojson vhdl1_json with
| Ok x ->
- Format.printf "Parsed VHDL: \n%s\n"
+ Format.printf
+ "Parsed VHDL: \n%s\n"
(pretty_to_string (vhdl_file_t_to_yojson x))
| Error e ->
Format.printf "Error: %s\n" e
diff --git a/src/tools/seal/seal_export.ml b/src/tools/seal/seal_export.ml
index ad8d1520..731dab19 100644
--- a/src/tools/seal/seal_export.ml
+++ b/src/tools/seal/seal_export.ml
@@ -18,12 +18,14 @@ let process_sw vars f_e sw =
List.assoc vid remaining :: res, List.remove_assoc vid remaining
else (
Format.eprintf
- "Looking for variable %s in remaining expressions: [%a]@." vid
+ "Looking for variable %s in remaining expressions: [%a]@."
+ vid
(Utils.fprintf_list ~sep:";@ " (fun fmt (id, e) ->
Format.fprintf fmt "(%s -> %a)" id Printers.pp_expr e))
remaining;
assert false (* Missing variable v in list *)))
- vars ([], el)
+ vars
+ ([], el)
in
assert (forgotten = []);
let loc = (List.hd el).expr_loc in
@@ -57,8 +59,10 @@ let process_sw vars f_e sw =
let g_opt, up_e, loc = process_branch g_opt up in
match g_opt with
| None ->
- Format.eprintf "SEAL issue: process_sw with %a"
- (pp_sys Printers.pp_expr) sw;
+ Format.eprintf
+ "SEAL issue: process_sw with %a"
+ (pp_sys Printers.pp_expr)
+ sw;
assert false (* How could this happen anyway ? *)
| Some g ->
let tl_e = process_sw f_e tl in
@@ -166,10 +170,16 @@ let to_lustre basename prog new_node orig_node =
let fmt_verif = Format.formatter_of_out_channel out_verif in
let check_nd = Lustre_utils.check_eq new_node orig_node in
let check_top =
- Corelang.mktop_decl Location.dummy_loc output_file_verif false
+ Corelang.mktop_decl
+ Location.dummy_loc
+ output_file_verif
+ false
(Node check_nd)
in
- Format.fprintf fmt_verif "%a@." Printers.pp_prog
+ Format.fprintf
+ fmt_verif
+ "%a@."
+ Printers.pp_prog
(prog @ [ new_top; check_top ])
let node_to_lustre basename prog m sw_init sw_step init_out update_out =
diff --git a/src/tools/seal/seal_extract.ml b/src/tools/seal/seal_extract.ml
index d85a9e4f..16311b02 100644
--- a/src/tools/seal/seal_extract.ml
+++ b/src/tools/seal/seal_extract.ml
@@ -47,12 +47,16 @@ let pp_e_map fmt =
let pp_ze_hash fmt =
pp_hash
(fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))
- Format.pp_print_int fmt ze_hash
+ Format.pp_print_int
+ fmt
+ ze_hash
let pp_e_hash fmt =
- pp_hash Format.pp_print_int
+ pp_hash
+ Format.pp_print_int
(fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))
- fmt e_hash
+ fmt
+ e_hash
let mem_expr e =
(* Format.eprintf "Searching for %a in map: @[<v 0>%t@]"
@@ -84,7 +88,9 @@ let get_zid (ze : Z3.Expr.expr) : Utils.tag =
else if Z3.Expr.equal ze (neg_ze is_init_z3e) then -2
else Hashtbl.find ze_hash ze
with _ ->
- Format.eprintf "Looking for ze %s in Hash %a" (Z3.Expr.to_string ze)
+ Format.eprintf
+ "Looking for ze %s in Hash %a"
+ (Z3.Expr.to_string ze)
(fun fmt hash ->
Hashtbl.iter
(fun ze uid ->
@@ -186,7 +192,8 @@ let expr_to_z3_expr, zexpr_to_expr =
let real = Real.create_q ratio s in
mkexpr Location.dummy_loc (Expr_const (Const_real real))
else if Z3.Arithmetic.is_int ze then
- mkexpr Location.dummy_loc
+ mkexpr
+ Location.dummy_loc
(Expr_const
(Const_int (Z.to_int (Z3.Arithmetic.Integer.get_big_int ze))))
else if Z3.Expr.is_const ze then
@@ -198,7 +205,9 @@ let expr_to_z3_expr, zexpr_to_expr =
| _ ->
assert false
else (
- Format.eprintf "Const err: %s %b@." (Z3.Expr.to_string ze)
+ Format.eprintf
+ "Const err: %s %b@."
+ (Z3.Expr.to_string ze)
(Z3.Expr.is_const ze);
assert false (* a numeral but no int nor real *))
in
@@ -226,7 +235,8 @@ let expr_to_z3_expr, zexpr_to_expr =
List.fold_left
(fun e e_new ->
mkpredef_call Location.dummy_loc op [ e; e_new ])
- first_binary_and tl
+ first_binary_and
+ tl
in
None, Some e
@@ -256,11 +266,15 @@ let expr_to_z3_expr, zexpr_to_expr =
x
| Some e1, Some e2 ->
Some (mkpredef_call Location.dummy_loc op [ e1; e2 ]) ))
- hd tl)
+ hd
+ tl)
| op ->
let args = List.map (fun ze -> snd (ze2e ze)) zel in
- Format.eprintf "deal with op %s (nb args: %i). Expr is %s@." op
- (List.length args) (Z3.Expr.to_string ze);
+ Format.eprintf
+ "deal with op %s (nb args: %i). Expr is %s@."
+ op
+ (List.length args)
+ (Z3.Expr.to_string ze);
assert false)
in
(fun e -> e2ze e), fun ze -> ze2e ze
@@ -309,8 +323,11 @@ let implies =
else (
if !seal_debug then
report ~level:6 (fun fmt ->
- Format.fprintf fmt "Checking implication: %s => %s?@ "
- (Z3.Expr.to_string ze1) (Z3.Expr.to_string ze2));
+ Format.fprintf
+ fmt
+ "Checking implication: %s => %s?@ "
+ (Z3.Expr.to_string ze1)
+ (Z3.Expr.to_string ze2));
let solver = Z3.Solver.mk_simple_solver !ctx in
let tgt = Z3.Boolean.mk_not !ctx (Z3.Boolean.mk_implies !ctx ze1 ze2) in
let res =
@@ -347,7 +364,8 @@ let rec simplify zl =
if implies hd e then true, accu (* throwing away e *)
else if implies e hd then false, e :: accu (* throwing away hd *)
else keep_hd, e :: accu (* keeping both *))
- (true, []) tl
+ (true, [])
+ tl
in
(* Format.eprintf "keep_hd?%b hd=%s, tl=[%a]@."
* keep_hd
@@ -377,13 +395,15 @@ let check_sat ?(just_check = false) (l : elem_boolexpr guard) :
l
in
if false then
- Format.eprintf "Z3 exprs1: [%a]@ "
+ Format.eprintf
+ "Z3 exprs1: [%a]@ "
(fprintf_list ~sep:",@ " (fun fmt e ->
Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
zl;
let zl = simplify zl in
if false then
- Format.eprintf "Z3 exprs2: [%a]@ "
+ Format.eprintf
+ "Z3 exprs2: [%a]@ "
(fprintf_list ~sep:",@ " (fun fmt e ->
Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
zl;
@@ -391,7 +411,8 @@ let check_sat ?(just_check = false) (l : elem_boolexpr guard) :
let status_res = Z3.Solver.check solver zl in
(* Format.eprintf "Z3 done@."; *)
if false then
- Format.eprintf "Z3 status: %s@ @]@. "
+ Format.eprintf
+ "Z3 status: %s@ @]@. "
(Z3.Solver.string_of_status status_res);
match status_res with
| Z3.Solver.UNSATISFIABLE ->
@@ -430,7 +451,8 @@ let clean_sys sys =
if sat then
(List.map (fun (e, b) -> deelem e, b) guards', updates) :: accu
else accu)
- [] sys
+ []
+ sys
(* Most costly function: has the be efficiently implemented. All registered
guards are initially produced by the call to combine_guards. We csan
@@ -510,7 +532,8 @@ let combine_guards ?(fresh = None) gl1 gl2 =
if keep_long_e then short, long_e :: long_sel, true
else short, long_sel, true
else [], [], false)
- (short, [], true) long
+ (short, [], true)
+ long
in
ok, long_sel @ short
in
@@ -538,8 +561,10 @@ let concatenate_ge gel1 posneg gel2 =
(* Format.eprintf "@]@ Result is [%a]@ " * pp_guard_list gl; *)
if ok then (gl, e2) :: accu, false else accu, all_invalid)
- (accu, all_invalid) gel1)
- ([], true) gel2
+ (accu, all_invalid)
+ gel1)
+ ([], true)
+ gel2
in
not all_invalid, l
@@ -604,7 +629,8 @@ let rec rewrite defs expr : elem_guarded_expr list =
let e = rewrite e in
let ok, g_eq_id = concatenate_ge g true e in
if ok then g_eq_id @ accu else accu)
- [] branches
+ []
+ branches
else assert false (* g should be defined already *)
| Expr_when (e, id, l) ->
let e = rewrite e in
@@ -637,8 +663,10 @@ let rec rewrite defs expr : elem_guarded_expr list =
in
new_gt :: accu
else accu)
- accu getl)
- [] gel
+ accu
+ getl)
+ []
+ gel
in
let gtuples = aux gell in
(* Rebuilding the valid type: guarded expr list (with tuple exprs) *)
@@ -673,8 +701,12 @@ and add_def defs vid expr =
* (Utils.fprintf_list ~sep:"@ "
* (pp_guard_expr pp_elem)) vid_defs; *)
report ~level:6 (fun fmt ->
- Format.fprintf fmt "Add_def: %s = %a@. -> @[<v 0>%a@]@." vid
- Printers.pp_expr expr
+ Format.fprintf
+ fmt
+ "Add_def: %s = %a@. -> @[<v 0>%a@]@."
+ vid
+ Printers.pp_expr
+ expr
(Utils.fprintf_list ~sep:"@ " (pp_guard_expr pp_elem))
vid_defs);
Hashtbl.add defs vid vid_defs;
@@ -701,12 +733,17 @@ let split_mdefs elem (mdefs : elem_guarded_expr list) =
lists *)
ge :: selected, ge :: left_out
| _ ->
- Format.eprintf "@.Spliting list on elem %a.@.List:%a@." pp_elem elem
- (pp_mdefs pp_elem) mdefs;
+ Format.eprintf
+ "@.Spliting list on elem %a.@.List:%a@."
+ pp_elem
+ elem
+ (pp_mdefs pp_elem)
+ mdefs;
assert false
(* more then one element selected. Should not happen , or trival dead code
like if x then if not x then dead code *))
- ([], []) mdefs
+ ([], [])
+ mdefs
let split_mem_defs (elem : element)
(mem_defs : (ident * elem_guarded_expr list) list) :
@@ -716,7 +753,8 @@ let split_mem_defs (elem : element)
(fun (m, mdefs) (accu_pos, accu_neg) ->
let pos, neg = split_mdefs elem mdefs in
(m, pos) :: accu_pos, (m, neg) :: accu_neg)
- mem_defs ([], [])
+ mem_defs
+ ([], [])
(* Split a list of mem_defs into init and step lists of guarded expressions per
memory. *)
@@ -748,7 +786,8 @@ let rec pick_guard mem_defs : expr option =
| (IsInit, _) :: _ ->
assert false (* should be removed already *)
else found)
- None gel
+ None
+ gel
in
if found = None then pick_guard tl else found
@@ -759,7 +798,10 @@ let rec build_switch_sys
((expr * bool) list * (ident * expr) list) list =
if !seal_debug then
report ~level:4 (fun fmt ->
- Format.fprintf fmt "@[<v 2>Build_switch with@ %a@]@." pp_all_defs
+ Format.fprintf
+ fmt
+ "@[<v 2>Build_switch with@ %a@]@."
+ pp_all_defs
mem_defs);
(* if all mem_defs have empty guards, we are done, return prefix, mem_defs
expr.
@@ -803,7 +845,9 @@ let rec build_switch_sys
let elem_opt : expr option = pick_guard mem_defs in
match elem_opt with
| None ->
- Format.eprintf "Issues picking guard in mem_defs: %a@." pp_all_defs
+ Format.eprintf
+ "Issues picking guard in mem_defs: %a@."
+ pp_all_defs
mem_defs;
assert false (* Otherwise the first case should have matched *)
| Some elem -> (
@@ -834,8 +878,11 @@ let rec build_switch_sys
let clean l =
let l = List.map (fun (e, b) -> Expr e, b) l in
report ~level:4 (fun fmt ->
- Format.fprintf fmt "Checking satisfiability of %a@."
- (pp_guard_list pp_elem) l);
+ Format.fprintf
+ fmt
+ "Checking satisfiability of %a@."
+ (pp_guard_list pp_elem)
+ l);
let ok, l = check_sat l in
let l = List.map (fun (e, b) -> deelem e, b) l in
ok, l
@@ -865,9 +912,13 @@ let rec build_switch_sys
Format.fprintf fmt "@[<v 2>===> @[%t@ @]@]@ @]@ " (fun fmt ->
List.iter
(fun (gl, up) ->
- Format.fprintf fmt "[@[%a@]] -> (%a)@ "
+ Format.fprintf
+ fmt
+ "[@[%a@]] -> (%a)@ "
(pp_guard_list Printers.pp_expr)
- gl (pp_up Printers.pp_expr) up)
+ gl
+ (pp_up Printers.pp_expr)
+ up)
res));
res
@@ -897,7 +948,10 @@ let build_environement consts (mems : var_decl list) nd =
List.iter
(fun v ->
let fdecl =
- Z3.FuncDecl.mk_func_decl_s !ctx v.var_id []
+ Z3.FuncDecl.mk_func_decl_s
+ !ctx
+ v.var_id
+ []
(Zustre_common.type_to_sort v.var_type)
in
ignore (Zustre_common.register_fdecl v.var_id fdecl))
@@ -908,8 +962,11 @@ let build_environement consts (mems : var_decl list) nd =
in
report ~level:4 (fun fmt ->
- Format.fprintf fmt "Computing definitions for equations@.%a@."
- Printers.pp_node_eqs sorted_eqs);
+ Format.fprintf
+ fmt
+ "Computing definitions for equations@.%a@."
+ Printers.pp_node_eqs
+ sorted_eqs);
(* Registering node equations: identifying mem definitions and storing others
in the "defs" hashtbl.
@@ -931,7 +988,10 @@ let build_environement consts (mems : var_decl list) nd =
Format.fprintf fmt "Preparing mem %s@." vid);
let def_vid = rewrite defs def_m in
report ~level:4 (fun fmt ->
- Format.fprintf fmt "%s = %a@." vid
+ Format.fprintf
+ fmt
+ "%s = %a@."
+ vid
(Utils.fprintf_list ~sep:"@ " (pp_guard_expr pp_elem))
def_vid);
(vid, def_vid) :: accu_mems, accu_outputs
@@ -950,19 +1010,26 @@ let build_environement consts (mems : var_decl list) nd =
| _ ->
assert false
(* should have been removed by normalization *))
- ([], []) sorted_eqs
+ ([], [])
+ sorted_eqs
in
report ~level:1 (fun fmt ->
Format.fprintf fmt "registering all definitions done@.");
report ~level:2 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"Printing out (guarded) memories definitions (may takes time)@.");
(* Printing memories definitions *)
report ~level:3 (fun fmt ->
- Format.fprintf fmt "@[<v 0>%a@]@."
+ Format.fprintf
+ fmt
+ "@[<v 0>%a@]@."
(Utils.fprintf_list ~sep:"@ " (fun fmt (m, mdefs) ->
- Format.fprintf fmt "%s -> [@[<v 0>%a@] ]@ " m
+ Format.fprintf
+ fmt
+ "%s -> [@[<v 0>%a@] ]@ "
+ m
(Utils.fprintf_list ~sep:"@ " (pp_guard_expr pp_elem))
mdefs))
mem_defs);
@@ -987,7 +1054,8 @@ let merge_updates sys =
let guard_set = UpMap.find up map in
UpMap.add up (new_set :: guard_set) map
else UpMap.add up [ new_set ] map)
- UpMap.empty sys
+ UpMap.empty
+ sys
in
(* Processing the set of guards leading to the same update: return conj, disj
@@ -1059,11 +1127,15 @@ let merge_updates sys =
(fun up (common, disj) accu ->
if !seal_debug then
report ~level:6 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"Guards:@.shared: [%a]@.disj: [@[<v 0>%a@ ]@]@.Updates: %a@."
- Guards.pp_short common
+ Guards.pp_short
+ common
(fprintf_list ~sep:";@ " Guards.pp_long)
- disj UpMap.pp up);
+ disj
+ UpMap.pp
+ up);
let disj = clean_disj disj in
let guard_expr = gl_as_expr common @ disj in
@@ -1074,7 +1146,8 @@ let merge_updates sys =
Some (mk_binop "&&" guard_expr)),
up )
:: accu)
- map []
+ map
+ []
(* Take a normalized node and extract a list of switches: (cond, update) meaning
"if cond then update" where update shall define all node memories. Everything
@@ -1087,8 +1160,13 @@ let node_as_switched_sys consts (mems : var_decl list) nd =
let init_out, update_out = split_init output_defs in
report ~level:3 (fun fmt ->
- Format.fprintf fmt "@[<v 0>Init:@ %a@ Step:@ %a@]@."
- (pp_assign_map pp_elem) init_defs (pp_assign_map pp_elem) update_defs);
+ Format.fprintf
+ fmt
+ "@[<v 0>Init:@ %a@ Step:@ %a@]@."
+ (pp_assign_map pp_elem)
+ init_defs
+ (pp_assign_map pp_elem)
+ update_defs);
report ~level:1 (fun fmt ->
Format.fprintf fmt "init/step as a switched system ...@.");
@@ -1122,7 +1200,8 @@ let node_as_switched_sys consts (mems : var_decl list) nd =
report ~level:3 (fun fmt -> Format.fprintf fmt "Process update_out:@.");
let update_out = merge_updates update_out in
report ~level:1 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"removing dead branches and merging remaining ... done@.");
sw_init, sw_sys, init_out, update_out
@@ -1141,7 +1220,8 @@ let fun_as_switched_sys consts nd =
let update_out = clean_sys update_out in
let update_out = merge_updates update_out in
report ~level:1 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"removing dead branches and merging remaining ... done@.");
update_out
diff --git a/src/tools/seal/seal_slice.ml b/src/tools/seal/seal_slice.ml
index 5f5743a6..4f13c2b3 100644
--- a/src/tools/seal/seal_slice.ml
+++ b/src/tools/seal/seal_slice.ml
@@ -32,7 +32,10 @@ let coi_var deps nd v =
(ISet.singleton vname, ISet.empty)
in
report ~level:3 (fun fmt ->
- Format.fprintf fmt "COI of var %s: (%a // %a)@." v.var_id
+ Format.fprintf
+ fmt
+ "COI of var %s: (%a // %a)@."
+ v.var_id
(fprintf_list ~sep:"," Format.pp_print_string)
(ISet.elements vset)
(fprintf_list ~sep:"," Format.pp_print_string)
@@ -71,7 +74,9 @@ let slice_node vars_to_keep msch nd =
compute_sliced_vars vars_to_keep msch.Scheduling_type.dep_graph nd
in
report ~level:3 (fun fmt ->
- Format.fprintf fmt "COI Vars: %a@."
+ Format.fprintf
+ fmt
+ "COI Vars: %a@."
(Utils.fprintf_list ~sep:"," Format.pp_print_string)
coi_vars);
let outputs =
@@ -81,7 +86,8 @@ let slice_node vars_to_keep msch nd =
match outputs with
| [] ->
report ~level:2 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"No visible output variable, subtituting with provided vars@ ");
vars_to_keep
| l ->
diff --git a/src/tools/seal/seal_utils.ml b/src/tools/seal/seal_utils.ml
index 038185e8..771bc183 100644
--- a/src/tools/seal/seal_utils.ml
+++ b/src/tools/seal/seal_utils.ml
@@ -29,11 +29,17 @@ let pp_elem fmt e =
let pp_guard_list pp_elem fmt gl =
(fprintf_list ~sep:";@ " (fun fmt (e, b) ->
if b then pp_elem fmt e else Format.fprintf fmt "not(%a)" pp_elem e))
- fmt gl
+ fmt
+ gl
let pp_guard_expr pp_elem fmt (gl, e) =
- Format.fprintf fmt "@[<v 2>@[%a@] ->@ @[<hov 2>%a@]@]" (pp_guard_list pp_elem)
- gl pp_elem e
+ Format.fprintf
+ fmt
+ "@[<v 2>@[%a@] ->@ @[<hov 2>%a@]@]"
+ (pp_guard_list pp_elem)
+ gl
+ pp_elem
+ e
let pp_mdefs pp_elem fmt gel =
fprintf_list ~sep:"@ " (pp_guard_expr pp_elem) fmt gel
@@ -64,20 +70,29 @@ let pp_gl_short =
pp_gl (fun fmt e -> Format.fprintf fmt "%i" e.Lustre_types.expr_tag)
let pp_up pp_elem fmt up =
- fprintf_list ~sep:"@ "
+ fprintf_list
+ ~sep:"@ "
(fun fmt (id, e) -> Format.fprintf fmt "%s == %a;@ " id pp_elem e)
- fmt up
+ fmt
+ up
let pp_sys pp_elem fmt sw =
- fprintf_list ~sep:"@ "
+ fprintf_list
+ ~sep:"@ "
(fun fmt (gl, up) ->
match gl with
| None ->
(pp_up pp_elem) fmt up
| Some gl ->
- Format.fprintf fmt "@[<v 2>[@[%a@]]:@ %a@]" Printers.pp_expr gl
- (pp_up pp_elem) up)
- fmt sw
+ Format.fprintf
+ fmt
+ "@[<v 2>[@[%a@]]:@ %a@]"
+ Printers.pp_expr
+ gl
+ (pp_up pp_elem)
+ up)
+ fmt
+ sw
let pp_all_defs =
Utils.fprintf_list ~sep:",@ " (fun fmt (id, gel) ->
diff --git a/src/tools/seal/seal_verifier.ml b/src/tools/seal/seal_verifier.ml
index 546ef3c3..5abd6b12 100644
--- a/src/tools/seal/seal_verifier.ml
+++ b/src/tools/seal/seal_verifier.ml
@@ -43,7 +43,8 @@ let seal_run ~basename prog machines =
match !Options.main_node with
| "" ->
Format.eprintf "SEAL verifier requires a main node.@.";
- Format.eprintf "@[<v 2>Available ones are:@ %a@]@.@?"
+ Format.eprintf
+ "@[<v 2>Available ones are:@ %a@]@.@?"
(Utils.fprintf_list ~sep:"@ " (fun fmt m ->
Format.fprintf fmt "%s" m.Machine_code_types.mname.node_id))
machines;
@@ -53,7 +54,9 @@ let seal_run ~basename prog machines =
match Machine_code_common.get_machine_opt machines s with
| None ->
Global.main_node := s;
- Format.eprintf "Code generation error: %a@." Error.pp_error_msg
+ Format.eprintf
+ "Code generation error: %a@."
+ Error.pp_error_msg
Error.Main_not_found;
raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
| Some _ ->
@@ -64,7 +67,10 @@ let seal_run ~basename prog machines =
let mems = m.mmemory in
report ~level:1 (fun fmt ->
- Format.fprintf fmt "Node %s compiled: %i memories@." nd.node_id
+ Format.fprintf
+ fmt
+ "Node %s compiled: %i memories@."
+ nd.node_id
(List.length mems));
(* Slicing node *)
@@ -82,8 +88,12 @@ let seal_run ~basename prog machines =
let update_out = fun_as_switched_sys consts sliced_nd in
report ~level:1 (fun fmt ->
- Format.fprintf fmt "Output (%i step switch cases):@ @[<v 0>%a@]@."
- (List.length update_out) pp_sys update_out);
+ Format.fprintf
+ fmt
+ "Output (%i step switch cases):@ @[<v 0>%a@]@."
+ (List.length update_out)
+ pp_sys
+ update_out);
let _ =
match !seal_export with
@@ -104,23 +114,40 @@ let seal_run ~basename prog machines =
in
report ~level:1 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"DynSys: (%i memories, %i init, %i step switch cases)@ @[<v 0>@[<v \
3>Init:@ %a@]@ @[<v 3>Step:@ %a@]@]@."
- (List.length mems) (List.length sw_init) (List.length sw_sys) pp_sys
- sw_init pp_sys sw_sys);
+ (List.length mems)
+ (List.length sw_init)
+ (List.length sw_sys)
+ pp_sys
+ sw_init
+ pp_sys
+ sw_sys);
report ~level:1 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"Output (%i init, %i step switch cases):@ @[<v 0>@[<v 3>Init:@ %a@]@ \
@[<v 3>Step:@ %a@]@]@."
- (List.length init_out) (List.length update_out) pp_sys init_out pp_sys
+ (List.length init_out)
+ (List.length update_out)
+ pp_sys
+ init_out
+ pp_sys
update_out);
let _ =
match !seal_export with
| Some "lustre" | Some "lus" ->
- Seal_export.node_to_lustre basename prog m sw_init sw_sys init_out
+ Seal_export.node_to_lustre
+ basename
+ prog
+ m
+ sw_init
+ sw_sys
+ init_out
update_out
| Some "matlab" | Some "m" ->
assert false (* TODO *)
diff --git a/src/tools/stateflow/common/basetypes.ml b/src/tools/stateflow/common/basetypes.ml
index 2a431bbd..9769c916 100644
--- a/src/tools/stateflow/common/basetypes.ml
+++ b/src/tools/stateflow/common/basetypes.ml
@@ -36,7 +36,9 @@ let pp_junction_name = Format.pp_print_string
let pp_path fmt p =
Utils.Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_string fmt ".")
- pp_state_name fmt p
+ pp_state_name
+ fmt
+ p
(* XXX: UNUSED *)
(* let pp_event fmt e =
@@ -124,8 +126,17 @@ module Action = struct
match call with
| Ecall ->
fun (p, p', f) ->
- Format.fprintf fmt "%a(%a, %a, %a)" pp_call call pp_path p pp_path p'
- pp_frontier f
+ Format.fprintf
+ fmt
+ "%a(%a, %a, %a)"
+ pp_call
+ call
+ pp_path
+ p
+ pp_path
+ p'
+ pp_frontier
+ f
| Dcall ->
fun p -> Format.fprintf fmt "%a(%a)" pp_call call pp_path p
| Xcall ->
diff --git a/src/tools/stateflow/common/datatype.ml b/src/tools/stateflow/common/datatype.ml
index 2726d62b..1aacdb3b 100644
--- a/src/tools/stateflow/common/datatype.ml
+++ b/src/tools/stateflow/common/datatype.ml
@@ -97,7 +97,8 @@ module SF = struct
res
| SFFunction _ ->
res)
- ActiveStates.Vars.empty defs
+ ActiveStates.Vars.empty
+ defs
(* XXX: UNUSED *)
(* let init_env model = ActiveStates.Env.from_set (states model) false *)
@@ -121,13 +122,25 @@ module SF = struct
Format.fprintf fmt "Junction %a" pp_junction_name j
let pp_trans fmt t =
- Format.fprintf fmt "@[<hov 0>(@[<hov 0>%a,@ %a,@ %a,@ %a,@ %a@]@ )@]"
- pp_event t.event Condition.pp_cond t.condition Action.pp_act
- t.condition_act Action.pp_act t.transition_act pp_dest t.dest
+ Format.fprintf
+ fmt
+ "@[<hov 0>(@[<hov 0>%a,@ %a,@ %a,@ %a,@ %a@]@ )@]"
+ pp_event
+ t.event
+ Condition.pp_cond
+ t.condition
+ Action.pp_act
+ t.condition_act
+ Action.pp_act
+ t.transition_act
+ pp_dest
+ t.dest
let pp_transitions fmt l =
Format.(
- fprintf fmt "@[<hov 0>[@[<hov 0>%a@]@ ]@]"
+ fprintf
+ fmt
+ "@[<hov 0>[@[<hov 0>%a@]@ ]@]"
(pp_print_list ~pp_sep:pp_print_semicolon pp_trans)
l)
@@ -135,12 +148,18 @@ module SF = struct
match c with
| Or (_T, _S) ->
Format.(
- fprintf fmt "Or(%a, {%a})" pp_transitions _T
+ fprintf
+ fmt
+ "Or(%a, {%a})"
+ pp_transitions
+ _T
(pp_print_list ~pp_sep:pp_print_semicolon pp_state_name)
_S)
| And _S ->
Format.(
- fprintf fmt "And({%a})"
+ fprintf
+ fmt
+ "And({%a})"
(pp_print_list ~pp_sep:pp_print_semicolon pp_state_name)
_S)
diff --git a/src/tools/stateflow/json-parser/json_parser.ml b/src/tools/stateflow/json-parser/json_parser.ml
index 7ca93ae8..24397a93 100644
--- a/src/tools/stateflow/json-parser/json_parser.ml
+++ b/src/tools/stateflow/json-parser/json_parser.ml
@@ -150,7 +150,8 @@ module Parser (Ext : ParseExt) = struct
match datatype with
| "bool" ->
( Tydec_bool,
- mkexpr location
+ mkexpr
+ location
(Expr_const
(Const_tag
((fun s ->
@@ -180,7 +181,9 @@ module Parser (Ext : ParseExt) = struct
m "parse_variable %s" (json |> member "name" |> to_string));
let location = Location.dummy_loc in
let datatype, initial_value = lustre_datatype_of_json json location in
- mkvar_decl location ~orig:true
+ mkvar_decl
+ location
+ ~orig:true
( json |> member "name" |> to_string,
{ ty_dec_desc = datatype; ty_dec_loc = location },
{ ck_dec_desc = Ckdec_any; ck_dec_loc = location },
diff --git a/src/tools/stateflow/json-parser/main_parse_json_file.ml b/src/tools/stateflow/json-parser/main_parse_json_file.ml
index 86800966..f1930ddf 100644
--- a/src/tools/stateflow/json-parser/main_parse_json_file.ml
+++ b/src/tools/stateflow/json-parser/main_parse_json_file.ml
@@ -52,7 +52,8 @@ module ParseExt = struct
let loc = Location.dummy_loc in
raise (Parse.Error (loc, Parse.String_Syntax_error actions)))
with Util.Type_error _ ->
- Format.eprintf "Unable to explore json subtree: empty string %s@."
+ Format.eprintf
+ "Unable to explore json subtree: empty string %s@."
(to_string json);
default
@@ -63,7 +64,9 @@ module ParseExt = struct
{ expr = e; cinputs = in_; coutputs = out_; cvariables = locals_ })
let parse_action =
- protect Action.nil Parser_lustre.stmt_list
+ protect
+ Action.nil
+ Parser_lustre.stmt_list
(fun (stmts, asserts, annots) (in_, out_, locals_) ->
if asserts != [] || annots != [] then assert false
(* Stateflow equations should not use asserts nor define annotations *)
@@ -125,7 +128,8 @@ let json_parse _ file pp =
let module Sem = CPS.Semantics (T) (Model) in
let prog = Sem.code_gen modularmode in
let header =
- List.map Corelang.mktop
+ List.map
+ Corelang.mktop
[
LustreSpec.Open (false, "lustrec_math");
LustreSpec.Open (false, "conv");
@@ -155,8 +159,12 @@ let json_parse _ file pp =
Format.eprintf "Print expanded lustre model in sf_gen_test_noauto.lus@.";
()
with Parse.Error (l, err) ->
- Format.eprintf "Parse error at loc %a : %a@.@?" Location.pp_loc l
- Parse.pp_error err
+ Format.eprintf
+ "Parse error at loc %a : %a@.@?"
+ Location.pp_loc
+ l
+ Parse.pp_error
+ err
(* term representing argument for file *)
let file =
diff --git a/src/tools/stateflow/json-parser/test_json_parser_variables.ml b/src/tools/stateflow/json-parser/test_json_parser_variables.ml
index e4cc8929..534b7421 100644
--- a/src/tools/stateflow/json-parser/test_json_parser_variables.ml
+++ b/src/tools/stateflow/json-parser/test_json_parser_variables.ml
@@ -44,19 +44,25 @@ let test_var_skeleton var id var_type value =
assert_bool "user variables are considered as constants" var.var_dec_const;
assert_equal
~msg:("problem with variable " ^ var.var_id ^ " clock type")
- Ckdec_any var.var_dec_clock.ck_dec_desc;
+ Ckdec_any
+ var.var_dec_clock.ck_dec_desc;
assert_equal
~msg:("problem with variable " ^ var.var_id ^ " ident")
~printer:(fun x -> x)
- id var.var_id;
+ id
+ var.var_id;
assert_equal
~msg:("problem with variable " ^ var.var_id ^ " type")
- ~printer:string_of_var_type var_type var.var_dec_type.ty_dec_desc;
+ ~printer:string_of_var_type
+ var_type
+ var.var_dec_type.ty_dec_desc;
match var.var_dec_value with
| Some { expr_desc = d } ->
assert_equal
~msg:("problem with variable " ^ var.var_id ^ " value")
- ~printer:string_of_var_value value d
+ ~printer:string_of_var_value
+ value
+ d
| _ ->
raise
(OUnitTest.OUnit_failure "User variables should have an initial value")
@@ -68,7 +74,10 @@ let test_simple_var_bool_false tests_ctxt =
in
match prog with
| Program ("simple_var_bool_false", [], [ x ]) ->
- test_var_skeleton x "my_bool_var_false" Tydec_bool
+ test_var_skeleton
+ x
+ "my_bool_var_false"
+ Tydec_bool
(Expr_const (Const_tag tag_false))
| _ ->
raise
@@ -82,7 +91,10 @@ let test_simple_var_bool_true tests_ctxt =
in
match prog with
| Program ("simple_var_bool_true", [], [ x ]) ->
- test_var_skeleton x "my_bool_var_true" Tydec_bool
+ test_var_skeleton
+ x
+ "my_bool_var_true"
+ Tydec_bool
(Expr_const (Const_tag tag_true))
| _ ->
raise
@@ -135,7 +147,10 @@ let test_simple_var_real_zero tests_ctxt =
in
match prog with
| Program ("simple_var_real_zero", [], [ x ]) ->
- test_var_skeleton x "my_real_var_zero" Tydec_real
+ test_var_skeleton
+ x
+ "my_real_var_zero"
+ Tydec_real
(Expr_const (Const_real (Num.num_of_int 0, 1, "0.0")))
| _ ->
raise
@@ -149,7 +164,10 @@ let test_simple_var_real_pos tests_ctxt =
in
match prog with
| Program ("simple_var_real_pos", [], [ x ]) ->
- test_var_skeleton x "my_real_var_pos" Tydec_real
+ test_var_skeleton
+ x
+ "my_real_var_pos"
+ Tydec_real
(Expr_const (Const_real (Num.num_of_int 2115, 2, "21.15")))
| _ ->
raise
@@ -163,7 +181,10 @@ let test_simple_var_real_neg tests_ctxt =
in
match prog with
| Program ("simple_var_real_neg", [], [ x ]) ->
- test_var_skeleton x "my_real_var_neg" Tydec_real
+ test_var_skeleton
+ x
+ "my_real_var_neg"
+ Tydec_real
(Expr_const (Const_real (Num.num_of_int (-224), 2, "-2.24")))
| _ ->
raise
@@ -177,7 +198,10 @@ let test_simple_var_real_e tests_ctxt =
in
match prog with
| Program ("simple_var_real_e", [], [ x ]) ->
- test_var_skeleton x "my_real_var_e" Tydec_real
+ test_var_skeleton
+ x
+ "my_real_var_e"
+ Tydec_real
(Expr_const (Const_real (Num.num_of_int (-2115), 4, "-21.15e-02")))
| _ ->
raise
diff --git a/src/tools/stateflow/models/model_medium.ml b/src/tools/stateflow/models/model_medium.ml
index b07930cb..20092c55 100644
--- a/src/tools/stateflow/models/model_medium.ml
+++ b/src/tools/stateflow/models/model_medium.ml
@@ -5,7 +5,8 @@ let name = "medium"
let condition x =
condition
- (Corelang.mkexpr Location.dummy_loc
+ (Corelang.mkexpr
+ Location.dummy_loc
(LustreSpec.Expr_const (Corelang.const_of_bool true)))
let model : prog_t =
diff --git a/src/tools/stateflow/models/model_simple.ml b/src/tools/stateflow/models/model_simple.ml
index c7ae2c01..86b8a810 100644
--- a/src/tools/stateflow/models/model_simple.ml
+++ b/src/tools/stateflow/models/model_simple.ml
@@ -8,7 +8,8 @@ let condition _ =
condition
{
expr =
- Corelang.mkexpr Location.dummy
+ Corelang.mkexpr
+ Location.dummy
(Lustre_types.Expr_const (Corelang.const_of_bool true));
cinputs = [];
coutputs = [];
diff --git a/src/tools/stateflow/models/model_stopwatch.ml b/src/tools/stateflow/models/model_stopwatch.ml
index 4f1fbd18..e2a95895 100644
--- a/src/tools/stateflow/models/model_stopwatch.ml
+++ b/src/tools/stateflow/models/model_stopwatch.ml
@@ -17,7 +17,8 @@ let condition _ =
condition
{
expr =
- Corelang.mkexpr Location.dummy
+ Corelang.mkexpr
+ Location.dummy
(Lustre_types.Expr_const (Corelang.const_of_bool true));
cinputs = [];
coutputs = [];
@@ -293,7 +294,8 @@ let model =
let int_typ = Corelang.mktyp Location.dummy Lustre_types.Tydec_int in
List.map
(fun k ->
- ( Corelang.mkvar_decl Location.dummy
+ ( Corelang.mkvar_decl
+ Location.dummy
( k,
(* name *)
int_typ,
@@ -306,7 +308,8 @@ let model =
(* no default value *)
None (* no parent known *) ),
(* Default value is zero *)
- Corelang.mkexpr Location.dummy
+ Corelang.mkexpr
+ Location.dummy
(Lustre_types.Expr_const (Lustre_types.Const_int 0)) ))
[ "cent"; "sec"; "min"; "cont" ]
in
diff --git a/src/tools/stateflow/semantics/cPS_evaluator.ml b/src/tools/stateflow/semantics/cPS_evaluator.ml
index bc33cc99..40a997cc 100644
--- a/src/tools/stateflow/semantics/cPS_evaluator.ml
+++ b/src/tools/stateflow/semantics/cPS_evaluator.ml
@@ -32,8 +32,11 @@ let _main_ _ = function
let run_trace model func t =
let init_env = Datatype.SF.init_env model in
let _ =
- Format.printf "Model definitions@.%a@.Initial state: %s @.####"
- Datatype.SF.pp_src (snd model) (fst model)
+ Format.printf
+ "Model definitions@.%a@.Initial state: %s @.####"
+ Datatype.SF.pp_src
+ (snd model)
+ (fst model)
in
let final_env, cpt =
@@ -53,7 +56,8 @@ let run_trace model func t =
in
(* we do not consider produced events *)
env', cpt + 1)
- (init_env, 1) t
+ (init_env, 1)
+ t
in
Format.printf "#### %i@.%a@." cpt ActiveStates.Env.pp_env final_env;
()
@@ -152,14 +156,41 @@ module Evaluator :
match call with
| Ecall ->
fun (p, p', f) tr ->
- Format.fprintf fmt "component %a(%a, %a, %a) =@.%a" pp_call call pp_path
- p pp_path p' pp_frontier f pp_transformer tr
+ Format.fprintf
+ fmt
+ "component %a(%a, %a, %a) =@.%a"
+ pp_call
+ call
+ pp_path
+ p
+ pp_path
+ p'
+ pp_frontier
+ f
+ pp_transformer
+ tr
| Dcall ->
fun p tr ->
- Format.fprintf fmt "component %a(%a) =@.%a" pp_call call pp_path p
- pp_transformer tr
+ Format.fprintf
+ fmt
+ "component %a(%a) =@.%a"
+ pp_call
+ call
+ pp_path
+ p
+ pp_transformer
+ tr
| Xcall ->
fun (p, f) tr ->
- Format.fprintf fmt "component %a(%a, %a) =@.%a" pp_call call pp_path p
- pp_frontier f pp_transformer tr
+ Format.fprintf
+ fmt
+ "component %a(%a, %a) =@.%a"
+ pp_call
+ call
+ pp_path
+ p
+ pp_frontier
+ f
+ pp_transformer
+ tr
end
diff --git a/src/tools/stateflow/semantics/cPS_interpreter.ml b/src/tools/stateflow/semantics/cPS_interpreter.ml
index 30ea9a5c..d49161ff 100644
--- a/src/tools/stateflow/semantics/cPS_interpreter.ml
+++ b/src/tools/stateflow/semantics/cPS_interpreter.ml
@@ -138,7 +138,8 @@ module Interpreter (Transformer : TransformerType) = struct
in
let cond = Transformer.(event trans.event && trans.condition) in
Transformer.(
- eval_cond cond
+ eval_cond
+ cond
(eval_act (module Theta) trans.condition_act
>> eval_dest trans.dest wrapper success' fail)
fail.local)
@@ -159,9 +160,17 @@ module Interpreter (Transformer : TransformerType) = struct
let rec eval_open_path mode p p1 p2 success_p2 =
Log.report ~level:sf_level (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"@[<v 2>open_path_rec[[mode %a, prefix %a, src %a, dst %a]]@ "
- pp_mode mode pp_path p pp_path p1 pp_path p2);
+ pp_mode
+ mode
+ pp_path
+ p
+ pp_path
+ p1
+ pp_path
+ p2);
match frontier p1, frontier p2 with
| ([ x ], ps), ([ y ], pd) when x = y ->
eval_open_path mode (p @ [ x ]) ps pd success_p2
@@ -193,8 +202,15 @@ module Interpreter (Transformer : TransformerType) = struct
| E -> (
Transformer.(
Log.report ~level:sf_level (fun fmt ->
- Format.fprintf fmt "@[<v 2>C_%a[[%a, %a]]@ " pp_tag tag pp_path
- prefix SF.pp_comp comp);
+ Format.fprintf
+ fmt
+ "@[<v 2>C_%a[[%a, %a]]@ "
+ pp_tag
+ tag
+ pp_path
+ prefix
+ SF.pp_comp
+ comp);
match comp with
| Or (_T, []) ->
null
@@ -207,7 +223,8 @@ module Interpreter (Transformer : TransformerType) = struct
| And _S ->
List.fold_right
(fun p -> ( >> ) (Theta.theta E (prefix @ [ p ]) [] Loose))
- _S null))
+ _S
+ null))
| D -> (
Transformer.(
match comp with
@@ -221,7 +238,8 @@ module Interpreter (Transformer : TransformerType) = struct
| And _S ->
List.fold_right
(fun p -> ( >> ) (Theta.theta D (prefix @ [ p ])))
- _S null))
+ _S
+ null))
| X -> (
Transformer.(
match comp with
@@ -235,7 +253,8 @@ module Interpreter (Transformer : TransformerType) = struct
| And _S ->
List.fold_right
(fun p -> ( >> ) (Theta.theta X (prefix @ [ p ]) Loose))
- _S null))
+ _S
+ null))
| J ->
assert false
@@ -248,9 +267,17 @@ module Interpreter (Transformer : TransformerType) = struct
fun path frontier ->
Transformer.(
Log.report ~level:sf_level (fun fmt ->
- Format.fprintf fmt
- "@[<v 2>S_%a[[node %a, dest %a, frontier %a]]@ " pp_tag tag
- pp_path p pp_path path pp_frontier frontier);
+ Format.fprintf
+ fmt
+ "@[<v 2>S_%a[[node %a, dest %a, frontier %a]]@ "
+ pp_tag
+ tag
+ pp_path
+ p
+ pp_path
+ path
+ pp_frontier
+ frontier);
frontier = Loose
>? (eval_act (module Theta) p_def.state_actions.entry_act
>> eval_act (module Theta) (open_path p))
@@ -263,7 +290,12 @@ module Interpreter (Transformer : TransformerType) = struct
| D ->
Transformer.(
Log.report ~level:sf_level (fun fmt ->
- Format.fprintf fmt "@[<v 2>S_%a[[node %a]]@ " pp_tag tag pp_path
+ Format.fprintf
+ fmt
+ "@[<v 2>S_%a[[node %a]]@ "
+ pp_tag
+ tag
+ pp_path
p);
let wrapper_i = eval_open_path Inner [] p in
let wrapper_o = eval_open_path Outer [] p in
@@ -284,8 +316,15 @@ module Interpreter (Transformer : TransformerType) = struct
fun frontier ->
Transformer.(
Log.report ~level:sf_level (fun fmt ->
- Format.fprintf fmt "@[<v 2>S_%a[[node %a, frontier %a]]@ "
- pp_tag tag pp_path p pp_frontier frontier);
+ Format.fprintf
+ fmt
+ "@[<v 2>S_%a[[node %a, frontier %a]]@ "
+ pp_tag
+ tag
+ pp_path
+ p
+ pp_frontier
+ frontier);
eval_C X p p_def.internal_composition
>> (frontier = Loose
>? (eval_act (module Theta) p_def.state_actions.exit_act
diff --git a/src/tools/stateflow/semantics/cPS_lustre_generator.ml b/src/tools/stateflow/semantics/cPS_lustre_generator.ml
index a424453a..8c9d3709 100644
--- a/src/tools/stateflow/semantics/cPS_lustre_generator.ml
+++ b/src/tools/stateflow/semantics/cPS_lustre_generator.ml
@@ -37,7 +37,9 @@ end) : TransformerType = struct
fprintf fmt "%s%t" prefix (fun fmt ->
pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt "_")
- pp_print_string fmt path))
+ pp_print_string
+ fmt
+ path))
(* let pp_typed_path sin fmt path =
* Format.fprintf fmt "%a : bool" (pp_path sin) path *)
@@ -56,7 +58,8 @@ end) : TransformerType = struct
let mkvar name typ =
let loc = Location.dummy in
- Corelang.mkvar_decl loc
+ Corelang.mkvar_decl
+ loc
( name,
typ,
Corelang.mkclock loc Lustre_types.Ckdec_any,
@@ -76,7 +79,8 @@ end) : TransformerType = struct
ActiveStates.Vars.fold
(fun v accu ->
state_vars_to_vdecl_list ~prefix:(List.hd v) Vars.state_vars @ accu)
- locs []
+ locs
+ []
(* TODO: declare global vars *)
let mkeq = Corelang.mkeq Location.dummy
@@ -170,16 +174,37 @@ end) : TransformerType = struct
match call with
| Ecall ->
fun (p, p', f) ->
- Format.fprintf Format.str_formatter "theta%a%a%a_%a" pp_call call
- (pp_path "_from_") p (pp_path "_to_") p' pp_frontier f
+ Format.fprintf
+ Format.str_formatter
+ "theta%a%a%a_%a"
+ pp_call
+ call
+ (pp_path "_from_")
+ p
+ (pp_path "_to_")
+ p'
+ pp_frontier
+ f
| Dcall ->
fun p ->
- Format.fprintf Format.str_formatter "theta%a%a" pp_call call
- (pp_path "_from_") p
+ Format.fprintf
+ Format.str_formatter
+ "theta%a%a"
+ pp_call
+ call
+ (pp_path "_from_")
+ p
| Xcall ->
fun (p, f) ->
- Format.fprintf Format.str_formatter "theta%a%a_%a" pp_call call
- (pp_path "_from_") p pp_frontier f
+ Format.fprintf
+ Format.str_formatter
+ "theta%a%a_%a"
+ pp_call
+ call
+ (pp_path "_from_")
+ p
+ pp_frontier
+ f
let mkcall' : type c. name_t -> name_t -> c call_t -> c -> t_base =
fun sin sout call arg ->
@@ -244,7 +269,8 @@ end) : TransformerType = struct
| Active p ->
var_to_expr ~prefix:sin p
| Event e ->
- mkpredef_call "="
+ mkpredef_call
+ "="
[
Corelang.expr_of_vdecl event_var;
mkexpr
@@ -282,11 +308,14 @@ end) : TransformerType = struct
"NotCond_" ^ aut );
]
in
- Automata.mkhandler loc
+ Automata.mkhandler
+ loc
(* location *)
("CenterPoint_" ^ aut)
(* state name *)
- handler_default_mode_unless (* unless *) [] (* until *) []
+ handler_default_mode_unless
+ (* unless *) []
+ (* until *) []
(* locals *)
(tr0.statements, base_to_assert tr0, [])
(* stmts, asserts, annots *)
@@ -301,11 +330,13 @@ end) : TransformerType = struct
"CenterPoint_" ^ aut );
]
in
- Automata.mkhandler loc
+ Automata.mkhandler
+ loc
(* location *)
("Cond_" ^ aut)
(* state name *)
- [] (* unless *) handler_cond_mode_until
+ []
+ (* unless *) handler_cond_mode_until
(* until *)
(mk_locals vars1)
(* locals *)
@@ -322,11 +353,13 @@ end) : TransformerType = struct
"CenterPoint_" ^ aut );
]
in
- Automata.mkhandler loc
+ Automata.mkhandler
+ loc
(* location *)
("NotCond_" ^ aut)
(* state name *)
- [] (* unless *) handler_notcond_mode_until
+ []
+ (* unless *) handler_notcond_mode_until
(* until *)
(mk_locals vars2)
(* locals *)
diff --git a/src/tools/tiny/tiny_utils.ml b/src/tools/tiny/tiny_utils.ml
index 912c65d0..e3451878 100644
--- a/src/tools/tiny/tiny_utils.ml
+++ b/src/tools/tiny/tiny_utils.ml
@@ -3,7 +3,8 @@ module Ast = Tiny.Ast
let gen_loc () = Tiny.Location.dummy ()
let lloc_to_tloc loc =
- Tiny.Location.location_of_positions loc.Location.loc_start
+ Tiny.Location.location_of_positions
+ loc.Location.loc_start
loc.Location.loc_end
let tloc_to_lloc loc = assert false
diff --git a/src/tools/tiny/tiny_verifier.ml b/src/tools/tiny/tiny_verifier.ml
index 709e79b5..dbb38197 100644
--- a/src/tools/tiny/tiny_verifier.ml
+++ b/src/tools/tiny/tiny_verifier.ml
@@ -27,7 +27,8 @@ let tiny_run ~basename prog machines =
match !Options.main_node with
| "" ->
Format.eprintf "Tiny verifier requires a main node.@.";
- Format.eprintf "@[<v 2>Available ones are:@ %a@]@.@?"
+ Format.eprintf
+ "@[<v 2>Available ones are:@ %a@]@.@?"
(Utils.fprintf_list ~sep:"@ " (fun fmt m ->
Format.fprintf fmt "%s" m.Machine_code_types.mname.node_id))
machines;
@@ -37,7 +38,9 @@ let tiny_run ~basename prog machines =
match Machine_code_common.get_machine_opt machines s with
| None ->
Global.main_node := s;
- Format.eprintf "Code generation error: %a@." Error.pp_error_msg
+ Format.eprintf
+ "Code generation error: %a@."
+ Error.pp_error_msg
Error.Main_not_found;
raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
| Some _ ->
diff --git a/src/tools/zustre/zustre_analyze.ml b/src/tools/zustre/zustre_analyze.ml
index 9a7c08af..ebe61212 100644
--- a/src/tools/zustre/zustre_analyze.ml
+++ b/src/tools/zustre/zustre_analyze.ml
@@ -46,7 +46,9 @@ let check machines node =
let main_name node_id = "MAIN" ^ "_" ^ node_id in
let decl_main =
- decl_rel ~no_additional_vars:true (main_name node_id)
+ decl_rel
+ ~no_additional_vars:true
+ (main_name node_id)
(int_sort :: List.map (fun v -> type_to_sort v.var_type) main_memory_next)
in
@@ -67,7 +69,9 @@ let check machines node =
let _ = List.map decl_var main_memory_next in
let horn_head =
- Z3.Expr.mk_app !ctx decl_main
+ Z3.Expr.mk_app
+ !ctx
+ decl_main
(idx_0 :: (* uid_0:: *)
List.map horn_var_to_expr main_memory_next)
in
@@ -83,10 +87,12 @@ let check machines node =
let _ = List.map decl_var vars in
let horn_body =
- Z3.Boolean.mk_and !ctx
+ Z3.Boolean.mk_and
+ !ctx
[
Z3.Expr.mk_app !ctx decl_init [];
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_stateless_name node))
(idx_0 :: uid_0 :: List.map horn_var_to_expr vars);
]
@@ -103,15 +109,18 @@ let check machines node =
(* rule => (INIT_STATE and reset(mid) and step(mid, next)) MAIN(next) *)
let horn_body =
- Z3.Boolean.mk_and !ctx
+ Z3.Boolean.mk_and
+ !ctx
[
Z3.Expr.mk_app !ctx decl_init [];
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_reset_name node))
(idx_0
::
uid_0 :: List.map horn_var_to_expr (reset_vars machines machine));
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_step_name node))
(idx_0
::
@@ -150,17 +159,24 @@ let check machines node =
let k_var = Z3.Expr.mk_const_f !ctx (decl_var k) in
let horn_head =
- Z3.Expr.mk_app !ctx decl_main
- (Z3.Arithmetic.mk_add !ctx
+ Z3.Expr.mk_app
+ !ctx
+ decl_main
+ (Z3.Arithmetic.mk_add
+ !ctx
[ k_var; Z3.Arithmetic.Integer.mk_numeral_i !ctx 1 ]
:: List.map horn_var_to_expr main_memory_next)
in
let horn_body =
- Z3.Boolean.mk_and !ctx
+ Z3.Boolean.mk_and
+ !ctx
[
- Z3.Expr.mk_app !ctx decl_main
+ Z3.Expr.mk_app
+ !ctx
+ decl_main
(k_var :: List.map horn_var_to_expr main_memory_current);
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (step_name node))
(k_var
:: uid_0 :: List.map horn_var_to_expr (step_vars machines machine));
@@ -171,7 +187,9 @@ let check machines node =
step_vars_c_m_x machines machine @ main_output_dummy @ main_input_dummy
in
let _ =
- add_rule ~dont_touch:[ decl_main ] (k :: vars)
+ add_rule
+ ~dont_touch:[ decl_main ]
+ (k :: vars)
(Z3.Boolean.mk_implies !ctx horn_body horn_head)
in
@@ -183,11 +201,15 @@ let check machines node =
add_rule
(*~dont_touch:[decl_main;decl_err]*)
(k :: main_memory_next)
- (Z3.Boolean.mk_implies !ctx
- (Z3.Boolean.mk_and !ctx
+ (Z3.Boolean.mk_implies
+ !ctx
+ (Z3.Boolean.mk_and
+ !ctx
[
not_prop;
- Z3.Expr.mk_app !ctx decl_main
+ Z3.Expr.mk_app
+ !ctx
+ decl_main
(k_var :: List.map horn_var_to_expr main_memory_next);
])
(Z3.Expr.mk_app !ctx decl_err []));
@@ -202,7 +224,8 @@ let check machines node =
(* Debug instructions *)
let rules_expr = Z3.Fixedpoint.get_rules !fp in
if !debug then
- Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@."
+ Format.eprintf
+ "@[<v 2>Registered rules:@ %a@ @]@."
(Utils.fprintf_list ~sep:"@ " (fun fmt e ->
Format.pp_print_string fmt (Z3.Expr.to_string e)))
rules_expr;
diff --git a/src/tools/zustre/zustre_cex.ml b/src/tools/zustre/zustre_cex.ml
index e5af5889..9393bbe3 100644
--- a/src/tools/zustre/zustre_cex.ml
+++ b/src/tools/zustre/zustre_cex.ml
@@ -33,7 +33,9 @@ let build_cex machine machines _decl_err =
let conjuncts = List.rev (get_conjuncts cex) in
- Format.eprintf "cex: %s@.%i conjuncts: @[<v 0>%a@]@." (Z3.Expr.to_string cex)
+ Format.eprintf
+ "cex: %s@.%i conjuncts: @[<v 0>%a@]@."
+ (Z3.Expr.to_string cex)
(List.length conjuncts)
(Utils.fprintf_list ~sep:"@ " (fun fmt e ->
Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
@@ -65,7 +67,8 @@ let build_cex machine machines _decl_err =
in
let input_values = Utils.List.extract args 1 (1 + nb_inputs) in
let output_values =
- Utils.List.extract args
+ Utils.List.extract
+ args
(1 + nb_inputs + nb_mems)
(1 + nb_inputs + nb_mems + nb_outputs)
in
@@ -88,7 +91,9 @@ let build_cex machine machines _decl_err =
let main = List.sort (fun (id1, _) (id2, _) -> compare id1 id2) main in
List.iter
(fun (id, expr) ->
- Format.eprintf "Id %i: %a@." id
+ Format.eprintf
+ "Id %i: %a@."
+ id
(Utils.fprintf_list ~sep:", " (fun fmt e ->
Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
(fst expr))
@@ -213,8 +218,11 @@ let build_cex machine machines _decl_err =
[
( "type",
let _ =
- Format.fprintf Format.str_formatter
- "%a" Printers.pp_var_type vardecl
+ Format.fprintf
+ Format.str_formatter
+ "%a"
+ Printers.pp_var_type
+ vardecl
in
let s =
Format.flush_str_formatter ()
diff --git a/src/tools/zustre/zustre_common.ml b/src/tools/zustre/zustre_common.ml
index e8f78011..61dd0dfc 100644
--- a/src/tools/zustre/zustre_common.ml
+++ b/src/tools/zustre/zustre_common.ml
@@ -90,7 +90,9 @@ let decl_sorts () =
Hashtbl.add sort_elems new_sort tl;
List.iter (fun t -> Hashtbl.add const_tags t new_sort) tl
| _ ->
- Format.eprintf "Unknown type : %a@.@?" Printers.pp_var_type_dec_desc
+ Format.eprintf
+ "Unknown type : %a@.@?"
+ Printers.pp_var_type_dec_desc
typ;
assert false)
| _ ->
@@ -138,7 +140,9 @@ let get_fdecl id =
raise Not_found
let pp_fdecls fmt =
- Format.fprintf fmt "Registered fdecls: @[%a@]@ "
+ Format.fprintf
+ fmt
+ "Registered fdecls: @[%a@]@ "
(Utils.fprintf_list ~sep:"@ " Format.pp_print_string)
(Hashtbl.fold (fun id _ accu -> id :: accu) decls [])
@@ -188,7 +192,9 @@ let decl_rel ?(no_additional_vars = false) name args_sorts =
(* let args_sorts = List.map (fun v -> type_to_sort v.var_type) args in *)
if !debug then
- Format.eprintf "Registering fdecl %s (%a)@." name
+ Format.eprintf
+ "Registering fdecl %s (%a)@."
+ name
(Utils.fprintf_list ~sep:"@ " (fun fmt sort ->
Format.fprintf fmt "%s" (Z3.Sort.to_string sort)))
args_sorts;
@@ -235,7 +241,8 @@ let horn_tag_to_expr t =
res
| None ->
if t = cst then Some (expr : Z3.Expr.expr) else None)
- None elems
+ None
+ elems
(Z3.Enumeration.get_consts sort)
in
match res with None -> assert false | Some s -> s
@@ -321,12 +328,16 @@ let horn_basic_app i vl (vltyp, typ) =
try get_fdecl i
with Not_found ->
report ~level:3 (fun fmt ->
- Format.fprintf fmt
+ Format.fprintf
+ fmt
"Registering function %s as uninterpreted function in Z3@.%s: \
(%a) -> %a"
- i i
+ i
+ i
(Utils.fprintf_list ~sep:"," Types.print_ty)
- vltyp Types.print_ty typ);
+ vltyp
+ Types.print_ty
+ typ);
decl_fun i vltyp typ
in
Z3.FuncDecl.apply fd vl
@@ -363,14 +374,16 @@ let rec horn_val_to_expr ?(is_lhs = false) m self v =
| [] ->
horn_default_val v.value_type (* (get_type v) *)
| h :: t ->
- Z3.Z3Array.mk_store !ctx
+ Z3.Z3Array.mk_store
+ !ctx
(build_array (t, x + 1))
(Z3.Arithmetic.Integer.mk_numeral_i !ctx x)
(horn_val_to_expr ~is_lhs m self h)
in
build_array (il, 0)
| Access (tab, index) ->
- Z3.Z3Array.mk_select !ctx
+ Z3.Z3Array.mk_select
+ !ctx
(horn_val_to_expr ~is_lhs m self tab)
(horn_val_to_expr ~is_lhs m self index)
(* Code specific for arrays *)
@@ -381,11 +394,13 @@ let rec horn_val_to_expr ?(is_lhs = false) m self v =
if Types.is_array_type v.var_type then assert false
else
horn_var_to_expr
- (rename_machine self
+ (rename_machine
+ self
((if is_lhs then rename_next else rename_current (* self *)) v))
else horn_var_to_expr (rename_machine self v)
| Fun (n, vl) ->
- horn_basic_app n
+ horn_basic_app
+ n
(List.map (horn_val_to_expr m self) vl)
(List.map (fun v -> v.value_type) vl, v.value_type)
@@ -396,11 +411,13 @@ let no_reset_to_exprs machines m i =
in
let m_list =
- rename_machine_list (concat m.mname.node_id i)
+ rename_machine_list
+ (concat m.mname.node_id i)
(rename_mid_list (full_memory_vars machines target_machine))
in
let c_list =
- rename_machine_list (concat m.mname.node_id i)
+ rename_machine_list
+ (concat m.mname.node_id i)
(rename_current_list (full_memory_vars machines target_machine))
in
match c_list, m_list with
@@ -414,7 +431,8 @@ let no_reset_to_exprs machines m i =
List.map2
(fun mhd chd ->
Z3.Boolean.mk_eq !ctx (horn_var_to_expr mhd) (horn_var_to_expr chd))
- m_list c_list
+ m_list
+ c_list
in
exprs
@@ -424,13 +442,15 @@ let instance_reset_to_exprs machines m i =
List.find (fun m -> m.mname.node_id = Corelang.node_name n) machines
in
let vars =
- rename_machine_list (concat m.mname.node_id i)
+ rename_machine_list
+ (concat m.mname.node_id i)
(rename_current_list (full_memory_vars machines target_machine))
@ rename_mid_list (full_memory_vars machines target_machine)
in
let expr =
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_reset_name (Corelang.node_name n)))
(List.map horn_var_to_expr (idx :: uid :: vars))
in
@@ -445,7 +465,8 @@ let instance_call_to_exprs machines reset_instances m i inputs outputs =
let idx = horn_var_to_expr idx in
let uid = uid_conc (get_instance_uid i) (horn_var_to_expr uid) in
let inout =
- List.map (horn_val_to_expr m self)
+ List.map
+ (horn_val_to_expr m self)
(inputs @ List.map (fun v -> mk_val (Var v) v.var_type) outputs)
in
idx :: uid :: inout
@@ -479,23 +500,32 @@ let instance_call_to_exprs machines reset_instances m i inputs outputs =
| "_arrow", [ i1; i2 ], [ o ], [ mem_m ], [ mem_x ] ->
let stmt1 =
(* out = ite mem_m then i1 else i2 *)
- Z3.Boolean.mk_eq !ctx
+ Z3.Boolean.mk_eq
+ !ctx
((* output var *)
- horn_val_to_expr ~is_lhs:true m self
+ horn_val_to_expr
+ ~is_lhs:true
+ m
+ self
(mk_val (Var o) o.var_type))
- (Z3.Boolean.mk_ite !ctx (horn_var_to_expr mem_m)
+ (Z3.Boolean.mk_ite
+ !ctx
+ (horn_var_to_expr mem_m)
(horn_val_to_expr m self i1)
(horn_val_to_expr m self i2))
in
let stmt2 =
(* mem_X = false *)
- Z3.Boolean.mk_eq !ctx (horn_var_to_expr mem_x)
+ Z3.Boolean.mk_eq
+ !ctx
+ (horn_var_to_expr mem_x)
(Z3.Boolean.mk_false !ctx)
in
[ stmt1; stmt2 ]
| _ ->
let expr =
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_step_name (node_name n)))
((* Arguments are input, output, mid_mems, next_mems *)
idx_uid_inout
@@ -509,7 +539,8 @@ let instance_call_to_exprs machines reset_instances m i inputs outputs =
(* stateless node instance *)
let n, _ = List.assoc i m.mcalls in
let expr =
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_stateless_name (node_name n)))
idx_uid_inout
(* Arguments are inputs, outputs *)
@@ -531,7 +562,8 @@ let instance_call_to_exprs machines reset_instances m i inputs outputs =
let assign_to_exprs m var_name value =
let self = m.mname.node_id in
let e =
- Z3.Boolean.mk_eq !ctx
+ Z3.Boolean.mk_eq
+ !ctx
(horn_val_to_expr ~is_lhs:true m self var_name)
(horn_val_to_expr m self value)
(* was: TODO deal with array accesses (value_suffix_to_expr self value) *)
@@ -578,8 +610,10 @@ let rec instr_to_exprs machines reset_instances (m : machine_t) instr :
instrs_to_expr machines reset_instances m instrs
in
let e =
- Z3.Boolean.mk_implies !ctx
- (Z3.Boolean.mk_eq !ctx
+ Z3.Boolean.mk_implies
+ !ctx
+ (Z3.Boolean.mk_eq
+ !ctx
(horn_val_to_expr m self g)
(horn_tag_to_expr tag))
branch_def
@@ -592,7 +626,8 @@ let rec instr_to_exprs machines reset_instances (m : machine_t) instr :
(fun (instrs, resets) b ->
let b_instrs, b_resets = branch_to_expr b in
instrs @ b_instrs, resets @ b_resets)
- ([], reset_instances) hl
+ ([], reset_instances)
+ hl
| MSpec _ ->
assert false
@@ -610,7 +645,8 @@ and instrs_to_expr machines reset_instances m instrs =
(fun (exprs, rs) i ->
let exprs_i, rs_i = instr_to_exprs rs i in
exprs @ exprs_i, rs @ rs_i)
- ([], reset_instances) instrs
+ ([], reset_instances)
+ instrs
| [] ->
[], reset_instances
in
@@ -671,20 +707,26 @@ let add_rule ?(dont_touch = []) vars expr =
extracted_sorts = List.map Z3.FuncDecl.get_range extracted_vars in let
extracted_symbols = List.map Z3.FuncDecl.get_name extracted_vars in *)
if !debug then
- Format.eprintf "Declaring rule: %s with variables @[<v 0>@ [%a@ ]@]@ @."
+ Format.eprintf
+ "Declaring rule: %s with variables @[<v 0>@ [%a@ ]@]@ @."
(Z3.Expr.to_string expr)
(Utils.fprintf_list ~sep:",@ " (fun fmt e ->
Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
(List.map horn_var_to_expr vars);
let expr =
- Z3.Quantifier.mk_forall_const !ctx
+ Z3.Quantifier.mk_forall_const
+ !ctx
(* context *)
(List.map horn_var_to_expr vars)
(* TODO provide bounded variables as expr *)
(* sorts (\* sort list*\) *)
(* symbols (\* symbol list *\) *)
- expr (* expression *) None (* quantifier weight, None means 1 *) []
- (* pattern list ? *) [] (* ? *) None (* ? *) None
+ expr
+ (* expression *) None
+ (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) []
+ (* ? *) None
+ (* ? *) None
(* ? *)
in
@@ -702,7 +744,8 @@ let machine_reset machines m =
let mid_mem_def =
List.map
(fun v ->
- Z3.Boolean.mk_eq !ctx
+ Z3.Boolean.mk_eq
+ !ctx
(horn_var_to_expr (rename_mid v))
(horn_var_to_expr (rename_current v)))
locals
@@ -715,7 +758,8 @@ let machine_reset machines m =
(fun (id, (n, _)) ->
let name = node_name n in
if name = "_arrow" then
- Z3.Boolean.mk_eq !ctx
+ Z3.Boolean.mk_eq
+ !ctx
(let vdecl =
get_fdecl (concat m.mname.node_id id ^ "._arrow._first_m")
in
@@ -724,9 +768,11 @@ let machine_reset machines m =
else
let machine_n = get_machine machines name in
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (name ^ "_reset"))
- (List.map horn_var_to_expr
+ (List.map
+ horn_var_to_expr
(idx
::
uid
@@ -746,7 +792,8 @@ let decl_machine machines m =
()
else
let _ =
- List.map decl_var
+ List.map
+ decl_var
(inout_vars m
@ rename_current_list (full_memory_vars machines m)
@ rename_mid_list (full_memory_vars machines m)
@@ -763,13 +810,18 @@ let decl_machine machines m =
let _ = decl_rel (machine_stateless_name m.mname.node_id) vars_types in
let horn_body, _ (* don't care for reset here *) =
- instrs_to_expr machines [] (* No reset info for stateless nodes *) m
+ instrs_to_expr
+ machines
+ []
+ (* No reset info for stateless nodes *) m
m.mstep.step_instrs
in
let horn_head =
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_stateless_name m.mname.node_id))
- (List.map horn_var_to_expr
+ (List.map
+ horn_var_to_expr
(idx :: uid :: (* Additional vars: counters, uid *)
vars))
in
@@ -791,7 +843,8 @@ let decl_machine machines m =
| assertsl ->
(*Rule for step "; Stateless step rule with Assertions @.";*)
let body_with_asserts =
- Z3.Boolean.mk_and !ctx
+ Z3.Boolean.mk_and
+ !ctx
(horn_body :: List.map (horn_val_to_expr m m.mname.node_id) assertsl)
in
let vars = rename_machine_list m.mname.node_id m.mstep.step_locals in
@@ -803,15 +856,18 @@ let decl_machine machines m =
let _ = decl_rel (machine_reset_name m.mname.node_id) vars_types in
let horn_reset_body = machine_reset machines m in
let horn_reset_head =
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_reset_name m.mname.node_id))
- (List.map horn_var_to_expr
+ (List.map
+ horn_var_to_expr
(idx :: uid :: (* Additional vars: counters, uid *)
vars))
in
let _ =
- add_rule (idx :: uid :: vars)
+ add_rule
+ (idx :: uid :: vars)
(Z3.Boolean.mk_implies !ctx horn_reset_body horn_reset_head)
in
@@ -823,9 +879,11 @@ let decl_machine machines m =
instrs_to_expr machines [] m m.mstep.step_instrs
in
let horn_step_head =
- Z3.Expr.mk_app !ctx
+ Z3.Expr.mk_app
+ !ctx
(get_fdecl (machine_step_name m.mname.node_id))
- (List.map horn_var_to_expr
+ (List.map
+ horn_var_to_expr
(idx :: uid :: (* Additional vars: counters, uid *)
vars))
in
@@ -836,12 +894,14 @@ let decl_machine machines m =
step_vars_c_m_x machines m
@ rename_machine_list m.mname.node_id m.mstep.step_locals
in
- add_rule (idx :: uid :: vars)
+ add_rule
+ (idx :: uid :: vars)
(Z3.Boolean.mk_implies !ctx horn_step_body horn_step_head)
| assertsl ->
(* Rule for step Assertions @.; *)
let body_with_asserts =
- Z3.Boolean.mk_and !ctx
+ Z3.Boolean.mk_and
+ !ctx
(horn_step_body
:: List.map (horn_val_to_expr m m.mname.node_id) assertsl)
in
@@ -849,7 +909,8 @@ let decl_machine machines m =
step_vars_c_m_x machines m
@ rename_machine_list m.mname.node_id m.mstep.step_locals
in
- add_rule (idx :: uid :: vars)
+ add_rule
+ (idx :: uid :: vars)
(Z3.Boolean.mk_implies !ctx body_with_asserts horn_step_head)
(* Debug functions *)
diff --git a/src/tools/zustre/zustre_test.ml b/src/tools/zustre/zustre_test.ml
index e7d08685..16da5ae3 100644
--- a/src/tools/zustre/zustre_test.ml
+++ b/src/tools/zustre/zustre_test.ml
@@ -73,14 +73,19 @@ let _ =
let expr_f = Z3.Boolean.mk_implies !ctx expr_f_lhs expr_f_rhs in
(* Adding forall as prefix *)
let expr_forall_f =
- Z3.Quantifier.mk_forall_const !ctx
+ Z3.Quantifier.mk_forall_const
+ !ctx
(* context *)
(* [int_sort; int_sort] (\* sort list*\) *)
(* [Z3.FuncDecl.get_name x; Z3.FuncDecl.get_name y] (\* symbol list *\) *)
(* [x_expr; y_expr] Second try with expr list "const" *)
[ Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y ]
- expr_f (* expression *) None (* quantifier weight, None means 1 *) []
- (* pattern list ? *) [] (* ? *) None (* ? *) None
+ expr_f
+ (* expression *) None
+ (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) []
+ (* ? *) None
+ (* ? *) None
(* ? *)
in
let expr_forall_f = Z3.Quantifier.expr_of_quantifier expr_forall_f in
@@ -109,14 +114,19 @@ let _ =
let expr_main1 = Z3.Boolean.mk_implies !ctx expr_main1_lhs expr_main1_rhs in
(* Adding forall as prefix *)
let expr_forall_main1 =
- Z3.Quantifier.mk_forall_const !ctx
+ Z3.Quantifier.mk_forall_const
+ !ctx
(* context *)
(* [int_sort; int_sort] (* sort list*) [Z3.FuncDecl.get_name x;
Z3.FuncDecl.get_name y] (* symbol list *) *)
(* [x_expr; y_expr] Second try with expr list "const" *)
[ Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y ]
- expr_main1 (* expression *) None (* quantifier weight, None means 1 *) []
- (* pattern list ? *) [] (* ? *) None (* ? *) None
+ expr_main1
+ (* expression *) None
+ (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) []
+ (* ? *) None
+ (* ? *) None
(* ? *)
in
let expr_forall_main1 = Z3.Quantifier.expr_of_quantifier expr_forall_main1 in
@@ -125,7 +135,8 @@ let _ =
(* Rule 2: forall x,y, MAIN(x,y) => MAIN(x+1, y+1) *)
let expr_main2_lhs = main_x_y_expr in
let plus_one x =
- Z3.Arithmetic.mk_add !ctx
+ Z3.Arithmetic.mk_add
+ !ctx
[
x;
(* Z3.Arithmetic.Integer.mk_const_s !ctx "1" *)
@@ -139,14 +150,19 @@ let _ =
let expr_main2 = Z3.Boolean.mk_implies !ctx expr_main2_lhs expr_main2_rhs in
(* Adding forall as prefix *)
let expr_forall_main2 =
- Z3.Quantifier.mk_forall_const !ctx
+ Z3.Quantifier.mk_forall_const
+ !ctx
(* context *)
(* [int_sort; int_sort] (* sort list*) [Z3.FuncDecl.get_name x;
Z3.FuncDecl.get_name y] (* symbol list *) *)
(* [x_expr; y_expr] Second try with expr list "const" *)
[ Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y ]
- expr_main2 (* expression *) None (* quantifier weight, None means 1 *) []
- (* pattern list ? *) [] (* ? *) None (* ? *) None
+ expr_main2
+ (* expression *) None
+ (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) []
+ (* ? *) None
+ (* ? *) None
(* ? *)
in
let expr_forall_main2 = Z3.Quantifier.expr_of_quantifier expr_forall_main2 in
@@ -165,14 +181,19 @@ let _ =
let expr_err = Z3.Boolean.mk_implies !ctx expr_err_lhs expr_err_rhs in
(* Adding forall as prefix *)
let expr_forall_err =
- Z3.Quantifier.mk_forall_const !ctx
+ Z3.Quantifier.mk_forall_const
+ !ctx
(* context *)
(* [int_sort; int_sort] (* sort list*) [Z3.FuncDecl.get_name x;
Z3.FuncDecl.get_name y] (* symbol list *) *)
(* [x_expr; y_expr] Second try with expr list "const" *)
[ Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y ]
- expr_err (* expression *) None (* quantifier weight, None means 1 *) []
- (* pattern list ? *) [] (* ? *) None (* ? *) None
+ expr_err
+ (* expression *) None
+ (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) []
+ (* ? *) None
+ (* ? *) None
(* ? *)
in
let expr_forall_err = Z3.Quantifier.expr_of_quantifier expr_forall_err in
@@ -180,7 +201,8 @@ let _ =
(* Printing the rules for sanity check *)
let rules_expr = Z3.Fixedpoint.get_rules !fp in
- Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@."
+ Format.eprintf
+ "@[<v 2>Registered rules:@ %a@ @]@."
(fprintf_list ~sep:"@ " (fun fmt e ->
(* let e2 = Z3.Quantifier.get_body eq in *)
(* let fd = Z3.Expr.get_func_decl e in *)
diff --git a/src/types.ml b/src/types.ml
index 312fbd3b..de500870 100644
--- a/src/types.ml
+++ b/src/types.ml
@@ -111,7 +111,7 @@ module type S = sig
val is_generic_type : t -> bool
- val print_ty : Format.formatter -> t -> unit
+ val pp : Format.formatter -> t -> unit
val repr : t -> t
@@ -137,7 +137,7 @@ module type S = sig
val type_list_of_type : t -> t list
- val print_node_ty : Format.formatter -> t -> unit
+ val pp_node_ty : Format.formatter -> t -> unit
val get_clock_base_type : t -> t option
@@ -266,83 +266,91 @@ module Make (BasicT : BASIC_TYPES) = struct
(* Pretty-print*)
open Format
- let rec print_struct_ty_field pp_basic fmt (label, ty) =
- fprintf fmt "%a : %a" pp_print_string label (print_ty_param pp_basic) ty
+ let rec pp_struct_ty_field pp_basic fmt (label, ty) =
+ fprintf fmt "%a : %a" pp_print_string label (pp_ty_param pp_basic) ty
- and print_ty_param pp_basic fmt ty =
- let print_ty = print_ty_param pp_basic in
+ and pp_ty_param pp_basic fmt ty =
+ let pp_ty = pp_ty_param pp_basic in
match ty.tdesc with
| Tvar ->
fprintf fmt "_%s" (name_of_type ty.tid)
| Tbasic t ->
pp_basic fmt t
| Tclock t ->
- fprintf fmt "%a%s" print_ty t
- (if !Options.kind2_print then "" else " clock")
+ fprintf fmt "%a%s" pp_ty t (if !Options.kind2_print then "" else " clock")
| Tstatic (_, t) ->
- print_ty fmt t
- (* fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t *)
+ pp_ty fmt t
+ (* fprintf fmt "(%a:%a)" Dimension.pp_dimension d pp_ty t *)
| Tconst t ->
fprintf fmt "%s" t
| Tarrow (ty1, ty2) ->
- fprintf fmt "%a -> %a" print_ty ty1 print_ty ty2
+ fprintf fmt "%a -> %a" pp_ty ty1 pp_ty ty2
| Ttuple tylist ->
- fprintf fmt "(%a)"
- (pp_print_list
- ~pp_sep:(fun fmt () -> pp_print_string fmt " * ")
- print_ty)
+ fprintf
+ fmt
+ "(%a)"
+ (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt " * ") pp_ty)
tylist
| Tenum taglist ->
fprintf fmt "enum {%a }" (pp_comma_list pp_print_string) taglist
| Tstruct fieldlist ->
- fprintf fmt "struct {%a }"
- (pp_print_list ~pp_sep:pp_print_semicolon
- (print_struct_ty_field pp_basic))
+ fprintf
+ fmt
+ "struct {%a }"
+ (pp_print_list ~pp_sep:pp_print_semicolon (pp_struct_ty_field pp_basic))
fieldlist
| Tarray (e, ty) ->
- fprintf fmt "%a^%a" print_ty ty Dimension.pp e
+ fprintf fmt "%a^%a" pp_ty ty Dimension.pp e
| Tlink ty ->
- print_ty fmt ty
+ pp_ty fmt ty
| Tunivar ->
fprintf fmt "'%s" (name_of_type ty.tid)
- let print_ty = print_ty_param BasicT.pp
+ let pp = pp_ty_param BasicT.pp
- let rec print_node_struct_ty_field fmt (label, ty) =
- fprintf fmt "%a : %a" pp_print_string label print_node_ty ty
+ let rec pp_node_struct_ty_field fmt (label, ty) =
+ fprintf fmt "%a : %a" pp_print_string label pp_node_ty ty
- and print_node_ty fmt ty =
+ and pp_node_ty fmt ty =
match ty.tdesc with
| Tvar ->
- (*Format.eprintf "DEBUG:Types.print_node@.";*)
+ (*Format.eprintf "DEBUG:Types.pp_node@.";*)
fprintf fmt "_%s" (name_of_type ty.tid)
| Tbasic t ->
BasicT.pp fmt t
| Tclock t ->
- fprintf fmt "%a%s" print_node_ty t
+ fprintf
+ fmt
+ "%a%s"
+ pp_node_ty
+ t
(if !Options.kind2_print then "" else " clock")
| Tstatic (_, t) ->
- fprintf fmt "%a" print_node_ty t
+ fprintf fmt "%a" pp_node_ty t
| Tconst t ->
fprintf fmt "%s" t
| Tarrow (ty1, ty2) ->
- fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2
+ fprintf fmt "%a -> %a" pp_node_ty ty1 pp_node_ty ty2
| Ttuple tylist ->
- fprintf fmt "(%a)"
+ fprintf
+ fmt
+ "(%a)"
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt "")
- print_node_ty)
+ pp_node_ty)
tylist
| Tenum taglist ->
fprintf fmt "enum {%a }" (pp_comma_list pp_print_string) taglist
| Tstruct fieldlist ->
- fprintf fmt "struct {%a }"
- (pp_print_list ~pp_sep:pp_print_semicolon print_node_struct_ty_field)
+ fprintf
+ fmt
+ "struct {%a }"
+ (pp_print_list ~pp_sep:pp_print_semicolon pp_node_struct_ty_field)
fieldlist
| Tarray (e, ty) ->
- fprintf fmt "%a^%a" print_node_ty ty Dimension.pp e
+ fprintf fmt "%a^%a" pp_node_ty ty Dimension.pp e
| Tlink ty ->
- print_node_ty fmt ty
+ pp_node_ty fmt ty
| Tunivar ->
fprintf fmt "'%s" (name_of_type ty.tid)
@@ -364,19 +372,24 @@ module Make (BasicT : BASIC_TYPES) = struct
| WrongArity (ar1, ar2) ->
fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2
| WrongMorphism (ar1, ar2) ->
- fprintf fmt
- "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2
+ fprintf
+ fmt
+ "Expecting %d argument(s) for homomorphic extension, found %d@."
+ ar1
+ ar2
| Type_mismatch id ->
fprintf fmt "Definition and declaration of type %s don't agree@." id
| Undefined_var vset ->
- fprintf fmt "No definition provided for variable(s): %a@."
+ fprintf
+ fmt
+ "No definition provided for variable(s): %a@."
(pp_comma_list pp_print_string)
(ISet.elements vset)
| Declared_but_undefined id ->
fprintf fmt "%s is declared but not defined@." id
| Type_clash (ty1, ty2) ->
Utils.reset_names ();
- fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2
+ fprintf fmt "Expected type %a, got type %a@." pp ty1 pp ty2
| Poly_imported_node _ ->
fprintf fmt "Imported nodes cannot have a polymorphic type@."
@@ -525,7 +538,7 @@ module Make (BasicT : BASIC_TYPES) = struct
| Tarray (d, _) ->
d
| _ ->
- eprintf "internal error: Types.array_type_dimension %a@." print_ty ty;
+ eprintf "internal error: Types.array_type_dimension %a@." pp ty;
assert false
let rec array_type_multi_dimension ty =
@@ -540,7 +553,7 @@ module Make (BasicT : BASIC_TYPES) = struct
| Tarray (_, ty') ->
ty'
| _ ->
- eprintf "internal error: Types.array_element_type %a@." print_ty ty;
+ eprintf "internal error: Types.array_element_type %a@." pp ty;
assert false
let rec array_base_type ty =
@@ -572,7 +585,7 @@ module Make (BasicT : BASIC_TYPES) = struct
(* Functions are not first order, I don't think the var case needs to be
considered here *)
| _ ->
- eprintf "type %a is not a map@.Unable to split@.@?" print_ty ty;
+ eprintf "type %a is not a map@.Unable to split@.@?" pp ty;
assert false
(** Returns the type corresponding to a type list. *)
diff --git a/src/types.mli b/src/types.mli
index 6a2cf25e..4133f4d7 100644
--- a/src/types.mli
+++ b/src/types.mli
@@ -97,7 +97,7 @@ module type S = sig
val is_generic_type : t -> bool
- val print_ty : Format.formatter -> t -> unit
+ val pp : Format.formatter -> t -> unit
val repr : t -> t
@@ -123,7 +123,7 @@ module type S = sig
val type_list_of_type : t -> t list
- val print_node_ty : Format.formatter -> t -> unit
+ val pp_node_ty : Format.formatter -> t -> unit
val get_clock_base_type : t -> t option
@@ -155,7 +155,7 @@ end
module Make (BasicT : BASIC_TYPES) : sig
include S
- val print_ty_param :
+ val pp_ty_param :
(Format.formatter -> basic_type -> unit) -> Format.formatter -> t -> unit
end
with module BasicT = BasicT
diff --git a/src/typing.ml b/src/typing.ml
index 3a7feca2..74003319 100644
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -381,11 +381,13 @@ struct
if List.mem l acc then
raise (Error (loc, Already_bound ("struct field " ^ l)))
else
- try_unify ty_struct
+ try_unify
+ ty_struct
(type_struct_const_field ~is_annot loc (l, c))
loc;
l :: acc)
- [] fl
+ []
+ fl
in
try
let total =
@@ -416,7 +418,7 @@ struct
let rec type_add_const env const arg targ =
(*Format.eprintf "Typing.type_add_const %a %a@." Printers.pp_expr arg
- Types.print_ty targ;*)
+ Types.pp targ;*)
if const then (
let d =
if is_dimension_type targ then dimension_of_expr arg
@@ -454,8 +456,7 @@ struct
type_add_const env const real_arg (type_expr env in_main const real_arg)
in
(*Format.eprintf "subtyping const %B real %a:%a vs formal %a@." const
- Printers.pp_expr real_arg Types.print_ty real_type Types.print_ty
- formal_type;*)
+ Printers.pp_expr real_arg Types.pp real_type Types.pp formal_type;*)
try_unify ~sub formal_type real_type loc
(* typing an application implies: - checking that const formal parameters
@@ -481,12 +482,12 @@ struct
and type_dependent_call env in_main loc const f targs =
(* Format.eprintf "Typing.type_dependent_call %s@." f; *)
let tins, touts = new_var (), new_var () in
- (* Format.eprintf "tin=%a, tout=%a@." print_ty tins print_ty touts; *)
+ (* Format.eprintf "tin=%a, tout=%a@." pp tins pp touts; *)
let tfun =
(* Type_predef. *)
type_arrow tins touts
in
- (* Format.eprintf "fun=%a@." print_ty tfun; *)
+ (* Format.eprintf "fun=%a@." pp tfun; *)
type_subtyping_arg env in_main const (expr_of_ident f loc) tfun;
(* Format.eprintf "type subtyping@."; *)
let tins = type_list_of_type tins in
@@ -496,18 +497,21 @@ struct
List.iter2
(fun (a, t) ti ->
let t' =
- type_add_const env
+ type_add_const
+ env
(const
|| (* Types. *)
get_static_value ti <> None)
- a t
+ a
+ t
in
- (* Format.eprintf "uniying ti=%a t'=%a touts=%a@." print_ty ti
- print_ty t' print_ty touts; *)
+ (* Format.eprintf "uniying ti=%a t'=%a touts=%a@." pp ti pp t' pp
+ touts; *)
try_unify ~sub:true ti t' a.expr_loc
- (* Format.eprintf "unified ti=%a t'=%a touts=%a@." print_ty ti
- print_ty t' print_ty touts; *))
- targs tins;
+ (* Format.eprintf "unified ti=%a t'=%a touts=%a@." pp ti pp t' pp
+ touts; *))
+ targs
+ tins;
touts)
(* type a simple call without dependent types but possible homomorphic
@@ -519,7 +523,7 @@ struct
type_arrow tins touts
in
type_subtyping_arg env in_main const (expr_of_ident f loc) tfun;
- (*Format.eprintf "try unify %a %a@." Types.print_ty tins Types.print_ty
+ (*Format.eprintf "try unify %a %a@." Types.pp tins Types.pp
(type_of_type_list targs);*)
try_unify ~sub:true tins (type_of_type_list targs) loc;
touts
@@ -543,7 +547,8 @@ struct
with Not_found ->
Format.eprintf
"Failure in typing expr %a. Not in typing environement@."
- Printers.pp_expr expr;
+ Printers.pp_expr
+ expr;
raise (Error (expr.expr_loc, Unbound_value ("identifier " ^ v)))
in
let ty = instantiate (ref []) (ref []) tyv in
@@ -560,7 +565,8 @@ struct
let ty_elt = new_var () in
List.iter
(fun e ->
- try_unify ty_elt
+ try_unify
+ ty_elt
(type_appl env in_main expr.expr_loc const "uminus" [ e ])
e.expr_loc)
elist;
@@ -572,14 +578,21 @@ struct
expr.expr_type <- Expr_type_hub.export ty;
ty
| Expr_access (e1, d) ->
- type_subtyping_arg env in_main false
+ type_subtyping_arg
+ env
+ in_main
+ false
(* not necessary a constant *)
(expr_of_dimension d)
(* Type_predef. *)
type_int;
let ty_elt = new_var () in
let d = Dimension.mkdim_var () in
- type_subtyping_arg env in_main const e1
+ type_subtyping_arg
+ env
+ in_main
+ const
+ e1
((* Type_predef. *)
type_array d ty_elt);
expr.expr_type <- Expr_type_hub.export ty_elt;
@@ -589,7 +602,11 @@ struct
(* Types. *)
get_static_value (Env.lookup_value (fst env) id)
in
- type_subtyping_arg env in_main true (expr_of_dimension d)
+ type_subtyping_arg
+ env
+ in_main
+ true
+ (expr_of_dimension d)
(* Type_predef. *)
type_int;
Dimension.eval Basic_library.eval_dim_env eval_const d;
@@ -673,9 +690,14 @@ struct
typ_out
in
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt "Type of expr %a: %a@ " Printers.pp_expr expr
+ Format.fprintf
+ fmt
+ "Type of expr %a: %a@ "
+ Printers.pp_expr
+ expr
(* Types. *)
- print_ty resulting_ty);
+ pp
+ resulting_ty);
resulting_ty
and type_branches ?(is_annot = false) env in_main loc const hl =
@@ -689,7 +711,8 @@ struct
type_subtyping_arg env in_main const h typ_out;
if List.mem t accu then raise (Error (loc, Already_bound t))
else t :: accu)
- [] hl
+ []
+ hl
in
let type_labels = get_enum_type_tags (coretype_type typ_in) in
if List.sort compare used_labels <> List.sort compare type_labels then
@@ -703,7 +726,11 @@ struct
(* Eexpr are always in annotations. TODO: add the quantifiers variables to the
env *)
let type_eexpr env eexpr =
- type_expr ~is_annot:true env false (* not in main *) false (* not a const *)
+ type_expr
+ ~is_annot:true
+ env
+ false
+ (* not in main *) false (* not a const *)
eexpr.eexpr_qfexpr
(** [type_eq env eq] types equation [eq] in environment [env] *)
@@ -711,7 +738,8 @@ struct
(*Format.eprintf "Typing.type_eq %a@." Printers.pp_node_eq eq;*)
(* Check undefined variables, type lhs *)
let expr_lhs =
- expr_of_expr_list eq.eq_loc
+ expr_of_expr_list
+ eq.eq_loc
(List.map (fun v -> expr_of_ident v eq.eq_loc) eq.eq_lhs)
in
let ty_lhs = type_expr env in_main false expr_lhs in
@@ -728,12 +756,14 @@ struct
if get_static_value ty <> None then
raise (Error (eq.eq_loc, Assigned_constant id))
else match get_clock_base_type ty with None -> ty | Some ty -> ty)
- (type_list_of_type ty_lhs) eq.eq_lhs)
+ (type_list_of_type ty_lhs)
+ eq.eq_lhs)
in
let undefined_vars =
List.fold_left
(fun uvars v -> define_var v uvars)
- undefined_vars eq.eq_lhs
+ undefined_vars
+ eq.eq_lhs
in
(* Type rhs wrt to lhs type with subtyping, i.e. a constant rhs value may be
assigned to a (always non-constant) lhs variable *)
@@ -760,7 +790,8 @@ struct
expr_loc = loc;
expr_annot = None;
})
- dummy_id_expr cl
+ dummy_id_expr
+ cl
in
ignore (type_expr env false false when_expr)
@@ -769,7 +800,7 @@ struct
| Tydec_clock ty | Tydec_array (_, ty) ->
check_type_declaration loc ty
| Tydec_const tname ->
- (* Format.eprintf "TABLE: %a@." print_type_table (); *)
+ (* Format.eprintf "TABLE: %a@." pp_type_table (); *)
if not (Hashtbl.mem type_table cty) then
raise (Error (loc, Unbound_type tname))
| _ ->
@@ -777,14 +808,18 @@ struct
let type_var_decl vd_env env vdecl =
(*Format.eprintf "Typing.type_var_decl START %a:%a@." Printers.pp_var vdecl
- Printers.print_dec_ty vdecl.var_dec_type.ty_dec_desc;*)
+ Printers.pp_dec_ty vdecl.var_dec_type.ty_dec_desc;*)
check_type_declaration vdecl.var_loc vdecl.var_dec_type.ty_dec_desc;
let eval_const id =
(* Types. *)
get_static_value (Env.lookup_value env id)
in
let type_dim d =
- type_subtyping_arg (env, vd_env) false true (expr_of_dimension d)
+ type_subtyping_arg
+ (env, vd_env)
+ false
+ true
+ (expr_of_dimension d)
(* Type_predef. *)
type_int;
Dimension.eval Basic_library.eval_dim_env eval_const d
@@ -804,9 +839,12 @@ struct
type_subtyping_arg (env, vd_env) false ~sub:false true v ty_static);
try_unify ty_static (Expr_type_hub.import vdecl.var_type) vdecl.var_loc;
let new_env = Env.add_value env vdecl.var_id ty_static in
- type_coreclock (new_env, vd_env) vdecl.var_dec_clock vdecl.var_id
+ type_coreclock
+ (new_env, vd_env)
+ vdecl.var_dec_clock
+ vdecl.var_id
vdecl.var_loc;
- (*Format.eprintf "END %a@." Types.print_ty ty_static;*)
+ (*Format.eprintf "END %a@." Types.pp ty_static;*)
new_env
let type_var_decl_list vd_env env l =
@@ -829,7 +867,9 @@ struct
let env =
type_var_decl_list
(* this argument seems useless to me, cf TODO at top of the file*)
- vd_env env vd_env
+ vd_env
+ env
+ vd_env
in
(* typing stmts *)
let eqs =
@@ -841,15 +881,21 @@ struct
let _ =
List.fold_left
(type_eq (env, vd_env) false (*is_main*))
- undefined_vars_init eqs
+ undefined_vars_init
+ eqs
in
(* Typing each predicate expr *)
let type_pred_ee ee : unit =
- type_subtyping_arg (env, vd_env) false (* not in main *) false
+ type_subtyping_arg
+ (env, vd_env)
+ false
+ (* not in main *) false
(* not a const *)
- ee.eexpr_qfexpr type_bool
+ ee.eexpr_qfexpr
+ type_bool
in
- List.iter type_pred_ee
+ List.iter
+ type_pred_ee
(c.assume @ c.guarantees
@ List.flatten (List.map (fun m -> m.ensure @ m.require) c.modes));
(*TODO enrich env locally with locals and consts type each pre/post as a
@@ -889,7 +935,11 @@ struct
List.iter
(fun assert_ ->
let assert_expr = assert_.assert_expr in
- type_subtyping_arg (new_env, vd_env) is_main false assert_expr
+ type_subtyping_arg
+ (new_env, vd_env)
+ is_main
+ false
+ assert_expr
(* Type_predef. *)
type_bool)
nd.node_asserts;
@@ -912,7 +962,8 @@ struct
List.fold_left
(fun res vdecl ->
if vdecl.var_dec_const then ISet.add vdecl.var_id res else res)
- ISet.empty nd.node_locals
+ ISet.empty
+ nd.node_locals
in
let undefined_vars = ISet.diff undefined_vars local_consts in
@@ -1011,7 +1062,9 @@ struct
if vdecl.var_dec_const then
match get_static_value (Expr_type_hub.import vdecl.var_type) with
| None ->
- Format.eprintf "internal error: %a@." (* Types. *) print_ty
+ Format.eprintf
+ "internal error: %a@."
+ (* Types. *) pp
(Expr_type_hub.import vdecl.var_type);
assert false
| Some d ->
@@ -1057,7 +1110,7 @@ struct
try
let computed_t = Env.lookup_value computed k in
let computed_t = instantiate (ref []) (ref []) computed_t in
- (* Types.print_ty Format.std_formatter decl_type_k; Types.print_ty
+ (* Types.pp Format.std_formatter decl_type_k; Types.pp
Format.std_formatter computed_t;*)
try_unify ~sub:true ~semi:true decl_type_k computed_t loc
with Not_found -> (
@@ -1076,7 +1129,7 @@ struct
let check_typedef_top decl =
(*Format.eprintf "check_typedef %a@." Printers.pp_short_decl decl;*)
(*Format.eprintf "%a" Printers.pp_typedef (typedef_of_top decl);*)
- (*Format.eprintf "%a" Corelang.print_type_table ();*)
+ (*Format.eprintf "%a" Corelang.pp_type_table ();*)
match decl.top_decl_desc with
| TypeDef ty -> (
let owner = decl.top_decl_owner in
diff --git a/src/utils/dimension.ml b/src/utils/dimension.ml
index dcf07c49..36e23a55 100644
--- a/src/utils/dimension.ml
+++ b/src/utils/dimension.ml
@@ -95,7 +95,9 @@ let check_bound loc d = mkdim_appl loc "<=" [ mkdim_int loc 0; d ]
(* Builds a dimension expr representing 0<=i<d *)
let check_access loc d i =
- mkdim_appl loc "&&"
+ mkdim_appl
+ loc
+ "&&"
[ mkdim_appl loc "<=" [ mkdim_int loc 0; i ]; mkdim_appl loc "<" [ i; d ] ]
let rec repr dim = match dim.dim_desc with Dlink dim' -> repr dim' | _ -> dim
@@ -302,7 +304,8 @@ let rec instantiate inst_dim_vars dim =
| Dvar | Dident _ | Dint _ | Dbool _ ->
dim
| Dite (i, t, e) ->
- mkdim_ite dim.dim_loc
+ mkdim_ite
+ dim.dim_loc
(instantiate inst_dim_vars i)
(instantiate inst_dim_vars t)
(instantiate inst_dim_vars e)
diff --git a/src/utils/env.ml b/src/utils/env.ml
index 6e17b948..c9a860d9 100644
--- a/src/utils/env.ml
+++ b/src/utils/env.ml
@@ -32,7 +32,8 @@ let fold = IMap.fold
let overwrite x y =
IMap.merge
(fun _ _old _new -> match _new with Some _ -> _new | _ -> _old)
- x y
+ x
+ y
let pp pp_fun fmt env =
let l' = IMap.bindings env in
diff --git a/src/utils/utils.ml b/src/utils/utils.ml
index e4cdd10d..38af92cd 100644
--- a/src/utils/utils.ml
+++ b/src/utils/utils.ml
@@ -51,7 +51,8 @@ module IMap = struct
if v1 = v2 then None else o1
| _ ->
o1)
- m1 m2
+ m1
+ m2
let of_list l = List.fold_left (fun m (x, v) -> add x v m) empty l
@@ -344,14 +345,22 @@ module Format = struct
?(pp_open_box = fun fmt () -> pp_open_box fmt 0)
?(pp_eol = pp_print_nothing) ?(pp_nil = pp_print_nothing) ?pp_sep pp_v fmt
l =
- fprintf fmt "%a%a%a%a%a@]%a%a"
+ fprintf
+ fmt
+ "%a%a%a%a%a@]%a%a"
(fun fmt l -> if l <> [] then pp_prologue fmt ())
- l pp_op () pp_open_box ()
+ l
+ pp_op
+ ()
+ pp_open_box
+ ()
(fun fmt () ->
if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l)
()
(fun fmt l -> if l <> [] then pp_eol fmt ())
- l pp_cl ()
+ l
+ pp_cl
+ ()
(fun fmt l -> if l <> [] then pp_epilogue fmt ())
l
@@ -360,17 +369,33 @@ module Format = struct
let pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
?pp_eol ?pp_nil ?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_nil ?pp_sep (fun fmt x ->
+ pp_print_list
+ ?pp_prologue
+ ?pp_epilogue
+ ?pp_op
+ ?pp_cl
+ ?pp_open_box
+ ?pp_eol
+ ?pp_nil
+ ?pp_sep
+ (fun fmt x ->
pp_v fmt !i x;
incr i)
let pp_print_list_i2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
?pp_eol ?pp_nil ?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_nil ?pp_sep
+ pp_print_list_i
+ ?pp_prologue
+ ?pp_epilogue
+ ?pp_op
+ ?pp_cl
+ ?pp_open_box
+ ?pp_eol
+ ?pp_nil
+ ?pp_sep
(fun fmt i (x1, x2) -> pp_v fmt i x1 x2)
- fmt (List.combine l1 l2)
+ 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
@@ -387,8 +412,15 @@ end
let pp_date fmt tm =
let open Unix in
- Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" (tm.tm_year + 1900) tm.tm_mon
- tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
+ Format.fprintf
+ fmt
+ "%i/%i/%i, %02i:%02i:%02i"
+ (tm.tm_year + 1900)
+ tm.tm_mon
+ tm.tm_mday
+ tm.tm_hour
+ tm.tm_min
+ tm.tm_sec
(* Used for uid in variables *)
diff --git a/src/verifiers.ml b/src/verifiers.ml
index 42b9c5bf..f02ee2f5 100644
--- a/src/verifiers.ml
+++ b/src/verifiers.ml
@@ -6,7 +6,8 @@ let active = ref None
let options () =
List.flatten
- (List.map Options_management.verifier_opt
+ (List.map
+ Options_management.verifier_opt
(List.map
(fun m ->
let module M = (val m : VerifierType.S) in
@@ -18,7 +19,8 @@ let verifier_list verifiers =
(fun acc m ->
let module M = (val m : VerifierType.S) in
(if acc = "" then "" else acc ^ ", ") ^ M.name)
- "" verifiers
+ ""
+ verifiers
let get_active () =
match !active with
@@ -29,7 +31,8 @@ let get_active () =
(fun found m ->
let module M = (val m : VerifierType.S) in
if M.is_active () then m :: found else found)
- [] (verifiers ())
+ []
+ (verifiers ())
in
match found with
| [] ->
diff --git a/unused/checks/init_calculus.ml b/unused/checks/init_calculus.ml
index 75da0d54..413e2fd4 100644
--- a/unused/checks/init_calculus.ml
+++ b/unused/checks/init_calculus.ml
@@ -272,7 +272,8 @@ let type_coreclock env ck id loc =
expr_clock = Clocks.new_var true;
expr_loc = loc;
})
- dummy_id_expr cl
+ dummy_id_expr
+ cl
in
ignore (type_expr env false when_expr)
@@ -349,7 +350,8 @@ let type_top_consts env decl =
(fun env (id, c) ->
let ty = type_of_const c in
Env.add_value env id ty)
- env clist
+ env
+ clist
| Node _ | ImportedNode _ | SensorDecl _ | ActuatorDecl _ ->
env
diff --git a/unused/expand.ml b/unused/expand.ml
index da0248c4..e2ba8822 100644
--- a/unused/expand.ml
+++ b/unused/expand.ml
@@ -117,7 +117,8 @@ let rec expand_list ck_substs var_substs elist =
(fun e (eqs, locs, elist) ->
let eqs', locs', e' = expand_expr ck_substs var_substs e in
eqs' @ eqs, locs' @ locs, e' :: elist)
- elist ([], [], [])
+ elist
+ ([], [], [])
(* Expands the node instance [nd(args)]. *)
and expand_nodeinst parent_ck_substs parent_vsubsts nd args =
@@ -143,7 +144,8 @@ and expand_nodeinst parent_ck_substs parent_vsubsts nd args =
in
Hashtbl.add var_substs i.var_id i'.var_id;
{ eq_lhs = [ i'.var_id ]; eq_rhs = e; eq_loc = i.var_loc }, i')
- nd.node_inputs (expr_list_of_expr args'))
+ nd.node_inputs
+ (expr_list_of_expr args'))
in
(* Transform node local variables into local variables of the main node *)
let loc_sub =
@@ -261,7 +263,8 @@ and expand_eqs ck_substs var_substs eqs =
(fun (acc_eqs, acc_locals) eq ->
let new_eqs, new_locals, eq' = expand_eq ck_substs var_substs eq in
eq' :: (new_eqs @ acc_eqs), new_locals @ acc_locals)
- ([], []) eqs
+ ([], [])
+ eqs
(* Expands the body of a node, replacing recursively all the node calls it
contains by the body of the corresponding node. *)
diff --git a/unused/init_predef.ml b/unused/init_predef.ml
index 9c9c2115..5ba95295 100644
--- a/unused/init_predef.ml
+++ b/unused/init_predef.ml
@@ -61,7 +61,8 @@ let env =
let env' =
List.fold_right
(fun op env -> Env.add_value env op init_unary_poly_op)
- [ "uminus"; "not" ] init_env
+ [ "uminus"; "not" ]
+ init_env
in
let env' =
List.fold_right
@@ -88,7 +89,8 @@ let env =
let env' =
List.fold_right
(fun op env -> Env.add_value env op init_ternary_poly_op)
- [ "ite" ] init_env
+ [ "ite" ]
+ init_env
in
env'
diff --git a/unused/lustre_utils.ml b/unused/lustre_utils.ml
index 932c5ecb..eb557e05 100644
--- a/unused/lustre_utils.ml
+++ b/unused/lustre_utils.ml
@@ -11,7 +11,9 @@ let check_eq nd1 nd2 =
(* to keep the type info *)
let loc = Location.dummy in
let ok_var =
- Corelang.mkvar_decl loc ~orig:false
+ Corelang.mkvar_decl
+ loc
+ ~orig:false
( "__OK",
Corelang.mktyp loc Tydec_bool,
Corelang.mkclock loc Ckdec_any,
--
GitLab