From cc8525047a33fe950818079f7cb1b36fe8fa22a6 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 11:21:29 +0200
Subject: [PATCH] comment dead code with (* XXX: UNUSED *) disclaimer
---
src/annotations.mli | 10 +-
src/automata.ml | 46 +-
src/automata.mli | 16 +-
src/backends/Ada/ada_backend.ml | 8 +-
src/backends/Ada/ada_backend.mli | 2 +-
src/backends/Ada/ada_backend_adb.ml | 58 +-
src/backends/Ada/ada_backend_adb.mli | 21 +-
src/backends/Ada/ada_backend_ads.ml | 97 +-
src/backends/Ada/ada_backend_ads.mli | 20 +-
src/backends/Ada/ada_backend_common.ml | 27 +-
src/backends/Ada/ada_backend_common.mli | 1 -
src/backends/Ada/ada_backend_wrapper.ml | 129 +-
src/backends/Ada/ada_backend_wrapper.mli | 31 +-
src/backends/Ada/ada_printer.ml | 29 +-
src/backends/Ada/misc_lustre_function.ml | 164 +-
src/backends/Ada/misc_lustre_function.mli | 20 +-
src/backends/Ada/misc_printer.mli | 4 +-
src/backends/C/c_backend.ml | 12 +-
src/backends/C/c_backend.mli | 5 +-
src/backends/C/c_backend_common.ml | 4 +-
src/backends/C/c_backend_common.mli | 278 ++-
src/backends/C/c_backend_header.ml | 4 +-
src/backends/C/c_backend_header.mli | 12 +-
src/backends/C/c_backend_main.ml | 2 -
src/backends/C/c_backend_main.mli | 11 +-
src/backends/C/c_backend_makefile.ml | 13 +-
src/backends/C/c_backend_makefile.mli | 10 +-
src/backends/C/c_backend_mauve.ml | 1 -
src/backends/C/c_backend_mauve.mli | 11 +-
src/backends/C/c_backend_spec.ml | 1 -
src/backends/C/c_backend_spec.mli | 8 +-
src/backends/C/c_backend_src.ml | 1560 ++++++++---------
src/backends/C/c_backend_src.mli | 3 +-
src/backends/EMF/EMF_backend.ml | 153 +-
src/backends/EMF/EMF_backend.mli | 7 +-
src/backends/EMF/EMF_common.ml | 61 +-
src/backends/EMF/EMF_common.mli | 55 +-
src/backends/EMF/EMF_library_calls.ml | 3 +-
src/backends/EMF/EMF_library_calls.mli | 9 +-
src/backends/Horn/horn_backend.mli | 6 +-
.../Horn/horn_backend_collecting_sem.ml | 6 +-
.../Horn/horn_backend_collecting_sem.mli | 13 +-
src/backends/Horn/horn_backend_common.ml | 20 +-
src/backends/Horn/horn_backend_common.mli | 82 +-
src/backends/Horn/horn_backend_printers.ml | 79 +-
src/backends/Horn/horn_backend_printers.mli | 11 +-
src/backends/Horn/horn_backend_traces.ml | 43 +-
src/backends/Horn/horn_backend_traces.mli | 2 +-
src/backends/backends.ml | 12 +-
src/backends/backends.mli | 11 +-
src/basic_library.ml | 88 +-
src/basic_library.mli | 47 +-
src/causality.ml | 120 +-
src/causality.mli | 80 +-
src/checks/access.ml | 7 -
src/checks/access.mli | 2 +-
src/checks/algebraicLoop.ml | 30 +-
src/checks/algebraicLoop.mli | 2 +-
src/checks/liveness.ml | 22 +-
src/checks/liveness.mli | 18 +-
src/checks/stateless.mli | 13 +-
src/clock_calculus.ml | 19 +-
src/clock_calculus.mli | 10 +-
src/clock_predef.ml | 31 +-
src/clock_predef.mli | 11 +-
src/clocks.ml | 172 +-
src/clocks.mli | 65 +-
src/compiler_common.ml | 27 +-
src/compiler_common.mli | 28 +-
src/compiler_stages.mli | 15 +-
src/corelang.ml | 13 +-
src/corelang.mli | 9 +-
src/delay.ml | 101 +-
src/delay.mli | 6 +-
src/delay_predef.ml | 6 +-
src/delay_predef.mli | 11 +-
src/dune | 1 +
src/error.mli | 10 +-
src/features/machine_types/machine_types.ml | 7 +-
src/global.ml | 22 +-
src/global.mli | 10 +-
src/inliner.ml | 322 ++--
src/inliner.mli | 7 +-
src/log.ml | 4 +-
src/log.mli | 7 +-
src/lusic.mli | 8 +-
src/lustre_live.mli | 8 +-
src/lustre_types.mli | 5 +-
src/machine_code.ml | 4 +-
src/machine_code_common.ml | 4 +-
src/machine_code_common.mli | 82 +-
src/main_lustre_testgen.ml | 13 +-
src/modules.mli | 3 +-
src/mutation.ml | 499 +++---
src/mutation.mli | 11 +-
src/optimize_machine.ml | 53 +-
src/optimize_machine.mli | 8 +-
src/optimize_prog.ml | 118 +-
src/optimize_prog.mli | 2 +-
src/options.ml | 36 +-
src/options.mli | 109 +-
src/options_management.ml | 4 +-
src/options_management.mli | 23 +-
src/parsers/parse.ml | 6 +-
src/parsers/parse.mli | 14 +-
src/pathConditions.mli | 2 +-
src/plugins/mpfr/lustrec_mpfr.ml | 17 +-
src/plugins/mpfr/lustrec_mpfr.mli | 33 +-
src/plugins/pluginList.mli | 5 +-
src/plugins/pluginType.mli | 2 +-
src/plugins/plugins.mli | 16 +-
src/plugins/scopes/scopes.ml | 25 +-
src/plugins/scopes/scopes.mli | 4 +-
src/printers.ml | 93 +-
src/printers.mli | 62 +-
src/scheduling.ml | 27 +-
src/scheduling.mli | 27 +-
src/sortProg.ml | 16 +-
src/sortProg.mli | 5 +-
src/spec.mli | 2 +-
src/spec_common.mli | 24 +-
src/spec_types.ml | 3 +-
src/spec_types.mli | 2 +-
src/splitting.mli | 4 +-
src/tools/importer/vhdl_deriving_yojson.ml | 64 +-
src/tools/importer/vhdl_json_lib.ml | 152 +-
src/tools/importer/vhdl_json_lib.mli | 17 +-
src/tools/stateflow/common/activeStates.ml | 17 +-
src/tools/stateflow/common/activeStates.mli | 6 +-
src/tools/stateflow/common/basetypes.ml | 19 +-
src/tools/stateflow/common/basetypes.mli | 22 +-
src/tools/stateflow/common/datatype.ml | 140 +-
src/tools/stateflow/common/datatype.mli | 37 +-
src/tools/stateflow/models/model_stopwatch.ml | 3 +-
src/tools/stateflow/semantics/cPS.ml | 9 +-
src/tools/stateflow/semantics/cPS.mli | 2 +-
.../stateflow/semantics/cPS_interpreter.ml | 82 +-
.../stateflow/semantics/cPS_interpreter.mli | 6 +-
.../semantics/cPS_lustre_generator.ml | 9 +-
.../stateflow/semantics/cPS_transformer.mli | 10 +-
src/tools/stateflow/semantics/theta.ml | 19 +-
src/type_predef.ml | 47 +-
src/type_predef.mli | 80 +-
src/types.ml | 130 +-
src/types.mli | 10 +-
src/typing.ml | 46 +-
src/typing.mli | 29 +-
src/utils/dimension.ml | 76 +-
src/utils/dimension.mli | 68 +-
src/utils/env.mli | 23 +-
src/utils/location.ml | 5 +-
src/utils/location.mli | 27 +-
src/utils/utils.ml | 289 ++-
src/utils/utils.mli | 161 +-
src/verifierList.mli | 2 +-
src/verifierType.ml | 26 -
src/verifiers.mli | 5 +-
src/version.mli | 11 +-
158 files changed, 3980 insertions(+), 3582 deletions(-)
delete mode 100644 src/verifierType.ml
diff --git a/src/annotations.mli b/src/annotations.mli
index 98dea773..83426bbf 100644
--- a/src/annotations.mli
+++ b/src/annotations.mli
@@ -1,7 +1,9 @@
open Utils
-val expr_annotations: (string list, ident * tag) Hashtbl.t
+val expr_annotations : (string list, ident * tag) Hashtbl.t
-val add_node_ann: ident -> string list -> unit
-val add_expr_ann: ident -> tag -> string list -> unit
-val get_expr_annotations: ident list -> (ident * tag) list
+val add_node_ann : ident -> string list -> unit
+
+val add_expr_ann : ident -> tag -> string list -> unit
+
+val get_expr_annotations : ident list -> (ident * tag) list
diff --git a/src/automata.ml b/src/automata.ml
index 04c8f6f0..bf570f7a 100644
--- a/src/automata.ml
+++ b/src/automata.ml
@@ -69,12 +69,13 @@ let mkhandler hand_loc hand_state hand_unless hand_until hand_locals
let mkautomata loc id handlers =
{ aut_id = id; aut_handlers = handlers; aut_loc = loc }
-let expr_of_exit loc restart state conds tag =
- mkexpr loc
- (Expr_when
- ( List.fold_right add_branch conds (mkidentpair loc restart state),
- state,
- tag ))
+(* XXX: UNUSED *)
+(* let expr_of_exit loc restart state conds tag =
+ * mkexpr loc
+ * (Expr_when
+ * ( List.fold_right add_branch conds (mkidentpair loc restart state),
+ * state,
+ * tag )) *)
let unless_read reads handler =
let res =
@@ -259,22 +260,23 @@ let node_of_unless nused node aut_id aut_state handler =
let rename_output used name = mk_new_name used (Format.sprintf "%s_out" name)
-let rec rename_stmts_outputs frename stmts =
- match stmts with
- | [] ->
- []
- | Eq eq :: q ->
- let eq' = Eq { eq with eq_lhs = List.map frename eq.eq_lhs } in
- eq' :: rename_stmts_outputs frename q
- | Aut aut :: q ->
- let handlers' =
- List.map
- (fun h ->
- { h with hand_stmts = rename_stmts_outputs frename h.hand_stmts })
- aut.aut_handlers
- in
- let aut' = Aut { aut with aut_handlers = handlers' } in
- aut' :: rename_stmts_outputs frename q
+(* XXX: UNUSED *)
+(* let rec rename_stmts_outputs frename stmts =
+ * match stmts with
+ * | [] ->
+ * []
+ * | Eq eq :: q ->
+ * let eq' = Eq { eq with eq_lhs = List.map frename eq.eq_lhs } in
+ * eq' :: rename_stmts_outputs frename q
+ * | Aut aut :: q ->
+ * let handlers' =
+ * List.map
+ * (fun h ->
+ * { h with hand_stmts = rename_stmts_outputs frename h.hand_stmts })
+ * aut.aut_handlers
+ * in
+ * let aut' = Aut { aut with aut_handlers = handlers' } in
+ * aut' :: rename_stmts_outputs frename q *)
let mk_frename used outputs =
let table =
diff --git a/src/automata.mli b/src/automata.mli
index 1e478988..fa72518f 100644
--- a/src/automata.mli
+++ b/src/automata.mli
@@ -1,14 +1,18 @@
open Utils
open Lustre_types
-val mkhandler: Location.t -> ident -> (Location.t * expr * bool * ident) list
- -> (Location.t * expr * bool * ident) list
- -> var_decl list
- -> statement list * assert_t list * expr_annot list -> handler_desc
+val mkhandler :
+ Location.t ->
+ ident ->
+ (Location.t * expr * bool * ident) list ->
+ (Location.t * expr * bool * ident) list ->
+ var_decl list ->
+ statement list * assert_t list * expr_annot list ->
+ handler_desc
-val mkautomata: Location.t -> ident -> handler_desc list -> automata_desc
+val mkautomata : Location.t -> ident -> handler_desc list -> automata_desc
-val expand_decls: program_t -> program_t
+val expand_decls : program_t -> program_t
(* val expand_automata: (ident -> bool) -> (ident -> bool) -> ident -> typedef_desc -> node_desc ->
* automata_desc -> top_decl list * var_decl list * statement list *)
diff --git a/src/backends/Ada/ada_backend.ml b/src/backends/Ada/ada_backend.ml
index 246f9e46..8049f8a6 100644
--- a/src/backends/Ada/ada_backend.ml
+++ b/src/backends/Ada/ada_backend.ml
@@ -158,10 +158,14 @@ let translate_to_ada basename machines =
List.iter check machines;
log_str_level_two 1 "Generating ads";
- List.iter (write_file destname (_pp_filename "ads") Ada_backend_ads.pp_file) _machines;
+ List.iter
+ (write_file destname (_pp_filename "ads") Ada_backend_ads.pp_file)
+ _machines;
log_str_level_two 1 "Generating adb";
- List.iter (write_file destname (_pp_filename "adb") Ada_backend_adb.pp_file) _machines;
+ List.iter
+ (write_file destname (_pp_filename "adb") Ada_backend_adb.pp_file)
+ _machines;
(* If a main node is given we generate a main adb file and a project file *)
log_str_level_two 1 "Generating wrapper files";
diff --git a/src/backends/Ada/ada_backend.mli b/src/backends/Ada/ada_backend.mli
index 8de317ed..bb42d05f 100644
--- a/src/backends/Ada/ada_backend.mli
+++ b/src/backends/Ada/ada_backend.mli
@@ -1,5 +1,5 @@
+val translate_to_ada : string -> Machine_code_types.machine_t list -> unit
(** Main function of the Ada backend. It calls all the subfunction creating all
the file and fill them with Ada code representing the machines list given.
@param basename name of the lustre file @param prog list of machines to
translate **)
-val translate_to_ada: string -> Machine_code_types.machine_t list -> unit
diff --git a/src/backends/Ada/ada_backend_adb.ml b/src/backends/Ada/ada_backend_adb.ml
index 7c9e6aaf..47e620a3 100644
--- a/src/backends/Ada/ada_backend_adb.ml
+++ b/src/backends/Ada/ada_backend_adb.ml
@@ -24,17 +24,17 @@ open Ada_backend_common
(** Printing function for basic assignement [var := value].
- @param fmt the formater to print on @param var_name the name of the
- variable @param value the value to be assigned **)
+ @param fmt the formater to print on @param var_name the name of the variable
+ @param value the value to be assigned **)
let pp_assign env fmt var value =
fprintf fmt "%a := %a" (pp_var env) var (pp_value env) value
(** Printing function for instruction. See {!type:Machine_code_types.instr_t}
for more details on machine types.
- @param typed_submachines list of all typed machine instances of this
- machine @param machine the current machine @param fmt the formater to
- print on @param instr the instruction to print **)
+ @param typed_submachines list of all typed machine instances of this machine
+ @param machine the current machine @param fmt the formater to print on
+ @param instr the instruction to print **)
let rec pp_machine_instr typed_submachines env instr fmt =
let pp_instr = pp_machine_instr typed_submachines env in
(* Print args for a step call *)
@@ -49,9 +49,9 @@ let rec pp_machine_instr typed_submachines env instr fmt =
(List.map pp_when hl)
in
(* Print a if *)
- (* If neg is true the we must test for the negation of the condition. It
- first check that we don't have a negation and a else case, if so it
- inverses the two branch and remove the negation doing a recursive call. *)
+ (* If neg is true the we must test for the negation of the condition. It first
+ check that we don't have a negation and a else case, if so it inverses the
+ two branch and remove the negation doing a recursive call. *)
let pp_if fmt (neg, g, instrs1, instrs2) =
let pp_cond =
if neg then fun fmt x -> fprintf fmt "! (%a)" (pp_value env) x
@@ -78,9 +78,7 @@ let rec pp_machine_instr typed_submachines env instr fmt =
(* reset *)
| MSetReset i when List.mem_assoc i typed_submachines ->
let substitution, submachine = get_instance i typed_submachines in
- let pp_package =
- pp_package_name_with_polymorphic substitution submachine
- in
+ let pp_package = pp_package_name_with_polymorphic substitution submachine in
let args =
if is_machine_statefull submachine then [ [ pp_state i ] ] else []
in
@@ -94,9 +92,7 @@ let rec pp_machine_instr typed_submachines env instr fmt =
pp_assign env fmt i0 value
| MStep (il, i, vl) when List.mem_assoc i typed_submachines ->
let substitution, submachine = get_instance i typed_submachines in
- let pp_package =
- pp_package_name_with_polymorphic substitution submachine
- in
+ let pp_package = pp_package_name_with_polymorphic substitution submachine in
let input = List.map (fun x fmt -> pp_value env fmt x) vl in
let output = List.map pp_var_name il in
let args =
@@ -113,14 +109,16 @@ 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" (pp_print_list ~pp_sep:pp_print_nothing pp_oneline_comment) lines
+ fprintf fmt "%a"
+ (pp_print_list ~pp_sep:pp_print_nothing pp_oneline_comment)
+ lines
| _ ->
assert false
(** Print the definition of the step procedure from a machine.
- @param typed_submachines list of all typed machine instances of this
- machine @param fmt the formater to print on @param machine the machine **)
+ @param typed_submachines list of all typed machine instances of this machine
+ @param fmt the formater to print on @param machine the machine **)
let pp_step_definition env typed_submachines fmt (m, m_spec_opt, guarantees) =
let transform_local_to_state_assign instr =
match instr.instr_desc with
@@ -152,15 +150,15 @@ let pp_step_definition env typed_submachines fmt (m, m_spec_opt, guarantees) =
let content =
AdaProcedureContent
( ((if pp_local_ghost_list = [] then [] else [ pp_local_ghost_list ])
- @ if pp_local_list = [] then [] else [ pp_local_list ]),
+ @ if pp_local_list = [] then [] else [ pp_local_list ]),
pp_instr_list )
in
pp_procedure pp_step_procedure_name (build_pp_arg_step m) None fmt content
(** Print the definition of the reset procedure from a machine.
- @param typed_submachines list of all typed machine instances of this
- machine @param fmt the formater to print on @param machine the machine **)
+ @param typed_submachines list of all typed machine instances of this machine
+ @param fmt the formater to print on @param machine the machine **)
let pp_reset_definition env typed_submachines fmt (m, m_spec_opt) =
let build_assign = function
| var ->
@@ -176,15 +174,14 @@ let pp_reset_definition env typed_submachines fmt (m, m_spec_opt) =
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 typed instance. A typed submachine instance is (ident, type_machine)
- with ident the instance name and typed_machine is (substitution, machine)
- with machine the machine associated to the instance and substitution the
- instanciation of all its polymorphic types. @param fmt the formater to
- print on @param typed_submachines list of all typed machine instances of
- this machine @param m the machine **)
-let pp_file fmt (typed_submachines, ((opt_spec_machine, guarantees), machine))
- =
+(** Print the package definition(ads) of a machine. It requires the list of all
+ typed instance. A typed submachine instance is (ident, type_machine) with
+ ident the instance name and typed_machine is (substitution, machine) with
+ machine the machine associated to the instance and substitution the
+ instanciation of all its polymorphic types. @param fmt the formater to print
+ on @param typed_submachines list of all typed machine instances of this
+ machine @param m the machine **)
+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
@@ -208,8 +205,7 @@ let pp_file fmt (typed_submachines, ((opt_spec_machine, guarantees), machine))
in
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_adb.mli b/src/backends/Ada/ada_backend_adb.mli
index e52d73d4..324febd5 100644
--- a/src/backends/Ada/ada_backend_adb.mli
+++ b/src/backends/Ada/ada_backend_adb.mli
@@ -1,12 +1,15 @@
open Utils
open Machine_code_types
-(** Print the package definition(ads) of a machine. It requires the list of
- all typed instance. A typed submachine instance is (ident, type_machine)
- with ident the instance name and typed_machine is (substitution, machine)
- with machine the machine associated to the instance and substitution the
- instanciation of all its polymorphic types. @param fmt the formater to
- print on @param typed_submachines list of all typed machine instances of
- this machine @param m the machine **)
-val pp_file: Format.formatter -> (ident * ((tag * Types.t) list * machine_t)) list
- * ((machine_t option * ident list) * machine_t) -> unit
+val pp_file :
+ Format.formatter ->
+ (ident * ((tag * Types.t) list * machine_t)) list
+ * ((machine_t option * ident list) * machine_t) ->
+ unit
+(** Print the package definition(ads) of a machine. It requires the list of all
+ typed instance. A typed submachine instance is (ident, type_machine) with
+ ident the instance name and typed_machine is (substitution, machine) with
+ machine the machine associated to the instance and substitution the
+ instanciation of all its polymorphic types. @param fmt the formater to print
+ on @param typed_submachines list of all typed machine instances of this
+ machine @param m the machine **)
diff --git a/src/backends/Ada/ada_backend_ads.ml b/src/backends/Ada/ada_backend_ads.ml
index 3b74f2bc..f7ef4737 100644
--- a/src/backends/Ada/ada_backend_ads.ml
+++ b/src/backends/Ada/ada_backend_ads.ml
@@ -19,9 +19,6 @@ open Ada_backend_common
(** Functions printing the .ads file **)
-let rec init f = function i when i < 0 -> [] | i -> f i :: init f (i - 1)
-(*should be replaced by the init of list from ocaml std lib*)
-
let suffixOld = "_old"
let suffixNew = "_new"
@@ -32,21 +29,20 @@ let pp_transition_name fmt = fprintf fmt "transition"
let pp_init_name fmt = fprintf fmt "init"
-let pp_state_name_predicate suffix fmt =
- fprintf fmt "%t%s" pp_state_name suffix
+let pp_state_name_predicate suffix fmt = fprintf fmt "%t%s" pp_state_name suffix
let pp_axiomatize_package_name fmt = fprintf fmt "axiomatize"
-(** Print the expression function representing the transition predicate.
- @param fmt the formater to print on **)
+(** Print the expression function representing the transition predicate. @param
+ fmt the formater to print on **)
let pp_init_predicate fmt () =
let new_state =
AdaIn, pp_state_name_predicate suffixNew, pp_state_type, None
in
pp_predicate pp_init_name [ [ new_state ] ] true fmt None
-(** Print the expression function representing the transition predicate.
- @param fmt the formater to print on @param machine the machine **)
+(** Print the expression function representing the transition predicate. @param
+ fmt the formater to print on @param machine the machine **)
let pp_transition_predicate fmt (_, m) =
let old_state =
AdaIn, pp_state_name_predicate suffixOld, pp_state_type, None
@@ -78,8 +74,8 @@ let pp_new_package fmt (substitutions, machine) =
in
pp_package_instanciation pp_new_name pp_name fmt instanciations
-(** Remove duplicates from a list according to a given predicate. @param eq
- the predicate defining equality @param l the list to parse **)
+(** Remove duplicates from a list according to a given predicate. @param eq the
+ predicate defining equality @param l the list to parse **)
let remove_duplicates eq l =
let aux l x = if List.exists (eq x) l then l else x :: l in
List.fold_left aux [] l
@@ -89,18 +85,15 @@ let eq_typed_machine (subst1, machine1) (subst2, machine2) =
String.equal machine1.mname.node_id machine2.mname.node_id
&& List.for_all2 (fun a b -> pp_eq_type (snd a) (snd b)) subst1 subst2
-(** Print the package declaration(ads) of a machine. It requires the list of
- all typed instance. A typed submachine is a (ident, typed_machine) with -
- ident: the name - typed_machine: a (substitution, machine) with - machine:
- the submachine struct - substitution the instanciation of all its
- polymorphic types. @param fmt the formater to print on @param
- typed_submachines list of all typed submachines of this machine @param m
- the machine **)
+(** Print the package declaration(ads) of a machine. It requires the list of all
+ typed instance. A typed submachine is a (ident, typed_machine) with - ident:
+ the name - typed_machine: a (substitution, machine) with - machine: the
+ submachine struct - substitution the instanciation of all its polymorphic
+ types. @param fmt the formater to print on @param typed_submachines list of
+ all typed submachines of this machine @param m the machine **)
let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
let typed_machines = snd (List.split typed_submachines) in
- let typed_machines_set =
- remove_duplicates eq_typed_machine typed_machines
- in
+ let typed_machines_set = remove_duplicates eq_typed_machine typed_machines in
let machines_to_import =
List.map pp_package_name (snd (List.split typed_machines_set))
@@ -112,9 +105,7 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
List.filter (fun (l, _) -> l != []) typed_machines_set
in
- let typed_instances =
- List.filter is_submachine_statefull typed_submachines
- in
+ let typed_instances = List.filter is_submachine_statefull typed_submachines in
let memories =
match m_spec_opt with
@@ -123,15 +114,15 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
| Some m ->
List.map
(fun x ->
- pp_var_decl
- (build_pp_var_decl AdaNoMode (Some (true, false, [], [])) x))
+ pp_var_decl
+ (build_pp_var_decl AdaNoMode (Some (true, false, [], [])) x))
m.mmemory
in
let ghost_private = memories in
(* Commented since not used. Could be reinjected in the code let vars_spec =
match m_spec_opt with | None -> [] | Some m_spec -> List.map
- (build_pp_var_decl AdaNoMode (Some (true, false, [], [])))
- (m_spec.mmemory) in *)
+ (build_pp_var_decl AdaNoMode (Some (true, false, [], []))) (m_spec.mmemory)
+ in *)
let vars = List.map (build_pp_var_decl AdaNoMode None) m.mmemory in
let states =
List.map
@@ -165,16 +156,12 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
let pp_private_section fmt =
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
@@ -205,9 +192,7 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
[ invariant ], [ transition; invariant ]
else [], []
in
- let post_conditions =
- state_post_conditions @ guarantee_post_conditions
- in
+ let post_conditions = state_post_conditions @ guarantee_post_conditions in
let pre_conditions = state_pre_conditions in
if post_conditions = [] && pre_conditions = [] then None
else Some (false, false, pre_conditions, post_conditions)
@@ -221,31 +206,28 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
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
+ (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)
+ (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
- "pragma Annotate (GNATProve, External_Axiomatization);@,\
- @,\
- %a;@,\
- %a;@,\
- %a"
- (*Declare the init predicate*)
- pp_init_predicate ()
- (*Declare the transition predicate*)
- pp_transition_predicate (m_spec_opt, m)
- (*Declare the invariant predicate*)
- pp_invariant_predicate ())
+ fprintf fmt
+ "pragma Annotate (GNATProve, External_Axiomatization);@,\
+ @,\
+ %a;@,\
+ %a;@,\
+ %a"
+ (*Declare the init predicate*)
+ pp_init_predicate ()
+ (*Declare the transition predicate*)
+ pp_transition_predicate (m_spec_opt, m)
+ (*Declare the invariant predicate*)
+ pp_invariant_predicate ())
(*Print the private section*)
pp_private_section
in
@@ -255,8 +237,7 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
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_ads.mli b/src/backends/Ada/ada_backend_ads.mli
index 90b11e4a..75494563 100644
--- a/src/backends/Ada/ada_backend_ads.mli
+++ b/src/backends/Ada/ada_backend_ads.mli
@@ -1,12 +1,14 @@
open Utils
open Machine_code_types
-(** Print the package declaration(ads) of a machine. It requires the list of
- all typed instance. A typed submachine is a (ident, typed_machine) with -
- ident: the name - typed_machine: a (substitution, machine) with - machine:
- the submachine struct - substitution the instanciation of all its
- polymorphic types. @param fmt the formater to print on @param
- typed_submachines list of all typed submachines of this machine @param m
- the machine **)
-val pp_file: Format.formatter -> (ident * ((tag * Types.t) list * machine_t)) list
- * ((machine_t option * ident list) * machine_t) -> unit
+val pp_file :
+ Format.formatter ->
+ (ident * ((tag * Types.t) list * machine_t)) list
+ * ((machine_t option * ident list) * machine_t) ->
+ unit
+(** Print the package declaration(ads) of a machine. It requires the list of all
+ typed instance. A typed submachine is a (ident, typed_machine) with - ident:
+ the name - typed_machine: a (substitution, machine) with - machine: the
+ submachine struct - substitution the instanciation of all its polymorphic
+ types. @param fmt the formater to print on @param typed_submachines list of
+ all typed submachines of this machine @param m the machine **)
diff --git a/src/backends/Ada/ada_backend_common.ml b/src/backends/Ada/ada_backend_common.ml
index daff6d65..efc7d194 100644
--- a/src/backends/Ada/ada_backend_common.ml
+++ b/src/backends/Ada/ada_backend_common.ml
@@ -76,13 +76,11 @@ let pp_package_name machine fmt =
let pp_type fmt typ =
let open Types in
let t = repr typ in
- if is_bool_type t then
- pp_boolean_type fmt
- else if is_int_type t then
- pp_integer_type fmt
- else if is_real_type t then
- pp_float_type fmt
- else match t.tdesc with
+ if is_bool_type t then pp_boolean_type fmt
+ else if is_int_type t then pp_integer_type fmt
+ else if is_real_type t then pp_float_type fmt
+ else
+ match t.tdesc with
| Tunivar ->
pp_polymorphic_type typ.tid fmt
| Tbasic _ ->
@@ -125,14 +123,10 @@ let pp_type fmt typ =
type **)
let default_ada_cst t =
let open Types in
- if is_bool_type t then
- Const_tag tag_false
- else if is_int_type t then
- Const_int 0
- else if is_real_type t then
- Const_real Real.zero
- else
- assert false
+ if is_bool_type t then Const_tag tag_false
+ else if is_int_type t then Const_int 0
+ else if is_real_type t then Const_real Real.zero
+ else assert false
(** Make a default value from a given type. @param typ the type **)
let mk_default_value typ =
@@ -160,8 +154,7 @@ let pp_package_name_with_polymorphic substitution machine fmt =
(fun poly1 (poly2, _) -> poly1 = poly2)
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 "_")
diff --git a/src/backends/Ada/ada_backend_common.mli b/src/backends/Ada/ada_backend_common.mli
index a193ba56..2e5c322d 100644
--- a/src/backends/Ada/ada_backend_common.mli
+++ b/src/backends/Ada/ada_backend_common.mli
@@ -1,7 +1,6 @@
open Format
open Machine_code_types
open Lustre_types
-open Types
open Ada_printer
open Misc_printer
diff --git a/src/backends/Ada/ada_backend_wrapper.ml b/src/backends/Ada/ada_backend_wrapper.ml
index 3194e73f..27cc87d1 100644
--- a/src/backends/Ada/ada_backend_wrapper.ml
+++ b/src/backends/Ada/ada_backend_wrapper.ml
@@ -24,9 +24,8 @@ let build_text_io_package_local typ =
(fun fmt -> fprintf fmt "Ada.Text_IO.%s_IO" typ),
[ ((fun fmt -> fprintf fmt "Num"), fun fmt -> fprintf fmt "%s" typ) ] )
-(** Print the main file calling in a loop the step function of the main
- machine. @param fmt the formater to print on @param machine the main
- machine **)
+(** Print the main file calling in a loop the step function of the main machine.
+ @param fmt the formater to print on @param machine the main machine **)
let pp_main_adb fmt machine =
let statefull = is_machine_statefull machine in
@@ -44,17 +43,17 @@ let pp_main_adb fmt machine =
];
]
@ (if statefull then
+ [
[
- [
- AdaLocalVar
- (build_pp_state_decl_from_subinstance AdaNoMode None
- (asprintf "%t" pp_state_name, ([], machine)));
- ];
- ]
- else [])
+ AdaLocalVar
+ (build_pp_state_decl_from_subinstance AdaNoMode None
+ (asprintf "%t" pp_state_name, ([], machine)));
+ ];
+ ]
+ else [])
@ (if machine.mstep.step_inputs != [] then
- [ List.map (build_pp_var_decl_local None) machine.mstep.step_inputs ]
- else [])
+ [ List.map (build_pp_var_decl_local None) machine.mstep.step_inputs ]
+ else [])
@
if machine.mstep.step_outputs != [] then
[ List.map (build_pp_var_decl_local None) machine.mstep.step_outputs ]
@@ -88,9 +87,8 @@ let pp_main_adb fmt machine =
"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)
- else
- assert false
- (* Could not be the top level inputs *)
+ else assert false
+ (* Could not be the top level inputs *)
in
(* Loop instructions *)
@@ -102,11 +100,7 @@ let pp_main_adb fmt machine =
(machine.mstep.step_inputs @ machine.mstep.step_outputs)
in
fprintf fmt
- "while not Ada.Text_IO.End_Of_File loop@,\
- \ @[<v>%a;@,\
- %a;@,\
- %a;@]@,\
- end loop"
+ "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
(pp_package_access (pp_package, pp_step_procedure_name), [ args ])
@@ -117,13 +111,13 @@ let pp_main_adb fmt machine =
(* Print the file *)
let instrs =
(if statefull then
- [
- (fun fmt ->
- pp_call fmt
- ( pp_package_access (pp_package, pp_reset_procedure_name),
- [ [ pp_state_name ] ] ));
- ]
- else [])
+ [
+ (fun 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)
@@ -132,16 +126,15 @@ let pp_main_adb fmt machine =
(AdaProcedureContent (locals, instrs))
(** Print the name of the ada project configuration file. @param fmt the
- formater to print on @param main_machine the machine associated to the
- main node **)
+ formater to print on @param main_machine the machine associated to the main
+ node **)
let pp_project_configuration_name fmt basename = fprintf fmt "%s.adc" basename
-(** Print the project configuration file. @param fmt the formater to print on
- **)
+(** Print the project configuration file. @param fmt the formater to print on **)
let pp_project_configuration_file fmt = fprintf fmt "pragma SPARK_Mode (On);"
-(** Print the name of the ada project file. @param base_name name of the
- lustre file @param fmt the formater to print on **)
+(** Print the name of the ada project file. @param base_name name of the lustre
+ file @param fmt the formater to print on **)
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
@@ -153,16 +146,18 @@ let pp_for name args fmt =
let pp_content fmt lines =
fprintf fmt " @[<v>%a%a@]"
- (pp_print_list ~pp_sep:pp_print_semicolon (fun fmt pp -> fprintf fmt "%t" pp))
+ (pp_print_list ~pp_sep:pp_print_semicolon (fun fmt pp ->
+ fprintf fmt "%t" pp))
lines
- (if lines = [] then pp_print_nothing else pp_print_semicolon) ()
+ (if lines = [] then pp_print_nothing else pp_print_semicolon)
+ ()
let pp_package name lines fmt =
fprintf fmt "package %s is@,%a@,end %s" name pp_content lines name
(** Print the gpr project file, if there is a machine in machine_opt then an
- executable project is made else it is a library. @param fmt the formater
- to print on @param machine_opt the main machine option **)
+ executable project is made else it is a library. @param fmt the formater to
+ print on @param machine_opt the main machine option **)
let pp_project_file machines basename fmt machine_opt =
let adbs =
List.map (asprintf "%a" (pp_machine_filename "adb")) machines
@@ -173,41 +168,39 @@ let pp_project_file machines basename fmt machine_opt =
| Some m ->
[ asprintf "%a" pp_main_filename m ]
in
- let project_name =
- basename ^ if machine_opt = None then "_lib" else "_exe"
- in
+ let project_name = basename ^ if machine_opt = None then "_lib" else "_exe" in
fprintf fmt "%sproject %s is@,%a@,end %s;"
(if machine_opt = None then "library " else "")
project_name pp_content
((match machine_opt with
- | None ->
+ | None ->
+ [
+ pp_for_single "Library_Name" basename;
+ pp_for_single "Library_Dir" "lib";
+ ]
+ | Some _ ->
+ [
+ pp_for "Main" [ asprintf "%t" pp_main_procedure_name ];
+ pp_for_single "Exec_Dir" "bin";
+ ])
+ @ [
+ pp_for_single "Object_Dir" "obj";
+ pp_for "Source_Files" adbs;
+ pp_package "Builder"
[
- pp_for_single "Library_Name" basename;
- pp_for_single "Library_Dir" "lib";
- ]
- | Some _ ->
+ pp_for_single "Global_Configuration_Pragmas"
+ (asprintf "%a" pp_project_configuration_name basename);
+ ];
+ pp_package "Prove"
[
- pp_for "Main" [ asprintf "%t" pp_main_procedure_name ];
- pp_for_single "Exec_Dir" "bin";
- ])
- @ [
- pp_for_single "Object_Dir" "obj";
- pp_for "Source_Files" adbs;
- pp_package "Builder"
- [
- pp_for_single "Global_Configuration_Pragmas"
- (asprintf "%a" pp_project_configuration_name basename);
- ];
- pp_package "Prove"
- [
- pp_for "Switches"
- [
- "--mode=prove";
- "--report=statistics";
- "--proof=per_check";
- "--warnings=continue";
- ];
- pp_for_single "Proof_Dir" (asprintf "proof");
- ];
- ])
+ pp_for "Switches"
+ [
+ "--mode=prove";
+ "--report=statistics";
+ "--proof=per_check";
+ "--warnings=continue";
+ ];
+ pp_for_single "Proof_Dir" (asprintf "proof");
+ ];
+ ])
project_name
diff --git a/src/backends/Ada/ada_backend_wrapper.mli b/src/backends/Ada/ada_backend_wrapper.mli
index db8a9481..82b73804 100644
--- a/src/backends/Ada/ada_backend_wrapper.mli
+++ b/src/backends/Ada/ada_backend_wrapper.mli
@@ -2,25 +2,24 @@ open Utils
open Format
open Machine_code_types
-(** Print the main file calling in a loop the step function of the main
- machine. @param fmt the formater to print on @param machine the main
- machine **)
-val pp_main_adb: formatter -> machine_t -> unit
+val pp_main_adb : formatter -> machine_t -> unit
+(** Print the main file calling in a loop the step function of the main machine.
+ @param fmt the formater to print on @param machine the main machine **)
-(** Print the name of the ada project file. @param base_name name of the
- lustre file @param fmt the formater to print on **)
-val pp_project_name: string -> formatter -> unit
+val pp_project_name : string -> formatter -> unit
+(** Print the name of the ada project file. @param base_name name of the lustre
+ file @param fmt the formater to print on **)
+val pp_project_file :
+ machine_t list -> string -> formatter -> machine_t option -> unit
(** Print the gpr project file, if there is a machine in machine_opt then an
- executable project is made else it is a library. @param fmt the formater
- to print on @param machine_opt the main machine option **)
-val pp_project_file: machine_t list -> string -> formatter -> machine_t option -> unit
+ executable project is made else it is a library. @param fmt the formater to
+ print on @param machine_opt the main machine option **)
+val pp_project_configuration_name : formatter -> string -> unit
(** Print the name of the ada project configuration file. @param fmt the
- formater to print on @param main_machine the machine associated to the
- main node **)
-val pp_project_configuration_name: formatter -> string -> unit
+ formater to print on @param main_machine the machine associated to the main
+ node **)
-(** Print the project configuration file. @param fmt the formater to print on
- **)
-val pp_project_configuration_file: formatter -> unit
+val pp_project_configuration_file : formatter -> unit
+(** Print the project configuration file. @param fmt the formater to print on **)
diff --git a/src/backends/Ada/ada_printer.ml b/src/backends/Ada/ada_printer.ml
index 3443fa9f..2d98055b 100644
--- a/src/backends/Ada/ada_printer.ml
+++ b/src/backends/Ada/ada_printer.ml
@@ -92,16 +92,15 @@ let pp_args ~pp_sep fmt = function
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 (fun fmt pp -> pp fmt)
- fmt
- pp_item_list
+ ~pp_epilogue:pp_print_semicolon ~pp_sep:pp_print_semicolon
+ (fun fmt pp -> pp fmt)
+ fmt pp_item_list
let pp_and l fmt =
- fprintf fmt "(%t)" (pp_group ~pp_sep:(fun fmt () -> fprintf fmt "@ and then ") l)
+ fprintf fmt "(%t)"
+ (pp_group ~pp_sep:(fun fmt () -> fprintf fmt "@ and then ") l)
let pp_or l fmt =
fprintf fmt "(%t)" (pp_group ~pp_sep:(fun fmt () -> fprintf fmt "@ or ") l)
@@ -123,7 +122,8 @@ let pp_ada_with fmt = function
if not import then fprintf fmt ""
else
fprintf fmt " Import%a"
- (if contract = [] then pp_print_nothing else pp_print_comma) ()
+ (if contract = [] then pp_print_nothing else pp_print_comma)
+ ()
in
let pp_aspect aspect fmt pps =
if pps = [] then fprintf fmt ""
@@ -189,7 +189,9 @@ and pp_content pp_name fmt = function
fprintf fmt " is@, @[<v 2>(%t)@]" pp_content
| AdaProcedureContent (local_list, pp_instr_list) ->
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)
+ (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
| AdaRecord var_list ->
assert (var_list != []);
@@ -197,14 +199,16 @@ and pp_content pp_name fmt = function
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 (pp_args ~pp_sep:pp_print_comma)
+ 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
- pp_name (pp_args ~pp_sep:pp_print_semicolon)
+ 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_with_opt
@@ -392,7 +396,8 @@ let pp_oneline_comment fmt s =
fprintf fmt "-- %s@," s
let pp_call fmt (pp_name, args) =
- fprintf fmt "%t%a" pp_name (pp_args ~pp_sep:pp_print_comma)
+ fprintf fmt "%t%a" pp_name
+ (pp_args ~pp_sep:pp_print_comma)
(List.map (pp_group ~pp_sep:pp_print_comma) args)
(** Print the complete name of variable. @param m the machine to check if it is
diff --git a/src/backends/Ada/misc_lustre_function.ml b/src/backends/Ada/misc_lustre_function.ml
index 794ab385..b14c8535 100644
--- a/src/backends/Ada/misc_lustre_function.ml
+++ b/src/backends/Ada/misc_lustre_function.ml
@@ -1,7 +1,5 @@
open Machine_code_types
open Lustre_types
-open Corelang
-(* open Machine_code_common *)
let is_machine_statefull m = not m.mname.node_dec_stateless
@@ -204,15 +202,16 @@ let get_substitution machine ident submachine =
let get_instance identifier typed_submachines =
try List.assoc identifier typed_submachines with Not_found -> assert false
-(*Usefull for debug*)
-let pp_type_debug fmt typ =
- match (Types.repr typ).Types.tdesc with
- | Types.Tbasic t ->
- Types.BasicT.pp fmt t
- | Types.Tunivar ->
- Format.fprintf fmt "POLY(%i)" typ.Types.tid
- | _ ->
- assert false
+(* XXX: UNUSED *)
+(*Useful for debug*)
+(* let pp_type_debug fmt typ =
+ * match (Types.repr typ).Types.tdesc with
+ * | Types.Tbasic t ->
+ * Types.BasicT.pp fmt t
+ * | Types.Tunivar ->
+ * Format.fprintf fmt "POLY(%i)" typ.Types.tid
+ * | _ ->
+ * assert false *)
let build_if g c1 i1 tl =
let neg = c1 = tag_false in
@@ -225,74 +224,75 @@ let build_if g c1 i1 tl =
| _ ->
neg, g, i1, other
-let rec push_if_in_expr = function
- | [] ->
- []
- | instr :: q ->
- (match get_instr_desc instr with
- | MBranch (g, (c1, i1) :: tl) when c1 = tag_false || c1 = tag_true ->
- let _, g, instrs1, instrs2 = build_if g c1 i1 tl in
- let instrs1_pushed = push_if_in_expr instrs1 in
- let get_assign instr =
- match get_instr_desc instr with
- | MLocalAssign (id, value) ->
- false, id, value
- | MStateAssign (id, value) ->
- true, id, value
- | _ ->
- assert false
- in
- let gen_eq ident state value1 value2 =
- assert (check_type_equal ident.var_type value1.value_type);
- assert (check_type_equal ident.var_type value2.value_type);
- let value =
- {
- value_desc = Fun ("ite", [ g; value1; value2 ]);
- value_type = ident.var_type;
- value_annot = None;
- }
- in
- let assign =
- if state then MStateAssign (ident, value)
- else MLocalAssign (ident, value)
- in
- { instr_desc = assign; lustre_eq = None; instr_spec = [] }
- in
- let mkval_var id =
- { value_desc = Var id; value_type = id.var_type; value_annot = None }
- in
- let rec find_split s1 id1 accu = function
- | [] ->
- [], accu, mkval_var id1
- | (s2, id2, v2) :: q when s1 = s2 && id1.var_id = id2.var_id ->
- accu, q, v2
- | t :: q ->
- find_split s1 id1 (t :: accu) q
- in
- let gen_from_else l =
- List.map (fun (s2, id2, v2) -> gen_eq id2 s2 (mkval_var id2) v2) l
- in
- let rec gen_assigns if_assigns else_assigns =
- let res, accu_else =
- match if_assigns with
- | (s1, id1, v1) :: q ->
- let accu, remain, v2 = find_split s1 id1 [] else_assigns in
- gen_eq id1 s1 v1 v2 :: gen_assigns q remain, accu
- | [] ->
- [], else_assigns
- in
- gen_from_else accu_else @ res
- in
- let if_assigns = List.map get_assign instrs1_pushed in
- let else_assigns =
- match instrs2 with
- | None ->
- []
- | Some instrs2 ->
- let instrs2_pushed = push_if_in_expr instrs2 in
- List.map get_assign instrs2_pushed
- in
- gen_assigns if_assigns else_assigns
- | _ ->
- [ instr ])
- @ push_if_in_expr q
+(* XXX: UNUSED *)
+(* let rec push_if_in_expr = function
+ * | [] ->
+ * []
+ * | instr :: q ->
+ * (match get_instr_desc instr with
+ * | MBranch (g, (c1, i1) :: tl) when c1 = tag_false || c1 = tag_true ->
+ * let _, g, instrs1, instrs2 = build_if g c1 i1 tl in
+ * let instrs1_pushed = push_if_in_expr instrs1 in
+ * let get_assign instr =
+ * match get_instr_desc instr with
+ * | MLocalAssign (id, value) ->
+ * false, id, value
+ * | MStateAssign (id, value) ->
+ * true, id, value
+ * | _ ->
+ * assert false
+ * in
+ * let gen_eq ident state value1 value2 =
+ * assert (check_type_equal ident.var_type value1.value_type);
+ * assert (check_type_equal ident.var_type value2.value_type);
+ * let value =
+ * {
+ * value_desc = Fun ("ite", [ g; value1; value2 ]);
+ * value_type = ident.var_type;
+ * value_annot = None;
+ * }
+ * in
+ * let assign =
+ * if state then MStateAssign (ident, value)
+ * else MLocalAssign (ident, value)
+ * in
+ * { instr_desc = assign; lustre_eq = None; instr_spec = [] }
+ * in
+ * let mkval_var id =
+ * { value_desc = Var id; value_type = id.var_type; value_annot = None }
+ * in
+ * let rec find_split s1 id1 accu = function
+ * | [] ->
+ * [], accu, mkval_var id1
+ * | (s2, id2, v2) :: q when s1 = s2 && id1.var_id = id2.var_id ->
+ * accu, q, v2
+ * | t :: q ->
+ * find_split s1 id1 (t :: accu) q
+ * in
+ * let gen_from_else l =
+ * List.map (fun (s2, id2, v2) -> gen_eq id2 s2 (mkval_var id2) v2) l
+ * in
+ * let rec gen_assigns if_assigns else_assigns =
+ * let res, accu_else =
+ * match if_assigns with
+ * | (s1, id1, v1) :: q ->
+ * let accu, remain, v2 = find_split s1 id1 [] else_assigns in
+ * gen_eq id1 s1 v1 v2 :: gen_assigns q remain, accu
+ * | [] ->
+ * [], else_assigns
+ * in
+ * gen_from_else accu_else @ res
+ * in
+ * let if_assigns = List.map get_assign instrs1_pushed in
+ * let else_assigns =
+ * match instrs2 with
+ * | None ->
+ * []
+ * | Some instrs2 ->
+ * let instrs2_pushed = push_if_in_expr instrs2 in
+ * List.map get_assign instrs2_pushed
+ * in
+ * gen_assigns if_assigns else_assigns
+ * | _ ->
+ * [ instr ])
+ * @ push_if_in_expr q *)
diff --git a/src/backends/Ada/misc_lustre_function.mli b/src/backends/Ada/misc_lustre_function.mli
index 74a4f7df..a2a54e00 100644
--- a/src/backends/Ada/misc_lustre_function.mli
+++ b/src/backends/Ada/misc_lustre_function.mli
@@ -1,36 +1,39 @@
open Utils
open Machine_code_types
-val is_machine_statefull: machine_t -> bool
-val is_arrow: machine_t -> bool
+val is_machine_statefull : machine_t -> bool
+val is_arrow : machine_t -> bool
+
+val find_all_polymorphic_type : machine_t -> int list
(** Find all polymorphic type : Types.Tunivar in a machine. @param machine the
machine @return a list of id corresponding to polymorphic type **)
-val find_all_polymorphic_type: machine_t -> int list
+val pp_eq_type : Types.t -> Types.t -> bool
(** Test if two types are the same. @param typ1 the first type @param typ2 the
second type **)
-val pp_eq_type: Types.t -> Types.t -> bool
+val is_submachine_statefull : 'a * ('b * machine_t) -> bool
(** Check if a submachine is statefull. @param submachine a submachine @return
true if the submachine is statefull **)
-val is_submachine_statefull: 'a * ('b * machine_t) -> bool
+val get_instance : 'a -> ('a * 'b) list -> 'b
(** Extract from a machine the instance corresponding to the identifier, assume
that the identifier exists in the instances of the machine.
@param identifier the instance identifier @param machine a machine @return
the instance of machine.minstances corresponding to identifier **)
-val get_instance: 'a -> ('a * 'b) list -> 'b
-val build_if: 'a -> ident -> 'b -> ('c * 'b) list -> bool * 'a * 'b * 'b option
+val build_if : 'a -> ident -> 'b -> ('c * 'b) list -> bool * 'a * 'b * 'b option
+val get_machine :
+ machine_t list -> 'a * (Lustre_types.top_decl * 'b) -> machine_t
(** Extract from a machine list the one corresponding to the given instance.
assume that the machine is in the list. @param machines list of all machines
@param instance instance of a machine @return the machine corresponding to
hte given instance **)
-val get_machine: machine_t list -> 'a * (Lustre_types.top_decl * 'b) -> machine_t
+val get_substitution : machine_t -> ident -> machine_t -> (int * Types.t) list
(** Extract from a subinstance that can have polymorphic type the instantiation
of all its polymorphic type instanciation for a given machine. It searches
the step calls and extract a substitution for all polymorphic type from it.
@@ -38,4 +41,3 @@ val get_machine: machine_t list -> 'a * (Lustre_types.top_decl * 'b) -> machine_
the identifier of the instance which permits to find the step call @param
submachine the machine corresponding to the subinstance @return the
correspondance between polymorphic type id and their instantiation **)
-val get_substitution: machine_t -> ident -> machine_t -> (int * Types.t) list
diff --git a/src/backends/Ada/misc_printer.mli b/src/backends/Ada/misc_printer.mli
index 1fc5de74..6ba53a63 100644
--- a/src/backends/Ada/misc_printer.mli
+++ b/src/backends/Ada/misc_printer.mli
@@ -2,9 +2,9 @@ open Format
type printer = formatter -> unit
-val pp_str: string -> printer
+val pp_str : string -> printer
+val pp_filename : string -> formatter -> printer -> unit
(** Print a filename by lowercasing the base and appending an extension. @param
extension the extension to append to the package name @param fmt the
formatter @param pp_name the file base name printer **)
-val pp_filename: string -> formatter -> printer -> unit
diff --git a/src/backends/C/c_backend.ml b/src/backends/C/c_backend.ml
index 622d69c7..9bb5511a 100644
--- a/src/backends/C/c_backend.ml
+++ b/src/backends/C/c_backend.ml
@@ -104,13 +104,14 @@ let print_c_header basename =
let header_m =
match !spec with
| SpecNo ->
- C_backend_header.(module EmptyMod : MODIFIERS_HDR)
+ C_backend_header.((module EmptyMod : MODIFIERS_HDR))
| SpecACSL ->
- C_backend_header.(module C_backend_spec.HdrMod : MODIFIERS_HDR)
+ C_backend_header.((module C_backend_spec.HdrMod : MODIFIERS_HDR))
| SpecC ->
- assert false (* not implemented yet *)
+ assert false
+ (* not implemented yet *)
in
- let module Header = C_backend_header.Main (val header_m) in
+ let module Header = C_backend_header.Main ((val header_m)) in
let destname = !dest_dir ^ "/" ^ basename in
(* Generating H file *)
let lusic = Lusic.read_lusic destname ".lusic" in
@@ -135,7 +136,8 @@ let translate_to_c generate_c_header basename prog machines dependencies =
C_backend_main.((module EmptyMod : MODIFIERS_MAINSRC)),
C_backend_makefile.((module MakefileMod : MODIFIERS_MKF)) )
| SpecC ->
- assert false (* not implemented yet *)
+ assert false
+ (* not implemented yet *)
in
let module Header = C_backend_header.Main ((val header_m)) in
let module Source = C_backend_src.Main ((val source_m)) in
diff --git a/src/backends/C/c_backend.mli b/src/backends/C/c_backend.mli
index b358eb0e..c326a791 100644
--- a/src/backends/C/c_backend.mli
+++ b/src/backends/C/c_backend.mli
@@ -1,6 +1,7 @@
open Lustre_types
open Machine_code_types
-val translate_to_c: bool -> string -> program_t -> machine_t list -> dep_t list -> unit
+val translate_to_c :
+ bool -> string -> program_t -> machine_t list -> dep_t list -> unit
-val print_c_header: string -> unit
+val print_c_header : string -> unit
diff --git a/src/backends/C/c_backend_common.ml b/src/backends/C/c_backend_common.ml
index b6d782e8..308fa56c 100644
--- a/src/backends/C/c_backend_common.ml
+++ b/src/backends/C/c_backend_common.ml
@@ -237,8 +237,8 @@ let pp_c_basic_type_desc t_desc =
else assert false
(* Not a basic C type. Do not handle arrays or pointers *)
-let pp_basic_c_type ?(pp_c_basic_type_desc = pp_c_basic_type_desc)
- ?var_opt fmt t =
+let pp_basic_c_type ?(pp_c_basic_type_desc = pp_c_basic_type_desc) ?var_opt fmt
+ t =
match var_opt with
| Some v when Machine_types.is_exportable v ->
Machine_types.pp_c_var_type fmt v
diff --git a/src/backends/C/c_backend_common.mli b/src/backends/C/c_backend_common.mli
index bd7c9abc..a4629f06 100644
--- a/src/backends/C/c_backend_common.mli
+++ b/src/backends/C/c_backend_common.mli
@@ -3,128 +3,234 @@ open Format
open Lustre_types
open Machine_code_types
-val pp_file_decl: formatter -> ident -> int -> unit
-val pp_file_open: formatter -> ident -> int -> string
-val pp_put_var: formatter -> string -> ident -> Types.t -> ident -> unit
-val pp_ptr: formatter -> ident -> unit
-val pp_machine_set_reset_name: formatter -> ident -> unit
-val pp_machine_clear_reset_name: formatter -> ident -> unit
-val pp_machine_init_name: formatter -> ident -> unit
-val pp_machine_clear_name: formatter -> ident -> unit
-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_dealloc_name: formatter -> ident -> unit
-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_link_name: formatter -> ident -> unit
-val pp_global_init_prototype: formatter -> ident -> unit
-val pp_global_clear_prototype: formatter -> ident -> unit
-val pp_alloc_prototype: formatter -> ident * var_decl list -> unit
-val pp_dealloc_prototype: formatter -> ident -> unit
-val pp_import_prototype: formatter -> dep_t -> unit
-val pp_import_alloc_prototype: formatter -> dep_t -> unit
-val pp_c_var_read: ?test_output:bool -> machine_t -> formatter -> var_decl -> unit
-val pp_c_var_write: machine_t -> formatter -> var_decl -> unit
-val pp_c_var: machine_t -> ident -> (formatter -> var_decl -> unit) -> formatter -> var_decl -> unit
-val pp_c_dimension: formatter -> Dimension.t -> unit
-val pp_label: formatter -> label -> unit
-val pp_c_tag: formatter -> label -> unit
-val pp_reset_assign: ident -> formatter -> bool -> unit
-val pp_assign: machine_t -> ident -> (formatter -> var_decl -> unit) -> formatter -> var_decl * value_t -> unit
-val pp_c_type: ?pp_c_basic_type_desc:(Types.t -> string) -> ?var_opt:var_decl ->
- ident -> formatter -> Types.t -> unit
-val pp_basic_c_type: ?pp_c_basic_type_desc:(Types.t -> string) -> ?var_opt:var_decl -> formatter -> Types.t -> unit
-val pp_machine_memtype_name: ?ghost:bool -> formatter -> ident -> unit
-val pp_array_suffix: formatter -> ident list -> unit
-val pp_print_version: formatter -> unit -> unit
-val pp_machine_struct: ?ghost:bool -> formatter -> machine_t -> unit
-val pp_reset_flag: ?indirect:bool -> (formatter -> 'a -> unit) -> formatter -> 'a -> unit
-val pp_reset_flag': ?indirect:bool -> formatter -> ident -> unit
-val pp_machine_decl: ?ghost:bool -> (formatter -> 'a -> unit) -> formatter -> ident * 'a -> unit
-val pp_machine_decl': ?ghost:bool -> formatter -> ident * ident -> unit
-val pp_file: ident -> formatter -> ident * ident -> unit
-val pp_basic_lib_fun: bool -> ident -> (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
-val pp_c_decl_input_var: formatter -> var_decl -> unit
+val pp_file_decl : formatter -> ident -> int -> unit
+
+val pp_file_open : formatter -> ident -> int -> string
+
+val pp_put_var : formatter -> string -> ident -> Types.t -> ident -> unit
+
+val pp_ptr : formatter -> ident -> unit
+
+val pp_machine_set_reset_name : formatter -> ident -> unit
+
+val pp_machine_clear_reset_name : formatter -> ident -> unit
+
+val pp_machine_init_name : formatter -> ident -> unit
+
+val pp_machine_clear_name : formatter -> ident -> unit
+
+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_dealloc_name : formatter -> ident -> unit
+
+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_link_name : formatter -> ident -> unit
+
+val pp_global_init_prototype : formatter -> ident -> unit
+
+val pp_global_clear_prototype : formatter -> ident -> unit
+
+val pp_alloc_prototype : formatter -> ident * var_decl list -> unit
+
+val pp_dealloc_prototype : formatter -> ident -> unit
+
+val pp_import_prototype : formatter -> dep_t -> unit
+
+val pp_import_alloc_prototype : formatter -> dep_t -> unit
+
+val pp_c_var_read :
+ ?test_output:bool -> machine_t -> formatter -> var_decl -> unit
+
+val pp_c_var_write : machine_t -> formatter -> var_decl -> unit
+
+val pp_c_var :
+ machine_t ->
+ ident ->
+ (formatter -> var_decl -> unit) ->
+ formatter ->
+ var_decl ->
+ unit
+
+val pp_c_dimension : formatter -> Dimension.t -> unit
+
+val pp_label : formatter -> label -> unit
+
+val pp_c_tag : formatter -> label -> unit
+
+val pp_reset_assign : ident -> formatter -> bool -> unit
+
+val pp_assign :
+ machine_t ->
+ ident ->
+ (formatter -> var_decl -> unit) ->
+ formatter ->
+ var_decl * value_t ->
+ unit
+
+val pp_c_type :
+ ?pp_c_basic_type_desc:(Types.t -> string) ->
+ ?var_opt:var_decl ->
+ ident ->
+ formatter ->
+ Types.t ->
+ unit
+
+val pp_basic_c_type :
+ ?pp_c_basic_type_desc:(Types.t -> string) ->
+ ?var_opt:var_decl ->
+ formatter ->
+ Types.t ->
+ unit
+
+val pp_machine_memtype_name : ?ghost:bool -> formatter -> ident -> unit
+
+val pp_array_suffix : formatter -> ident list -> unit
+
+val pp_print_version : formatter -> unit -> unit
+
+val pp_machine_struct : ?ghost:bool -> formatter -> machine_t -> unit
+
+val pp_reset_flag :
+ ?indirect:bool -> (formatter -> 'a -> unit) -> formatter -> 'a -> unit
+
+val pp_reset_flag' : ?indirect:bool -> formatter -> ident -> unit
+
+val pp_machine_decl :
+ ?ghost:bool -> (formatter -> 'a -> unit) -> formatter -> ident * 'a -> unit
+
+val pp_machine_decl' : ?ghost:bool -> formatter -> ident * ident -> unit
+
+val pp_file : ident -> formatter -> ident * ident -> unit
+
+val pp_basic_lib_fun :
+ bool -> ident -> (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
+
+val pp_c_decl_input_var : formatter -> var_decl -> unit
(* Prints a value expression [v], with internal function calls only. [pp_var] is
a printer for variables (typically [pp_c_var_read]), but an offset suffix may
be added for array variables *)
-val pp_c_val: machine_t -> ident -> (formatter -> var_decl -> unit) -> formatter -> value_t -> unit
+val pp_c_val :
+ machine_t ->
+ ident ->
+ (formatter -> var_decl -> unit) ->
+ formatter ->
+ value_t ->
+ unit
- (* Prints a constant value *)
-val pp_c_const: formatter -> constant -> unit
+(* Prints a constant value *)
+val pp_c_const : formatter -> constant -> unit
(* Declaration of a local/mem variable: - if it's an array/matrix/etc, its
size(s) should be known in order to statically allocate memory, so we print
the full type *)
-val pp_c_decl_local_var: ?pp_c_basic_type_desc:(Types.t -> string) -> machine_t -> formatter -> var_decl -> unit
+val pp_c_decl_local_var :
+ ?pp_c_basic_type_desc:(Types.t -> string) ->
+ machine_t ->
+ formatter ->
+ var_decl ->
+ unit
(* type directed initialization: useless wrt the lustre compilation model,
except for MPFR injection, where values are dynamically allocated *)
-val pp_initialize: machine_t -> ident -> (formatter -> var_decl -> unit) -> formatter -> var_decl -> unit
+val pp_initialize :
+ machine_t ->
+ ident ->
+ (formatter -> var_decl -> unit) ->
+ formatter ->
+ var_decl ->
+ unit
(* type directed clear: useless wrt the lustre compilation model, except for
MPFR injection, where values are dynamically allocated *)
-val pp_clear: machine_t -> ident -> (formatter -> var_decl -> unit) -> formatter -> var_decl -> unit
+val pp_clear :
+ machine_t ->
+ ident ->
+ (formatter -> var_decl -> unit) ->
+ formatter ->
+ var_decl ->
+ unit
-val mk_call_var_decl: Location.t -> ident -> var_decl
+val mk_call_var_decl : Location.t -> ident -> var_decl
-val pp_c_basic_type_desc: Types.t -> string
+val pp_c_basic_type_desc : Types.t -> string
-val has_c_prototype: ident -> dep_t list -> bool
+val has_c_prototype : ident -> dep_t list -> bool
-val reset_label: label
+val reset_label : label
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t
-val mk_loop_var: machine_t -> unit -> ident
+val mk_loop_var : machine_t -> unit -> ident
(* Computes the list of nested loop variables together with their dimension
bounds.
* - LInt r stands for loop expansion (no loop variable, but int loop
index)
* - LVar v stands for loop variable v *)
-val mk_loop_variables: machine_t -> Types.t -> int -> (Dimension.t * loop_index) list
+val mk_loop_variables :
+ machine_t -> Types.t -> int -> (Dimension.t * loop_index) list
-val reset_loop_counter: unit -> unit
+val reset_loop_counter : unit -> unit
-val reorder_loop_variables: (Dimension.t * loop_index) list -> (Dimension.t * loop_index) list
+val reorder_loop_variables :
+ (Dimension.t * loop_index) list -> (Dimension.t * loop_index) list
- (* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
-val pp_value_suffix: ?indirect:bool -> machine_t -> ident -> Types.t ->
- (Dimension.t * loop_index) list -> (formatter -> var_decl -> unit) -> formatter -> value_t -> unit
+(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
+val pp_value_suffix :
+ ?indirect:bool ->
+ machine_t ->
+ ident ->
+ Types.t ->
+ (Dimension.t * loop_index) list ->
+ (formatter -> var_decl -> unit) ->
+ formatter ->
+ value_t ->
+ unit
(* Generation of a non-clashing name for the self memory variable (for step and
reset functions) *)
-val mk_self: machine_t -> ident
-val mk_mem: machine_t -> ident
-val mk_mem_in: machine_t -> ident
-val mk_mem_out: machine_t -> ident
-val mk_mem_reset: machine_t -> ident
+val mk_self : machine_t -> ident
+
+val mk_mem : machine_t -> ident
+
+val mk_mem_in : machine_t -> ident
+
+val mk_mem_out : machine_t -> ident
+
+val mk_mem_reset : machine_t -> ident
(* Generation of a non-clashing name for the attribute variable of static
allocation macro *)
-val mk_attribute: machine_t -> ident
+val mk_attribute : machine_t -> ident
(* Generation of a non-clashing name for the instance variable of static
allocation macro *)
-val mk_instance: machine_t -> ident
+val mk_instance : machine_t -> ident
-val mpfr_vars: var_decl list -> var_decl list
-val mpfr_consts: const_desc list -> const_desc list
+val mpfr_vars : var_decl list -> var_decl list
-val reset_flag_name: string
+val mpfr_consts : const_desc list -> const_desc list
-val file_to_module_name: string -> string
+val reset_flag_name : string
-val protect_filename: string -> string
+val file_to_module_name : string -> string
+
+val protect_filename : string -> string
(* Computes the depth to which multi-dimension array assignments should be
expanded. It equals the maximum number of nested static array constructions
accessible from root [v]. *)
-val expansion_depth: value_t -> int
+val expansion_depth : value_t -> int
module type MODIFIERS_GHOST_PROTO = sig
val pp_ghost_parameters :
@@ -136,11 +242,21 @@ end
module EmptyGhostProto : MODIFIERS_GHOST_PROTO
-module Protos (Mod : MODIFIERS_GHOST_PROTO): sig
- val print_stateless_prototype: formatter -> ident * var_decl list * var_decl list -> unit
- val print_clear_reset_prototype: ident -> ident -> formatter -> ident * var_decl list -> unit
- val print_set_reset_prototype: ident -> ident -> formatter -> ident * var_decl list -> unit
- val print_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 print_clear_prototype: ident -> formatter -> ident * var_decl list -> unit
+module Protos (Mod : MODIFIERS_GHOST_PROTO) : sig
+ val print_stateless_prototype :
+ formatter -> ident * var_decl list * var_decl list -> unit
+
+ val print_clear_reset_prototype :
+ ident -> ident -> formatter -> ident * var_decl list -> unit
+
+ val print_set_reset_prototype :
+ ident -> ident -> formatter -> ident * var_decl list -> unit
+
+ val print_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 print_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 64255452..f6e95c4a 100644
--- a/src/backends/C/c_backend_header.ml
+++ b/src/backends/C/c_backend_header.ml
@@ -15,7 +15,6 @@ open Corelang
open Machine_code_types
open Machine_code_common
open C_backend_common
-
module Mpfr = Lustrec_mpfr
(********************************************************************************************)
@@ -406,8 +405,7 @@ functor
/* 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. *)
diff --git a/src/backends/C/c_backend_header.mli b/src/backends/C/c_backend_header.mli
index fb1395fe..e23ea75f 100644
--- a/src/backends/C/c_backend_header.mli
+++ b/src/backends/C/c_backend_header.mli
@@ -5,13 +5,17 @@ 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_import_arrow: formatter -> unit -> unit
+
+ val print_machine_decl_prefix : formatter -> machine_t -> unit
+
+ val pp_import_arrow : formatter -> unit -> unit
end
module EmptyMod : MODIFIERS_HDR
module Main (Mod : MODIFIERS_HDR) : sig
- val print_header_from_header: formatter -> string -> top_decl list -> unit
- val print_alloc_header: formatter -> string -> machine_t list -> dep_t list -> unit
+ val print_header_from_header : formatter -> string -> top_decl list -> unit
+
+ val print_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 b9ad438a..8c033597 100644
--- a/src/backends/C/c_backend_main.ml
+++ b/src/backends/C/c_backend_main.ml
@@ -14,8 +14,6 @@ open Machine_code_types
open Machine_code_common
open Utils.Format
open C_backend_common
-open Utils
-
module Mpfr = Lustrec_mpfr
module type MODIFIERS_MAINSRC = sig end
diff --git a/src/backends/C/c_backend_main.mli b/src/backends/C/c_backend_main.mli
index 82313865..7369ba5f 100644
--- a/src/backends/C/c_backend_main.mli
+++ b/src/backends/C/c_backend_main.mli
@@ -4,8 +4,15 @@ open Machine_code_types
module type MODIFIERS_MAINSRC = sig end
-module EmptyMod: MODIFIERS_MAINSRC
+module EmptyMod : MODIFIERS_MAINSRC
module Main (Mod : MODIFIERS_MAINSRC) : sig
- val print_main_c: formatter -> machine_t -> string -> program_t -> machine_t list -> dep_t list -> unit
+ val print_main_c :
+ formatter ->
+ machine_t ->
+ string ->
+ program_t ->
+ machine_t list ->
+ dep_t list ->
+ unit
end
diff --git a/src/backends/C/c_backend_makefile.ml b/src/backends/C/c_backend_makefile.ml
index 1235e7b3..92c57893 100644
--- a/src/backends/C/c_backend_makefile.ml
+++ b/src/backends/C/c_backend_makefile.ml
@@ -13,12 +13,13 @@ open Utils
open Format
open Lustre_types
-let pp_dep fmt dep =
- fprintf fmt "%b, %s, {%a}, %b" dep.local dep.name Printers.pp_prog
- dep.content dep.is_stateful
-
-let pp_deps fmt deps =
- fprintf fmt "@[<v 0>%a@ @]" (pp_comma_list pp_dep) deps
+(* XXX: UNUSED *)
+(* let pp_dep fmt dep =
+ * fprintf fmt "%b, %s, {%a}, %b" dep.local dep.name Printers.pp_prog
+ * dep.content dep.is_stateful
+ *
+ * let pp_deps fmt deps =
+ * fprintf fmt "@[<v 0>%a@ @]" (pp_comma_list pp_dep) deps *)
let header_has_code header =
List.exists
diff --git a/src/backends/C/c_backend_makefile.mli b/src/backends/C/c_backend_makefile.mli
index a178afd8..9495abe4 100644
--- a/src/backends/C/c_backend_makefile.mli
+++ b/src/backends/C/c_backend_makefile.mli
@@ -9,9 +9,11 @@ end
module EmptyMod : MODIFIERS_MKF
module Main (Mod : MODIFIERS_MKF) : sig
- val print_makefile: string -> string -> dep_t list -> formatter -> unit
+ val print_makefile : string -> string -> dep_t list -> formatter -> unit
end
-val fprintf_dependencies: formatter -> dep_t list -> unit
-val compiled_dependencies: dep_t list -> dep_t list
-val lib_dependencies: dep_t list -> ident list
+val fprintf_dependencies : formatter -> dep_t list -> unit
+
+val compiled_dependencies : dep_t list -> dep_t list
+
+val lib_dependencies : dep_t list -> ident list
diff --git a/src/backends/C/c_backend_mauve.ml b/src/backends/C/c_backend_mauve.ml
index b6e4829e..0a2bea2e 100644
--- a/src/backends/C/c_backend_mauve.ml
+++ b/src/backends/C/c_backend_mauve.ml
@@ -2,7 +2,6 @@ open Lustre_types
open Machine_code_types
open Format
open C_backend_common
-open Utils
open Printers
(* module type MODIFIERS_MAINSRC = sig end
diff --git a/src/backends/C/c_backend_mauve.mli b/src/backends/C/c_backend_mauve.mli
index 7680b24f..fc04dfc8 100644
--- a/src/backends/C/c_backend_mauve.mli
+++ b/src/backends/C/c_backend_mauve.mli
@@ -1,7 +1,10 @@
open Format
open Machine_code_types
-val print_mauve_header: formatter -> string -> unit
-val print_mauve_shell: formatter -> machine_t -> unit
-val print_mauve_core: formatter -> machine_t -> unit
-val print_mauve_fsm: formatter -> machine_t -> unit
+val print_mauve_header : formatter -> string -> unit
+
+val print_mauve_shell : formatter -> machine_t -> unit
+
+val print_mauve_core : formatter -> machine_t -> unit
+
+val print_mauve_fsm : formatter -> machine_t -> unit
diff --git a/src/backends/C/c_backend_spec.ml b/src/backends/C/c_backend_spec.ml
index 9d55cbd7..525ab3e0 100644
--- a/src/backends/C/c_backend_spec.ml
+++ b/src/backends/C/c_backend_spec.ml
@@ -16,7 +16,6 @@ open C_backend_common
open Corelang
open Spec_types
open Machine_code_common
-
module Mpfr = Lustrec_mpfr
(**************************************************************************)
diff --git a/src/backends/C/c_backend_spec.mli b/src/backends/C/c_backend_spec.mli
index 8a982275..5f89b425 100644
--- a/src/backends/C/c_backend_spec.mli
+++ b/src/backends/C/c_backend_spec.mli
@@ -1,3 +1,5 @@
-module HdrMod: C_backend_header.MODIFIERS_HDR
-module SrcMod: C_backend_src.MODIFIERS_SRC
-module MakefileMod: C_backend_makefile.MODIFIERS_MKF
+module HdrMod : C_backend_header.MODIFIERS_HDR
+
+module SrcMod : C_backend_src.MODIFIERS_SRC
+
+module MakefileMod : C_backend_makefile.MODIFIERS_MKF
diff --git a/src/backends/C/c_backend_src.ml b/src/backends/C/c_backend_src.ml
index 091eb15b..121ae917 100644
--- a/src/backends/C/c_backend_src.ml
+++ b/src/backends/C/c_backend_src.ml
@@ -16,7 +16,6 @@ open Machine_code_types
open Corelang
open Machine_code_common
open C_backend_common
-
module Mpfr = Lustrec_mpfr
module type MODIFIERS_SRC = sig
@@ -53,809 +52,796 @@ module EmptyMod = struct
let pp_ghost_parameter _ _ _ = ()
end
-module Main =
-functor
- (Mod : MODIFIERS_SRC)
- ->
- struct
- module Protos = Protos (Mod.GhostProto)
-
- (********************************************************************************************)
- (* Instruction Printing functions *)
- (********************************************************************************************)
-
- let rec merge_static_loop_profiles lp1 lp2 =
- match lp1, lp2 with
- | [], _ ->
- lp2
- | _, [] ->
- lp1
- | p1 :: q1, p2 :: q2 ->
- (p1 || p2) :: merge_static_loop_profiles q1 q2
-
- (* Returns a list of bool values, indicating whether the indices must be
- static or not *)
- let rec static_loop_profile v =
- match v.value_desc with
- | Cst cst ->
- static_loop_profile_cst cst
- | Var _ | ResetFlag ->
- []
- | Fun (_, vl) ->
- List.fold_right
- (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v))
- vl []
- | Array vl ->
- true
- ::
- List.fold_right
- (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v))
- vl []
- | Access (v, _) -> (
- match static_loop_profile v with [] -> [] | _ :: q -> q)
- | Power (v, _) ->
- false :: static_loop_profile v
-
- and static_loop_profile_cst cst =
- match cst with
- | Const_array cl ->
- List.fold_right
- (fun c lp ->
- merge_static_loop_profiles lp (static_loop_profile_cst c))
- cl []
- | _ ->
- []
-
- (* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
- which may yield constant arrays in expressions. Type is needed to
- correctly print constant arrays. *)
- let pp_c_val m self pp_var fmt v =
- pp_value_suffix m self v.value_type [] pp_var fmt v
-
- let pp_machine_ pp_machine_name fn_name m fmt ?inst self mem =
- let name, is_arrow, static =
- match inst with
- | Some inst ->
- 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;
- raise Not_found
- in
- node_name node, Arrow.td_is_arrow node, static
- | None ->
- 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;"
- (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
- (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
-
- let pp_machine_clear_reset m self mem fmt =
- pp_machine_ pp_machine_clear_reset_name "pp_machine_clear_reset" m fmt
- self mem
-
- let pp_machine_init m self mem fmt inst =
- pp_machine_ pp_machine_init_name "pp_machine_init" m fmt ~inst self mem
-
- let pp_machine_clear m self mem fmt inst =
- pp_machine_ pp_machine_clear_name "pp_machine_clear" m fmt ~inst self mem
-
- let pp_call m self mem pp_read pp_write fmt i inputs outputs =
- 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)
- (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
- (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)
- (pp_comma_list ~pp_eol:pp_print_comma (pp_c_val m self pp_read))
- 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)
-
- 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
- (Mod.pp_ghost_parameter mem)
- (Some i)
- | _ ->
+module Main (Mod : MODIFIERS_SRC) = struct
+ module Protos = Protos (Mod.GhostProto)
+
+ (********************************************************************************************)
+ (* Instruction Printing functions *)
+ (********************************************************************************************)
+
+ (* XXX: UNUSED *)
+ (* let rec merge_static_loop_profiles lp1 lp2 =
+ * match lp1, lp2 with
+ * | [], _ ->
+ * lp2
+ * | _, [] ->
+ * lp1
+ * | p1 :: q1, p2 :: q2 ->
+ * (p1 || p2) :: merge_static_loop_profiles q1 q2 *)
+
+ (* XXX: UNUSED *)
+ (* Returns a list of bool values, indicating whether the indices must be
+ static or not *)
+ (* let rec static_loop_profile v =
+ * match v.value_desc with
+ * | Cst cst ->
+ * static_loop_profile_cst cst
+ * | Var _ | ResetFlag ->
+ * []
+ * | Fun (_, vl) ->
+ * List.fold_right
+ * (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v))
+ * vl []
+ * | Array vl ->
+ * true
+ * ::
+ * List.fold_right
+ * (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v))
+ * vl []
+ * | Access (v, _) -> (
+ * match static_loop_profile v with [] -> [] | _ :: q -> q)
+ * | Power (v, _) ->
+ * false :: static_loop_profile v
+ *
+ * and static_loop_profile_cst cst =
+ * match cst with
+ * | Const_array cl ->
+ * List.fold_right
+ * (fun c lp ->
+ * merge_static_loop_profiles lp (static_loop_profile_cst c))
+ * cl []
+ * | _ ->
+ * [] *)
+
+ (* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
+ which may yield constant arrays in expressions. Type is needed to correctly
+ print constant arrays. *)
+ let pp_c_val m self pp_var fmt v =
+ pp_value_suffix m self v.value_type [] pp_var fmt v
+
+ let pp_machine_ pp_machine_name fn_name m fmt ?inst self mem =
+ let name, is_arrow, static =
+ match inst with
+ | Some inst ->
+ 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;
+ raise Not_found
+ in
+ node_name node, Arrow.td_is_arrow node, static
+ | None ->
+ 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;"
+ (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
+ (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
+
+ let pp_machine_clear_reset m self mem fmt =
+ pp_machine_ pp_machine_clear_reset_name "pp_machine_clear_reset" m fmt self
+ mem
+
+ let pp_machine_init m self mem fmt inst =
+ pp_machine_ pp_machine_init_name "pp_machine_init" m fmt ~inst self mem
+
+ let pp_machine_clear m self mem fmt inst =
+ pp_machine_ pp_machine_clear_name "pp_machine_clear" m fmt ~inst self mem
+
+ let pp_call m self mem pp_read pp_write fmt i inputs outputs =
+ 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)
+ (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
+ (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)
+ (pp_comma_list ~pp_eol:pp_print_comma (pp_c_val m self pp_read))
+ 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)
+
+ 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
+ (Mod.pp_ghost_parameter mem)
+ (Some i)
+ | _ ->
+ assert false
+
+ 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
+ (pp_print_list ~pp_sep:pp_print_nothing (fun fmt -> fprintf fmt "[%s]"))
+ indices
+ in
+ let rec aux indices fmt typ =
+ if Types.is_array_type typ then
+ let dim = Types.array_type_dimension typ in
+ let idx = mk_loop_var m () in
+ fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx idx
+ idx pp_c_dimension dim idx
+ (aux (idx :: indices))
+ (Types.array_element_type typ)
+ else
+ let pp_read = pp_offset (pp_c_var_read m) indices in
+ let pp_write = pp_offset (pp_c_var_write m) indices in
+ pp_call m self mem pp_read pp_write fmt i inputs outputs
+ in
+ reset_loop_counter ();
+ aux [] fmt (List.hd inputs).Machine_code_types.value_type
+
+ 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_machine_instr dependencies m self mem)
+ in
+ let pp_cond = pp_c_val m self (pp_c_var_read m) in
+ match tl, el with
+ | [], _ :: _ ->
+ fprintf fmt "@[<v 2>if (!%a) {%a@]@,}" pp_cond c pp_machine_instrs el
+ | _, [] ->
+ 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
+
+ and pp_machine_instr dependencies m self mem fmt instr =
+ let pp_instr fmt instr =
+ match get_instr_desc instr with
+ | MNoReset _ ->
+ ()
+ | MSetReset inst ->
+ pp_machine_set_reset m self mem fmt inst
+ | MClearReset ->
+ if not (fst (get_stateless_status m)) then
+ fprintf fmt "%t@,%a"
+ (pp_machine_clear_reset m self mem)
+ pp_label reset_label
+ | MResetAssign b ->
+ pp_reset_assign self fmt b
+ | MLocalAssign (i, v) ->
+ pp_assign m self (pp_c_var_read m) fmt (i, v)
+ | MStateAssign (i, v) ->
+ pp_assign m self (pp_c_var_read m) fmt (i, v)
+ | 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
+ (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;"
+ (pp_c_val m self (pp_c_var_read m))
+ (mk_val (Var i0) i0.var_type)
+ i
+ (pp_print_parenthesized (pp_c_val m self (pp_c_var_read m)))
+ vl
+ | MStep (il, i, vl) ->
+ let td, _ = List.assoc i m.minstances in
+ 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;
assert false
-
- 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
- (pp_print_list ~pp_sep:pp_print_nothing (fun fmt ->
- fprintf fmt "[%s]"))
- indices
- in
- let rec aux indices fmt typ =
- if Types.is_array_type typ then
- let dim = Types.array_type_dimension typ in
- let idx = mk_loop_var m () in
- fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx
- idx idx pp_c_dimension dim idx
- (aux (idx :: indices))
- (Types.array_element_type typ)
+ | MBranch (g, hl) ->
+ if
+ let t = fst (List.hd hl) in
+ t = tag_true || t = tag_false
+ then
+ (* boolean case, needs special treatment in C because truth value is
+ not unique *)
+ (* may disappear if we optimize code by replacing last branch test
+ with default *)
+ let tl = try List.assoc tag_true hl with Not_found -> [] in
+ let el = try List.assoc tag_false hl with Not_found -> [] in
+ let no_noreset =
+ List.filter (fun i ->
+ match i.instr_desc with MNoReset _ -> false | _ -> true)
+ in
+ pp_conditional dependencies m self mem fmt g (no_noreset tl)
+ (no_noreset el)
else
- let pp_read = pp_offset (pp_c_var_read m) indices in
- let pp_write = pp_offset (pp_c_var_write m) indices in
- pp_call m self mem pp_read pp_write fmt i inputs outputs
- in
- reset_loop_counter ();
- aux [] fmt (List.hd inputs).Machine_code_types.value_type
-
- 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_machine_instr dependencies m self mem)
- in
- let pp_cond = pp_c_val m self (pp_c_var_read m) in
- match tl, el with
- | [], _ :: _ ->
- fprintf fmt "@[<v 2>if (!%a) {%a@]@,}" pp_cond c pp_machine_instrs el
- | _, [] ->
- 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
-
- and pp_machine_instr dependencies m self mem fmt instr =
- let pp_instr fmt instr =
- match get_instr_desc instr with
- | MNoReset _ ->
- ()
- | MSetReset inst ->
- pp_machine_set_reset m self mem fmt inst
- | MClearReset ->
- if not (fst (get_stateless_status m)) then
- fprintf fmt "%t@,%a"
- (pp_machine_clear_reset m self mem)
- pp_label reset_label
- | MResetAssign b ->
- pp_reset_assign self fmt b
- | MLocalAssign (i, v) ->
- pp_assign m self (pp_c_var_read m) fmt (i, v)
- | MStateAssign (i, v) ->
- pp_assign m self (pp_c_var_read m) fmt (i, v)
- | 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
- (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;"
+ (* 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@,}@]"
(pp_c_val m self (pp_c_var_read m))
- (mk_val (Var i0) i0.var_type)
- i
- (pp_print_parenthesized (pp_c_val m self (pp_c_var_read m)))
- vl
- | MStep (il, i, vl) ->
- let td, _ = List.assoc i m.minstances in
- 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;
- assert false
- | MBranch (g, hl) ->
- if
- let t = fst (List.hd hl) in
- t = tag_true || t = tag_false
- then
- (* boolean case, needs special treatment in C because truth value is
- not unique *)
- (* may disappear if we optimize code by replacing last branch test
- with default *)
- let tl = try List.assoc tag_true hl with Not_found -> [] in
- let el = try List.assoc tag_false hl with Not_found -> [] in
- let no_noreset =
- List.filter (fun i ->
- match i.instr_desc with MNoReset _ -> false | _ -> true)
- in
- 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@,}@]"
- (pp_c_val m self (pp_c_var_read m))
- g
- (pp_print_list ~pp_open_box:pp_open_vbox0
- (pp_machine_branch dependencies m self mem))
- hl
- | MSpec s ->
- fprintf fmt "@[/*@@ %s */@]@ " s
- | MComment s ->
- fprintf fmt "/*%s*/@ " s
- in
- 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
- (pp_machine_instr dependencies m self mem))
- h
-
- (* let pp_machine_nospec_instr dependencies m self fmt instr =
- * pp_machine_instr dependencies m self fmt instr
- *
- * let pp_machine_step_instr dependencies m self mem fmt instr =
- * fprintf fmt "%a%a"
- * (pp_machine_instr dependencies m self) instr
- * (Mod.pp_step_instr_spec m self mem) instr *)
-
- (********************************************************************************************)
- (* C file Printing functions *)
- (********************************************************************************************)
-
- let print_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)
- (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)
- (pp_print_parenthesized Dimension.pp)
- static
-
- let print_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)"
- (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)
-
- let print_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
- "_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 =
- 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
- "%a *_alloc;@,\
- _alloc = (%a *) malloc(sizeof(%a));@,\
- assert(_alloc);@,\
- %a%areturn _alloc;"
- (pp_machine_memtype_name ~ghost:false)
- m.mname.node_id
- (pp_machine_memtype_name ~ghost:false)
- 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)
- (array_mems m)
- (pp_print_list ~pp_sep:pp_print_nothing print_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)
- (array_mems m)
- (pp_print_list ~pp_sep:pp_print_nothing print_dealloc_instance)
- m.minstances
-
- (* let print_stateless_init_code fmt m self =
- * let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
- * let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
- * fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
- * (print_init_prototype self) (m.mname.node_id, m.mstatic)
- * (\* array mems *\)
- * (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
- * (Utils.pp_final_char_if_non_empty ";@," array_mems)
- * (\* memory initialization *\)
- * (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
- * (Utils.pp_newline_if_non_empty m.mmemory)
- * (\* sub-machines initialization *\)
- * (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
- * (Utils.pp_newline_if_non_empty m.minit)
- *
- * let print_stateless_clear_code fmt m self =
- * let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
- * let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
- * fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
- * (print_clear_prototype self) (m.mname.node_id, m.mstatic)
- * (\* array mems *\)
- * (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
- * (Utils.pp_final_char_if_non_empty ";@," array_mems)
- * (\* memory clear *\)
- * (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
- * (Utils.pp_newline_if_non_empty m.mmemory)
- * (\* sub-machines clear*\)
- * (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
- * (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
- (pp_c_val m self (pp_c_var_read m))
- check
-
- let pp_print_function ~pp_prototype ~prototype ?(pp_spec = pp_print_nothing)
- ?(pp_local = pp_print_nothing) ?(base_locals = [])
- ?(pp_array_mem = pp_print_nothing) ?(array_mems = [])
- ?(pp_init_mpfr_local = pp_print_nothing)
- ?(pp_clear_mpfr_local = pp_print_nothing) ?(mpfr_locals = [])
- ?(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
- (* locals *)
- (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)
- array_mems
- (* locals initialization *)
- (pp_print_list ~pp_epilogue:pp_print_cut pp_init_mpfr_local)
- (mpfr_vars mpfr_locals)
- (* check assertions *)
- (pp_print_list pp_check)
- checks
- (* instrs *)
- (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 ()
-
- let node_of_machine m =
- {
- top_decl_desc = Node m.mname;
- top_decl_loc = Location.dummy;
- top_decl_owner = "";
- top_decl_itf = false;
- }
-
- let print_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
- ~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_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)
- ~checks:m.mstep.step_checks
- ~pp_instr:(pp_machine_instr dependencies m self self)
- ~instrs:m.mstep.step_instrs fmt
- else
- (* C90 code *)
- let gen_locals, base_locals =
- List.partition
- (fun v -> Types.is_generic_type v.var_type)
- m.mstep.step_locals
- in
- let gen_calls =
- List.map
- (fun e ->
- let id, _, _ = call_of_expr e in
- mk_call_var_decl e.expr_loc id)
- m.mname.node_gencalls
- in
- pp_print_function ~pp_prototype:Protos.print_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_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)
- ~checks:m.mstep.step_checks
- ~pp_instr:(pp_machine_instr dependencies m self self)
- ~instrs:m.mstep.step_instrs fmt
-
- let print_clear_reset_code dependencies self mem fmt m =
+ g
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_machine_branch dependencies m self mem))
+ hl
+ | MSpec s ->
+ fprintf fmt "@[/*@@ %s */@]@ " s
+ | MComment s ->
+ fprintf fmt "/*%s*/@ " s
+ in
+ 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
+ (pp_machine_instr dependencies m self mem))
+ h
+
+ (* let pp_machine_nospec_instr dependencies m self fmt instr =
+ * pp_machine_instr dependencies m self fmt instr
+ *
+ * let pp_machine_step_instr dependencies m self mem fmt instr =
+ * fprintf fmt "%a%a"
+ * (pp_machine_instr dependencies m self) instr
+ * (Mod.pp_step_instr_spec m self mem) instr *)
+
+ (********************************************************************************************)
+ (* C file Printing functions *)
+ (********************************************************************************************)
+
+ let print_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)
+ (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)
+ (pp_print_parenthesized Dimension.pp)
+ static
+
+ let print_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)"
+ (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)
+
+ let print_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
+ "_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 =
+ 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
+ "%a *_alloc;@,\
+ _alloc = (%a *) malloc(sizeof(%a));@,\
+ assert(_alloc);@,\
+ %a%areturn _alloc;"
+ (pp_machine_memtype_name ~ghost:false)
+ m.mname.node_id
+ (pp_machine_memtype_name ~ghost:false)
+ 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)
+ (array_mems m)
+ (pp_print_list ~pp_sep:pp_print_nothing print_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)
+ (array_mems m)
+ (pp_print_list ~pp_sep:pp_print_nothing print_dealloc_instance)
+ m.minstances
+
+ (* let print_stateless_init_code fmt m self =
+ * let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
+ * let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
+ * fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
+ * (print_init_prototype self) (m.mname.node_id, m.mstatic)
+ * (\* array mems *\)
+ * (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
+ * (Utils.pp_final_char_if_non_empty ";@," array_mems)
+ * (\* memory initialization *\)
+ * (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
+ * (Utils.pp_newline_if_non_empty m.mmemory)
+ * (\* sub-machines initialization *\)
+ * (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
+ * (Utils.pp_newline_if_non_empty m.minit)
+ *
+ * let print_stateless_clear_code fmt m self =
+ * let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
+ * let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
+ * fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
+ * (print_clear_prototype self) (m.mname.node_id, m.mstatic)
+ * (\* array mems *\)
+ * (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
+ * (Utils.pp_final_char_if_non_empty ";@," array_mems)
+ * (\* memory clear *\)
+ * (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
+ * (Utils.pp_newline_if_non_empty m.mmemory)
+ * (\* sub-machines clear*\)
+ * (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
+ * (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
+ (pp_c_val m self (pp_c_var_read m))
+ check
+
+ let pp_print_function ~pp_prototype ~prototype ?(pp_spec = pp_print_nothing)
+ ?(pp_local = pp_print_nothing) ?(base_locals = [])
+ ?(pp_array_mem = pp_print_nothing) ?(array_mems = [])
+ ?(pp_init_mpfr_local = pp_print_nothing)
+ ?(pp_clear_mpfr_local = pp_print_nothing) ?(mpfr_locals = [])
+ ?(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
+ (* locals *)
+ (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)
+ array_mems
+ (* locals initialization *)
+ (pp_print_list ~pp_epilogue:pp_print_cut pp_init_mpfr_local)
+ (mpfr_vars mpfr_locals)
+ (* check assertions *)
+ (pp_print_list pp_check)
+ checks
+ (* instrs *)
+ (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 ()
+
+ let node_of_machine m =
+ {
+ top_decl_desc = Node m.mname;
+ top_decl_loc = Location.dummy;
+ top_decl_owner = "";
+ top_decl_itf = false;
+ }
+
+ let print_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_clear_reset_spec fmt self mem m)
- ~pp_prototype:(Protos.print_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_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:
- [
- mk_branch
- (mk_val ResetFlag Type_predef.type_bool)
- [ "true", mkinstr (MResetAssign false) :: m.minit ];
- ]
- fmt
-
- let print_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)
- ~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 minit =
+ ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self self m)
+ ~pp_prototype:Protos.print_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_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)
+ ~checks:m.mstep.step_checks
+ ~pp_instr:(pp_machine_instr dependencies m self self)
+ ~instrs:m.mstep.step_instrs fmt
+ else
+ (* C90 code *)
+ let gen_locals, base_locals =
+ List.partition
+ (fun v -> Types.is_generic_type v.var_type)
+ m.mstep.step_locals
+ in
+ let gen_calls =
List.map
- (fun i ->
- match get_instr_desc i with MSetReset i -> i | _ -> assert false)
- m.minit
+ (fun e ->
+ let id, _, _ = call_of_expr e in
+ mk_call_var_decl e.expr_loc id)
+ m.mname.node_gencalls
in
+ pp_print_function ~pp_prototype:Protos.print_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_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)
+ ~checks:m.mstep.step_checks
+ ~pp_instr:(pp_machine_instr dependencies m self self)
+ ~instrs:m.mstep.step_instrs fmt
+
+ let print_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)
+ ~prototype:(m.mname.node_id, m.mstatic)
+ ~pp_local:(pp_c_decl_local_var m) ~base_locals:(const_locals m)
+ ~pp_instr:(pp_machine_instr dependencies m self mem)
+ ~instrs:
+ [
+ mk_branch
+ (mk_val ResetFlag Type_predef.type_bool)
+ [ "true", mkinstr (MResetAssign false) :: m.minit ];
+ ]
+ fmt
+
+ let print_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)
+ ~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 minit =
+ List.map
+ (fun i ->
+ match get_instr_desc i with MSetReset i -> i | _ -> assert false)
+ m.minit
+ in
+ pp_print_function
+ ~pp_prototype:(Protos.print_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_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_machine_init m self self)
+ fmt minit)
+ fmt
+
+ let print_clear_code self fmt m =
+ let minit =
+ List.map
+ (fun i ->
+ match get_instr_desc i with MSetReset i -> i | _ -> assert false)
+ m.minit
+ in
+ pp_print_function
+ ~pp_prototype:(Protos.print_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_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_machine_clear m self self)
+ fmt minit)
+ fmt
+
+ let print_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_prototype:(Protos.print_init_prototype self)
- ~prototype:(m.mname.node_id, m.mstatic)
+ ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
+ ~pp_prototype:(Protos.print_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_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_machine_init m self self)
- fmt minit)
- fmt
-
- let print_clear_code self fmt m =
- let minit =
+ ~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)
+ ~checks:m.mstep.step_checks
+ ~pp_instr:(pp_machine_instr dependencies m self mem)
+ ~instrs:m.mstep.step_instrs fmt
+ else
+ (* C90 code *)
+ let gen_locals, base_locals =
+ List.partition
+ (fun v -> Types.is_generic_type v.var_type)
+ m.mstep.step_locals
+ in
+ let gen_calls =
List.map
- (fun i ->
- match get_instr_desc i with MSetReset i -> i | _ -> assert false)
- m.minit
+ (fun e ->
+ let id, _, _ = call_of_expr e in
+ mk_call_var_decl e.expr_loc id)
+ m.mname.node_gencalls
in
pp_print_function
- ~pp_prototype:(Protos.print_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_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
+ ~pp_prototype:(Protos.print_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_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.mmemory
- ~pp_extra:(fun fmt () ->
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
- (pp_machine_clear m self self)
- fmt minit)
- fmt
-
- let print_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)
- ~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_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)
- ~checks:m.mstep.step_checks
- ~pp_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:m.mstep.step_instrs fmt
+ ~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
+
+ (********************************************************************************************)
+ (* MAIN C file Printing functions *)
+ (********************************************************************************************)
+
+ let pp_const_initialize m pp_var fmt const =
+ let var =
+ Machine_code_common.mk_val
+ (Var (Corelang.var_decl_of_const const))
+ const.const_type
+ in
+ let rec aux indices value fmt typ =
+ if Types.is_array_type typ then
+ let dim = Types.array_type_dimension typ in
+ let szl = Utils.enumerate (Dimension.size_const dim) in
+ let typ' = Types.array_element_type typ in
+ let value =
+ match value with Const_array ca -> List.nth ca | _ -> assert false
+ in
+ pp_print_list
+ (fun fmt i -> aux (string_of_int i :: indices) (value i) fmt typ')
+ fmt szl
else
- (* C90 code *)
- let gen_locals, base_locals =
- List.partition
- (fun v -> Types.is_generic_type v.var_type)
- m.mstep.step_locals
+ 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
- let gen_calls =
- List.map
- (fun e ->
- let id, _, _ = call_of_expr e in
- mk_call_var_decl e.expr_loc id)
- m.mname.node_gencalls
+ fprintf fmt "%a@,%a"
+ (Mpfr.pp_inject_init pp_var_suffix)
+ var
+ (Mpfr.pp_inject_real pp_var_suffix pp_c_const)
+ (var, value)
+ in
+ reset_loop_counter ();
+ aux [] const.const_value fmt const.const_type
+
+ let pp_const_clear pp_var fmt const =
+ let m = Machine_code_common.empty_machine in
+ let var = Corelang.var_decl_of_const const in
+ let rec aux indices fmt typ =
+ if Types.is_array_type typ then
+ let dim = Types.array_type_dimension typ in
+ let idx = mk_loop_var m () in
+ fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx idx
+ idx pp_c_dimension dim idx
+ (aux (idx :: indices))
+ (Types.array_element_type typ)
+ else
+ let indices = List.rev indices in
+ let pp_var_suffix fmt var =
+ fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices
in
- pp_print_function
- ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
- ~pp_prototype:(Protos.print_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_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)
- ~checks:m.mstep.step_checks
- ~pp_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:m.mstep.step_instrs fmt
-
- (********************************************************************************************)
- (* MAIN C file Printing functions *)
- (********************************************************************************************)
-
- let pp_const_initialize m pp_var fmt const =
- let var =
- Machine_code_common.mk_val
- (Var (Corelang.var_decl_of_const const))
- const.const_type
- in
- let rec aux indices value fmt typ =
- if Types.is_array_type typ then
- let dim = Types.array_type_dimension typ in
- let szl = Utils.enumerate (Dimension.size_const dim) in
- let typ' = Types.array_element_type typ in
- let value =
- match value with Const_array ca -> List.nth ca | _ -> assert false
- in
- pp_print_list
- (fun fmt i -> aux (string_of_int i :: indices) (value i) fmt typ')
- 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"
- (Mpfr.pp_inject_init pp_var_suffix)
- var
- (Mpfr.pp_inject_real pp_var_suffix pp_c_const)
- (var, value)
- in
- reset_loop_counter ();
- aux [] const.const_value fmt const.const_type
-
- let pp_const_clear pp_var fmt const =
- let m = Machine_code_common.empty_machine in
- let var = Corelang.var_decl_of_const const in
- let rec aux indices fmt typ =
- if Types.is_array_type typ then
- let dim = Types.array_type_dimension typ in
- let idx = mk_loop_var m () in
- fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx
- idx idx pp_c_dimension dim idx
- (aux (idx :: indices))
- (Types.array_element_type typ)
- else
- let indices = List.rev indices in
- let pp_var_suffix fmt var =
- fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix
- indices
- in
- Mpfr.pp_inject_clear pp_var_suffix fmt var
- in
- reset_loop_counter ();
- aux [] fmt var.var_type
-
- let print_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 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 baseNAME = file_to_module_name basename in
- let constants = List.map const_of_top (get_consts prog) in
- fprintf fmt
- "@[<v 2>%a {@,\
- static %s init = 0;@,\
- @[<v 2>if (!init) { @,\
- init = 1;%a%a@]@,\
- }@,\
- return;@]@,\
- }"
- pp_global_init_prototype baseNAME
- (pp_c_basic_type_desc Type_predef.type_bool)
- (* constants *)
- (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)
- (List.filter (fun dep -> dep.local) dependencies)
-
- let print_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
- "@[<v 2>%a {@,\
- static %s clear = 0;@,\
- @[<v 2>if (!clear) { @,\
- clear = 1;%a%a@]@,\
- }@,\
- return;@]@,\
- }"
- pp_global_clear_prototype baseNAME
- (pp_c_basic_type_desc Type_predef.type_bool)
- (* constants *)
- (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)
- (List.filter (fun dep -> dep.local) dependencies)
-
- let print_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@]@,@,"
- 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
-
- let print_mpfr_code self fmt m =
- if !Options.mpfr then
- fprintf fmt "@,@[<v>%a@,%a@]"
- (* Init function *)
- (print_init_code self)
- m
- (* Clear function *)
- (print_clear_code self)
- m
-
- (* TODO: ACSL - a contract machine shall not be directly printed in the C
- source - but a regular machine associated to a contract machine shall
- 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 =
- if fst (get_stateless_status m) then
+ Mpfr.pp_inject_clear pp_var_suffix fmt var
+ in
+ reset_loop_counter ();
+ aux [] fmt var.var_type
+
+ let print_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 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 baseNAME = file_to_module_name basename in
+ let constants = List.map const_of_top (get_consts prog) in
+ fprintf fmt
+ "@[<v 2>%a {@,\
+ static %s init = 0;@,\
+ @[<v 2>if (!init) { @,\
+ init = 1;%a%a@]@,\
+ }@,\
+ return;@]@,\
+ }"
+ pp_global_init_prototype baseNAME
+ (pp_c_basic_type_desc Type_predef.type_bool)
+ (* constants *)
+ (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)
+ (List.filter (fun dep -> dep.local) dependencies)
+
+ let print_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
+ "@[<v 2>%a {@,\
+ static %s clear = 0;@,\
+ @[<v 2>if (!clear) { @,\
+ clear = 1;%a%a@]@,\
+ }@,\
+ return;@]@,\
+ }"
+ pp_global_clear_prototype baseNAME
+ (pp_c_basic_type_desc Type_predef.type_bool)
+ (* constants *)
+ (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)
+ (List.filter (fun dep -> dep.local) dependencies)
+
+ let print_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@]@,@,"
+ 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
+
+ let print_mpfr_code self fmt m =
+ if !Options.mpfr then
+ fprintf fmt "@,@[<v>%a@,%a@]"
+ (* Init function *)
+ (print_init_code self)
+ m
+ (* Clear function *)
+ (print_clear_code self)
+ m
+
+ (* TODO: ACSL - a contract machine shall not be directly printed in the C
+ source - but a regular machine associated to a contract machine shall
+ 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 =
+ if fst (get_stateless_status m) then
+ (* Step function *)
+ print_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
+ (* Reset functions *)
+ (print_clear_reset_code dependencies self mem)
+ m
+ (print_set_reset_code dependencies self mem)
+ m
(* Step function *)
- print_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
- (* Reset functions *)
- (print_clear_reset_code dependencies self mem)
- m
- (print_set_reset_code dependencies self mem)
- m
- (* Step function *)
- (print_step_code machines dependencies self mem)
- m (print_mpfr_code self) m
-
- let print_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)
- ()
- (if not !Options.static_mem then pp_print_endcut "#include <stdlib.h>"
- else pp_print_nothing)
- ()
- (if !Options.mpfr then pp_print_endcut "#include <mpfr.h>"
- else pp_print_nothing)
- ()
-
- let print_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
- {
- 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 dependencies *)
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Import dependencies */")
- pp_import_prototype ~pp_epilogue:pp_print_cutcut)
- dependencies
- (* Print consts *)
- (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)
- (get_consts prog)
- (* MPFR *)
- (if !Options.mpfr then fun fmt () ->
- fprintf fmt
- "@[<v>/* Global constants initialization */@,\
- %a@,\
- @,\
- /* Global constants clearing */@,\
- %a@]@,\
- @,"
- print_global_init_code
- (basename, prog, dependencies)
- print_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
- ~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
- (List.filter_map
- (fun decl ->
- match decl.top_decl_desc with
- | ImportedNode ind when not ind.nodei_stateless ->
- Some ind
- | _ ->
- None)
- dep.content)))
- dependencies
- (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
- (m.mname.node_id, m.mstatic)
- 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_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
- (* 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))
- machines
- end
+ (print_step_code machines dependencies self mem)
+ m (print_mpfr_code self) m
+
+ let print_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)
+ ()
+ (if not !Options.static_mem then pp_print_endcut "#include <stdlib.h>"
+ else pp_print_nothing)
+ ()
+ (if !Options.mpfr then pp_print_endcut "#include <mpfr.h>"
+ else pp_print_nothing)
+ ()
+
+ let print_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
+ {
+ 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 dependencies *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Import dependencies */")
+ pp_import_prototype ~pp_epilogue:pp_print_cutcut)
+ dependencies
+ (* Print consts *)
+ (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)
+ (get_consts prog)
+ (* MPFR *)
+ (if !Options.mpfr then fun fmt () ->
+ fprintf fmt
+ "@[<v>/* Global constants initialization */@,\
+ %a@,\
+ @,\
+ /* Global constants clearing */@,\
+ %a@]@,\
+ @,"
+ print_global_init_code
+ (basename, prog, dependencies)
+ print_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
+ ~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
+ (List.filter_map
+ (fun decl ->
+ match decl.top_decl_desc with
+ | ImportedNode ind when not ind.nodei_stateless ->
+ Some ind
+ | _ ->
+ None)
+ dep.content)))
+ dependencies
+ (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
+ (m.mname.node_id, m.mstatic)
+ 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_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
+ (* 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))
+ machines
+end
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
diff --git a/src/backends/C/c_backend_src.mli b/src/backends/C/c_backend_src.mli
index 93cfc84c..f08f3b53 100644
--- a/src/backends/C/c_backend_src.mli
+++ b/src/backends/C/c_backend_src.mli
@@ -25,5 +25,6 @@ end
module EmptyMod : MODIFIERS_SRC
module Main (Mod : MODIFIERS_SRC) : sig
- val print_lib_c: formatter -> string -> program_t -> machine_t list -> dep_t list -> unit
+ val print_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 64513a81..9d3a47e2 100644
--- a/src/backends/EMF/EMF_backend.ml
+++ b/src/backends/EMF/EMF_backend.ml
@@ -106,10 +106,11 @@ open Machine_code_common
open Format
open EMF_common
-exception Unhandled of string
-
module ISet = Utils.ISet
+(* XXX: UNUSED *)
+(* exception Unhandled of string *)
+
(**********************************************)
(* Utility functions: arrow and lustre expr *)
(**********************************************)
@@ -259,24 +260,25 @@ and branch_instr_vars m i =
| MSpec _ | MComment _ -> assert false
(* not available for EMF output *)
+(* XXX: UNUSED *)
(* A kind of super join_guards: all MBranch are postponed and sorted by
guards so they can be easier merged *)
-let merge_branches instrs =
- let instrs, branches =
- List.fold_right
- (fun i (il, branches) ->
- match Corelang.get_instr_desc i with
- | MBranch _ -> il, i :: branches
- | _ -> i :: il, branches)
- instrs ([], [])
- in
- let sorting_branches b1 b2 =
- match Corelang.get_instr_desc b1, Corelang.get_instr_desc b2 with
- | MBranch (g1, _), MBranch (g2, _) -> compare g1 g2
- | _ -> assert false
- in
- let sorted_branches = List.sort sorting_branches branches in
- instrs @ join_guards_list sorted_branches
+(* let merge_branches instrs =
+ * let instrs, branches =
+ * List.fold_right
+ * (fun i (il, branches) ->
+ * match Corelang.get_instr_desc i with
+ * | MBranch _ -> il, i :: branches
+ * | _ -> i :: il, branches)
+ * instrs ([], [])
+ * in
+ * let sorting_branches b1 b2 =
+ * match Corelang.get_instr_desc b1, Corelang.get_instr_desc b2 with
+ * | MBranch (g1, _), MBranch (g2, _) -> compare g1 g2
+ * | _ -> assert false
+ * in
+ * let sorted_branches = List.sort sorting_branches branches in
+ * instrs @ join_guards_list sorted_branches *)
let rec pp_emf_instr m fmt i =
let pp_content fmt i =
@@ -418,14 +420,15 @@ let pp_emf_spec_mode fmt m =
let pp_emf_spec_modes = pp_emf_list pp_emf_spec_mode
-let pp_emf_spec_import fmt i =
- fprintf fmt "{@[";
- fprintf fmt "\"contract\": \"%s\",@ " i.import_nodeid;
- fprintf fmt "\"inputs\": [%a],@ " pp_emf_expr i.inputs;
- fprintf fmt "\"outputs\": [%a],@ " pp_emf_expr i.outputs;
- fprintf fmt "@]}"
-
-let pp_emf_spec_imports = pp_emf_list pp_emf_spec_import
+(* XXX: UNUSED *)
+(* let pp_emf_spec_import fmt i =
+ * fprintf fmt "{@[";
+ * fprintf fmt "\"contract\": \"%s\",@ " i.import_nodeid;
+ * fprintf fmt "\"inputs\": [%a],@ " pp_emf_expr i.inputs;
+ * fprintf fmt "\"outputs\": [%a],@ " pp_emf_expr i.outputs;
+ * fprintf fmt "@]}"
+ *
+ * let pp_emf_spec_imports = pp_emf_list pp_emf_spec_import *)
let pp_emf_spec fmt spec =
fprintf fmt "{ @[<hov 0>";
@@ -461,37 +464,38 @@ let pp_machine fmt m =
(*merge_branches*)
m.mstep.step_instrs
in
- try
- fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt ->
- pp_print_string fmt m.mname.node_id);
- (match m.mspec.mnode_spec with
- | Some (Contract _) -> fprintf fmt "\"contract\": \"true\",@ "
- | _ -> ());
- fprintf fmt "\"imported\": \"false\",@ ";
- fprintf fmt "\"kind\": %t,@ " (fun fmt ->
- if not (snd (get_stateless_status m)) then fprintf fmt "\"stateful\""
- else fprintf fmt "\"stateless\"");
- fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl m.mstep.step_inputs;
- fprintf fmt "\"outputs\": [%a],@ " pp_emf_vars_decl m.mstep.step_outputs;
- fprintf fmt "\"locals\": [%a],@ " pp_emf_vars_decl m.mstep.step_locals;
- fprintf fmt "\"mems\": [%a],@ " pp_emf_vars_decl m.mmemory;
- fprintf fmt "\"original_name\": \"%s\",@ " m.mname.node_id;
- fprintf fmt "\"instrs\": {@[<v 0> %a@]@ },@ " (pp_emf_instrs m) instrs;
- (match m.mspec.mnode_spec with
- | None -> ()
- | Some (Contract c) ->
- assert (c.locals = [] && c.consts = [] && c.stmts = [] && c.imports = []);
- fprintf fmt "\"spec\": %a,@ " pp_emf_spec c
- | Some (NodeSpec id) -> fprintf fmt "\"contract\": \"%s\",@ " id);
- fprintf fmt "\"annots\": {@[<v 0> %a@]@ }"
- (pp_emf_annots_list (ref 0))
- m.mannot;
- fprintf fmt "@]@ }"
- with Unhandled msg ->
- eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "
- m.mname.node_id;
- eprintf "%s@ " msg;
- eprintf "node skipped - no output generated@ @]@."
+ (* try *)
+ fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt ->
+ pp_print_string fmt m.mname.node_id);
+ (match m.mspec.mnode_spec with
+ | Some (Contract _) -> fprintf fmt "\"contract\": \"true\",@ "
+ | _ -> ());
+ fprintf fmt "\"imported\": \"false\",@ ";
+ fprintf fmt "\"kind\": %t,@ " (fun fmt ->
+ if not (snd (get_stateless_status m)) then fprintf fmt "\"stateful\""
+ else fprintf fmt "\"stateless\"");
+ fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl m.mstep.step_inputs;
+ fprintf fmt "\"outputs\": [%a],@ " pp_emf_vars_decl m.mstep.step_outputs;
+ fprintf fmt "\"locals\": [%a],@ " pp_emf_vars_decl m.mstep.step_locals;
+ fprintf fmt "\"mems\": [%a],@ " pp_emf_vars_decl m.mmemory;
+ fprintf fmt "\"original_name\": \"%s\",@ " m.mname.node_id;
+ fprintf fmt "\"instrs\": {@[<v 0> %a@]@ },@ " (pp_emf_instrs m) instrs;
+ (match m.mspec.mnode_spec with
+ | None -> ()
+ | Some (Contract c) ->
+ assert (c.locals = [] && c.consts = [] && c.stmts = [] && c.imports = []);
+ fprintf fmt "\"spec\": %a,@ " pp_emf_spec c
+ | Some (NodeSpec id) -> fprintf fmt "\"contract\": \"%s\",@ " id);
+ fprintf fmt "\"annots\": {@[<v 0> %a@]@ }"
+ (pp_emf_annots_list (ref 0))
+ m.mannot;
+ fprintf fmt "@]@ }"
+(* XXX: UNUSED *)
+(* with Unhandled msg ->
+ * eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "
+ * m.mname.node_id;
+ * eprintf "%s@ " msg;
+ * eprintf "node skipped - no output generated@ @]@." *)
(*let pp_machine fmt m =
match m.mspec with
@@ -501,23 +505,24 @@ 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 ->
- pp_print_string fmt ind.nodei_id);
- fprintf fmt "\"imported\": \"true\",@ ";
- fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl ind.nodei_inputs;
- fprintf fmt "\"outputs\": [%a],@ " pp_emf_vars_decl ind.nodei_outputs;
- fprintf fmt "\"original_name\": \"%s\"" ind.nodei_id;
- (match ind.nodei_spec with
- | None -> fprintf fmt "@ "
- | Some (Contract _) -> assert false (* should have been processed *)
- | Some (NodeSpec id) -> fprintf fmt ",@ \"coco_contract\": %s" id);
- fprintf fmt "@]@ }"
- with Unhandled msg ->
- eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "
- ind.nodei_id;
- eprintf "%s@ " msg;
- eprintf "node skipped - no output generated@ @]@."
+ (* try *)
+ fprintf fmt "@[<v 2>\"%a\": {@ " print_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;
+ fprintf fmt "\"outputs\": [%a],@ " pp_emf_vars_decl ind.nodei_outputs;
+ fprintf fmt "\"original_name\": \"%s\"" ind.nodei_id;
+ (match ind.nodei_spec with
+ | None -> fprintf fmt "@ "
+ | Some (Contract _) -> assert false (* should have been processed *)
+ | Some (NodeSpec id) -> fprintf fmt ",@ \"coco_contract\": %s" id);
+ fprintf fmt "@]@ }"
+(* XXX: UNUSED *)
+(* with Unhandled msg ->
+ * eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "
+ * ind.nodei_id;
+ * eprintf "%s@ " msg;
+ * eprintf "node skipped - no output generated@ @]@." *)
(****************************************************)
(* Main function: iterates over node and print them *)
diff --git a/src/backends/EMF/EMF_backend.mli b/src/backends/EMF/EMF_backend.mli
index f1c2927b..3141f75f 100644
--- a/src/backends/EMF/EMF_backend.mli
+++ b/src/backends/EMF/EMF_backend.mli
@@ -1 +1,6 @@
-val translate: Format.formatter -> string -> Lustre_types.program_t -> Machine_code_types.machine_t list -> unit
+val translate :
+ Format.formatter ->
+ string ->
+ Lustre_types.program_t ->
+ Machine_code_types.machine_t list ->
+ unit
diff --git a/src/backends/EMF/EMF_common.ml b/src/backends/EMF/EMF_common.ml
index 33ce3c76..c313cf0b 100644
--- a/src/backends/EMF/EMF_common.ml
+++ b/src/backends/EMF/EMF_common.ml
@@ -329,8 +329,7 @@ let rec pp_emf_cst_or_var m fmt v =
(* TODO: handle reset flag *)
assert false
-and pp_emf_cst_or_var_list m =
- pp_comma_list (pp_emf_cst_or_var m)
+and pp_emf_cst_or_var_list m = pp_comma_list (pp_emf_cst_or_var m)
(* Printer lustre expr and eexpr *)
@@ -348,9 +347,7 @@ let rec pp_emf_expr fmt e =
e.expr_type);
fprintf fmt "@]}"
| Expr_tuple el ->
- fprintf fmt "[@[<hov 0>%a@ @]]"
- (pp_comma_list pp_emf_expr)
- el
+ fprintf fmt "[@[<hov 0>%a@ @]]" (pp_comma_list pp_emf_expr) el
(* Missing these | Expr_ite of expr * expr * expr | Expr_arrow of expr * expr
| Expr_fby of expr * expr | Expr_array of expr list | Expr_access of expr *
Dimension.dim_expr | Expr_power of expr * Dimension.dim_expr | Expr_pre of
@@ -375,16 +372,18 @@ let rec pp_emf_expr fmt e =
(* | Expr_merge of ident * (label * expr) list *)
(* | Expr_appl of call_t *)
-let pp_emf_exprs = pp_emf_list pp_emf_expr
-
-let pp_emf_const fmt v =
- fprintf fmt
- "@[<hov 0>{\"name\": \"%a\",@ \"datatype\":%a,@ \"original_name\": \
- \"%a\",@ \"value\": %a}@]"
- pp_var_name v pp_var_type v Printers.pp_var_name v pp_emf_expr
- (match v.var_dec_value with None -> assert false | Some e -> e)
+(* XXX: UNUSED *)
+(* let pp_emf_exprs = pp_emf_list pp_emf_expr *)
-let pp_emf_consts = pp_emf_list pp_emf_const
+(* XXX: UNUSED *)
+(* let pp_emf_const fmt v =
+ * fprintf fmt
+ * "@[<hov 0>{\"name\": \"%a\",@ \"datatype\":%a,@ \"original_name\": \
+ * \"%a\",@ \"value\": %a}@]"
+ * pp_var_name v pp_var_type v Printers.pp_var_name v pp_emf_expr
+ * (match v.var_dec_value with None -> assert false | Some e -> 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@]@] }"
@@ -405,21 +404,22 @@ let pp_emf_eexprs = pp_emf_list pp_emf_eexpr
spec peut etre associer a chaque imported node une minimachine et rajouter un
champ a spec dans machine code pour stoquer memoire et instr *)
-let pp_emf_stmt fmt stmt =
- match stmt with
- | Aut _ ->
- assert false
- | Eq eq ->
- fprintf fmt "@[ @[<v 2>\"%a\": {@ "
- (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "_") pp_print_string)
- eq.eq_lhs;
- fprintf fmt "\"lhs\": [%a],@ "
- (pp_comma_list (fun fmt vid -> fprintf fmt "\"%s\"" vid))
- eq.eq_lhs;
- fprintf fmt "\"rhs\": %a,@ " pp_emf_expr eq.eq_rhs;
- fprintf fmt "@]@]@ }"
-
-let pp_emf_stmts = pp_emf_list pp_emf_stmt
+(* XXX: UNUSED *)
+(* let pp_emf_stmt fmt stmt =
+ * match stmt with
+ * | Aut _ ->
+ * assert false
+ * | Eq eq ->
+ * fprintf fmt "@[ @[<v 2>\"%a\": {@ "
+ * (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "_") pp_print_string)
+ * eq.eq_lhs;
+ * fprintf fmt "\"lhs\": [%a],@ "
+ * (pp_comma_list (fun fmt vid -> fprintf fmt "\"%s\"" vid))
+ * eq.eq_lhs;
+ * fprintf fmt "\"rhs\": %a,@ " pp_emf_expr eq.eq_rhs;
+ * fprintf fmt "@]@]@ }"
+ *
+ * let pp_emf_stmts = pp_emf_list pp_emf_stmt *)
(* Printing the type declaration, not its use *)
let rec pp_emf_typ_dec fmt tydef_dec =
@@ -439,7 +439,8 @@ let rec pp_emf_typ_dec fmt tydef_dec =
fprintf fmt "\"kind\": \"alias\",@ \"value\": \"%s\"" c
| Tydec_enum el ->
fprintf fmt "\"kind\": \"enum\",@ \"elements\": [%a]"
- (pp_comma_list (fun fmt e -> fprintf fmt "\"%s\"" e)) el
+ (pp_comma_list (fun fmt e -> fprintf fmt "\"%s\"" e))
+ el
| Tydec_struct s ->
fprintf fmt "\"kind\": \"struct\",@ \"fields\": [%a]"
(pp_comma_list (fun fmt (id, typ) ->
diff --git a/src/backends/EMF/EMF_common.mli b/src/backends/EMF/EMF_common.mli
index 15779482..e1d7b4e6 100644
--- a/src/backends/EMF/EMF_common.mli
+++ b/src/backends/EMF/EMF_common.mli
@@ -3,22 +3,39 @@ open Lustre_types
open Machine_code_types
open Format
-val pp_emf_cst_or_var_list: machine_t -> formatter -> value_t list -> unit
-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_var_string: formatter -> ident -> unit
-val pp_emf_vars_decl: formatter -> var_decl list -> unit
-val pp_tag_id: formatter -> ident -> unit
-val pp_emf_expr: formatter -> expr -> unit
-val pp_emf_eexpr: formatter -> eexpr -> unit
-val pp_emf_eexprs: formatter -> eexpr list -> unit
-val pp_emf_list: ?eol:(unit, formatter, unit) Stdlib.format -> (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
-val pp_emf_typedef: formatter -> Lustre_types.top_decl -> unit
-val pp_emf_top_const: formatter -> Lustre_types.top_decl -> unit
-
-val reset_name: ident -> ident
-
-val get_expr_vars: value_t -> Corelang.VSet.t
-
-val is_imported_node: ident -> machine_t -> bool
+val pp_emf_cst_or_var_list : machine_t -> formatter -> value_t list -> unit
+
+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_var_string : formatter -> ident -> unit
+
+val pp_emf_vars_decl : formatter -> var_decl list -> unit
+
+val pp_tag_id : formatter -> ident -> unit
+
+val pp_emf_expr : formatter -> expr -> unit
+
+val pp_emf_eexpr : formatter -> eexpr -> unit
+
+val pp_emf_eexprs : formatter -> eexpr list -> unit
+
+val pp_emf_list :
+ ?eol:(unit, formatter, unit) Stdlib.format ->
+ (formatter -> 'a -> unit) ->
+ formatter ->
+ 'a list ->
+ unit
+
+val pp_emf_typedef : formatter -> Lustre_types.top_decl -> unit
+
+val pp_emf_top_const : formatter -> Lustre_types.top_decl -> unit
+
+val reset_name : ident -> ident
+
+val get_expr_vars : value_t -> Corelang.VSet.t
+
+val is_imported_node : ident -> machine_t -> bool
diff --git a/src/backends/EMF/EMF_library_calls.ml b/src/backends/EMF/EMF_library_calls.ml
index 4e765698..ab77f057 100644
--- a/src/backends/EMF/EMF_library_calls.ml
+++ b/src/backends/EMF/EMF_library_calls.ml
@@ -19,7 +19,8 @@ let pp_call fmt m f outputs inputs =
"\"kind\": \"functioncall\",@ \"name\": \"%s\",@ \"library\": \"%s\",@ "
name lib;
fprintf fmt "\"lhs\": [@[%a@]],@ \"args\": [@[%a@]]"
- (pp_comma_list (fun fmt v -> fprintf fmt "\"%a\"" Printers.pp_var_name v))
+ (pp_comma_list (fun fmt v ->
+ fprintf fmt "\"%a\"" Printers.pp_var_name v))
outputs (pp_emf_cst_or_var_list m) inputs
| _ ->
Format.eprintf "Calls to function %s in library %s are not handled yet.@."
diff --git a/src/backends/EMF/EMF_library_calls.mli b/src/backends/EMF/EMF_library_calls.mli
index f5d0b3c4..b6381222 100644
--- a/src/backends/EMF/EMF_library_calls.mli
+++ b/src/backends/EMF/EMF_library_calls.mli
@@ -1,2 +1,7 @@
-val pp_call: Format.formatter -> Machine_code_types.machine_t -> Utils.ident ->
- Lustre_types.var_decl list -> Machine_code_types.value_t list -> unit
+val pp_call :
+ Format.formatter ->
+ Machine_code_types.machine_t ->
+ Utils.ident ->
+ Lustre_types.var_decl list ->
+ Machine_code_types.value_t list ->
+ unit
diff --git a/src/backends/Horn/horn_backend.mli b/src/backends/Horn/horn_backend.mli
index b1788f5e..531948bb 100644
--- a/src/backends/Horn/horn_backend.mli
+++ b/src/backends/Horn/horn_backend.mli
@@ -1 +1,5 @@
-val translate: Format.formatter -> Lustre_types.program_t -> Machine_code_types.machine_t list -> unit
+val translate :
+ Format.formatter ->
+ Lustre_types.program_t ->
+ Machine_code_types.machine_t list ->
+ unit
diff --git a/src/backends/Horn/horn_backend_collecting_sem.ml b/src/backends/Horn/horn_backend_collecting_sem.ml
index fae985b1..570afe0a 100644
--- a/src/backends/Horn/horn_backend_collecting_sem.ml
+++ b/src/backends/Horn/horn_backend_collecting_sem.ml
@@ -45,8 +45,7 @@ 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 *)
@@ -157,8 +156,7 @@ 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) @.";
diff --git a/src/backends/Horn/horn_backend_collecting_sem.mli b/src/backends/Horn/horn_backend_collecting_sem.mli
index 7d975275..cc732c0f 100644
--- a/src/backends/Horn/horn_backend_collecting_sem.mli
+++ b/src/backends/Horn/horn_backend_collecting_sem.mli
@@ -1,7 +1,12 @@
open Utils
open Machine_code_types
-val cex_computation: machine_t list -> Format.formatter -> ident -> machine_t -> unit
-val get_cex: machine_t list -> Format.formatter -> machine_t -> unit
-val collecting_semantics: machine_t list -> Format.formatter -> ident -> machine_t -> unit
-val check_prop: machine_t list -> Format.formatter -> machine_t -> unit
+val cex_computation :
+ machine_t list -> Format.formatter -> ident -> machine_t -> unit
+
+val get_cex : machine_t list -> Format.formatter -> machine_t -> unit
+
+val collecting_semantics :
+ machine_t list -> Format.formatter -> ident -> machine_t -> unit
+
+val check_prop : machine_t list -> Format.formatter -> machine_t -> unit
diff --git a/src/backends/Horn/horn_backend_common.ml b/src/backends/Horn/horn_backend_common.ml
index 3e0ff669..a5bec90d 100644
--- a/src/backends/Horn/horn_backend_common.ml
+++ b/src/backends/Horn/horn_backend_common.ml
@@ -17,11 +17,14 @@ open Corelang
let get_machine = Machine_code_common.get_machine
-let machine_reset_name id = id ^ "_reset"
+(* XXX: UNUSED *)
+(* let machine_reset_name id = id ^ "_reset" *)
-let machine_step_name id = id ^ "_step"
+(* XXX: UNUSED *)
+(* let machine_step_name id = id ^ "_step" *)
-let machine_stateless_name id = id ^ "_fun"
+(* XXX: UNUSED *)
+(* let machine_stateless_name id = id ^ "_fun" *)
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
@@ -161,11 +164,12 @@ let reset_vars machines m =
rename_current_list (full_memory_vars machines m)
@ rename_mid_list (full_memory_vars machines m)
-let step_vars_c_m_x machines m =
- inout_vars m
- @ rename_current_list (full_memory_vars machines m)
- @ rename_mid_list (full_memory_vars machines m)
- @ rename_next_list (full_memory_vars machines m)
+(* XXX: UNUSED *)
+(* let step_vars_c_m_x machines m =
+ * inout_vars m
+ * @ rename_current_list (full_memory_vars machines m)
+ * @ rename_mid_list (full_memory_vars machines m)
+ * @ rename_next_list (full_memory_vars machines m) *)
(* Local Variables: *)
(* compile-command:"make -C ../.." *)
diff --git a/src/backends/Horn/horn_backend_common.mli b/src/backends/Horn/horn_backend_common.mli
index 268b2841..676e055b 100644
--- a/src/backends/Horn/horn_backend_common.mli
+++ b/src/backends/Horn/horn_backend_common.mli
@@ -3,35 +3,53 @@ open Format
open Lustre_types
open Machine_code_types
-val rename_machine_list: ident -> var_decl list -> var_decl list
-val get_machine: machine_t list -> ident -> machine_t
-
-val full_memory_vars: ?without_arrow:bool -> machine_t list -> machine_t -> var_decl list
-
-val rename_machine: ident -> var_decl -> var_decl
-val rename_current: var_decl -> var_decl
-val rename_mid: var_decl -> var_decl
-val rename_next: var_decl -> var_decl
-val rename_current_list: var_decl list -> var_decl list
-val rename_mid_list: var_decl list -> var_decl list
-val rename_next_list: var_decl list -> var_decl list
-
-val concat: string -> ident -> ident
-
-val arrow_vars: machine_t list -> machine_t -> var_decl list
-val reset_vars: machine_t list -> machine_t -> var_decl list
-val step_vars: machine_t list -> machine_t -> var_decl list
-val step_vars_m_x: machine_t list -> machine_t -> var_decl list
-val local_memory_vars: machine_t -> var_decl list
-val inout_vars: machine_t -> var_decl list
-
-val pp_type: formatter -> Types.t -> unit
-val pp_machine_reset_name: formatter -> ident -> unit
-val pp_machine_step_name: formatter -> ident -> unit
-val pp_machine_stateless_name: formatter -> ident -> unit
-val pp_conj: (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
-val pp_decl_var: formatter -> var_decl -> unit
-
-val registered_keywords: ident list
-
-val protect_kwd: ident -> ident
+val rename_machine_list : ident -> var_decl list -> var_decl list
+
+val get_machine : machine_t list -> ident -> machine_t
+
+val full_memory_vars :
+ ?without_arrow:bool -> machine_t list -> machine_t -> var_decl list
+
+val rename_machine : ident -> var_decl -> var_decl
+
+val rename_current : var_decl -> var_decl
+
+val rename_mid : var_decl -> var_decl
+
+val rename_next : var_decl -> var_decl
+
+val rename_current_list : var_decl list -> var_decl list
+
+val rename_mid_list : var_decl list -> var_decl list
+
+val rename_next_list : var_decl list -> var_decl list
+
+val concat : string -> ident -> ident
+
+val arrow_vars : machine_t list -> machine_t -> var_decl list
+
+val reset_vars : machine_t list -> machine_t -> var_decl list
+
+val step_vars : machine_t list -> machine_t -> var_decl list
+
+val step_vars_m_x : machine_t list -> machine_t -> var_decl list
+
+val local_memory_vars : machine_t -> var_decl list
+
+val inout_vars : machine_t -> var_decl list
+
+val pp_type : formatter -> Types.t -> unit
+
+val pp_machine_reset_name : formatter -> ident -> unit
+
+val pp_machine_step_name : formatter -> ident -> unit
+
+val pp_machine_stateless_name : formatter -> ident -> unit
+
+val pp_conj : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
+
+val pp_decl_var : formatter -> var_decl -> unit
+
+val registered_keywords : ident list
+
+val protect_kwd : ident -> ident
diff --git a/src/backends/Horn/horn_backend_printers.ml b/src/backends/Horn/horn_backend_printers.ml
index 7a98efce..8911c454 100644
--- a/src/backends/Horn/horn_backend_printers.ml
+++ b/src/backends/Horn/horn_backend_printers.ml
@@ -264,17 +264,20 @@ let pp_instance_call machines reset_instances m fmt i inputs outputs =
| _ ->
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_horn_val m self (pp_horn_var m)))
+ inputs
(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)) (mid_mems @ next_mems)
+ (pp_print_list (pp_horn_var m))
+ (mid_mems @ next_mems)
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
- (pp_horn_val m self (pp_horn_var m))) inputs
+ (pp_horn_val m self (pp_horn_var m)))
+ inputs
(pp_print_list (pp_horn_val m self (pp_horn_var m)))
(List.map (fun v -> mk_val (Var v) v.var_type) outputs)
@@ -414,8 +417,7 @@ 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)
+ 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
@@ -446,8 +448,7 @@ let print_machine machines fmt m =
else (
(* Declaring predicate *)
fprintf fmt "(declare-rel %a (%a))@." pp_machine_reset_name
- m.mname.node_id
- (pp_print_list pp_type)
+ 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
@@ -538,8 +539,7 @@ 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)
+ 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 *)
@@ -553,13 +553,11 @@ let print_sfunction machines fmt m =
else (
(* Declaring predicate *)
Format.fprintf fmt "(declare-rel %a (%a))@." pp_machine_reset_name
- m.mname.node_id
- (pp_print_list pp_type)
+ 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)
+ 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 ();
@@ -688,32 +686,32 @@ and pp_xml_eexpr fmt e =
match e.eexpr_quantifiers with [] -> () | _ -> fprintf fmt ";")
pp_xml_expr e.eexpr_qfexpr
-and pp_xml_sf_value fmt e =
- fprintf fmt "%a"
- (* (Utils.fprintf_list ~sep:"; " pp_xml_quantifiers) e.eexpr_quantifiers *)
- (* (fun fmt -> match e.eexpr_quantifiers *)
- (* with [] -> () *)
- (* | _ -> fprintf fmt ";") *)
- pp_xml_expr e.eexpr_qfexpr
-
-and pp_xml_s_function fmt expr_ann =
- let pp_xml_annot fmt (kwds, ee) =
- Format.fprintf fmt " %t : %a"
- (fun fmt ->
- match kwds with
- | [] ->
- assert false
- | [ x ] ->
- Format.pp_print_string fmt x
- | _ ->
- Format.fprintf fmt "%a"
- (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "/")
- pp_print_string)
- kwds)
- pp_xml_sf_value ee
- in
- pp_print_list pp_xml_annot fmt expr_ann.annots
-
+(* XXX: UNUSED *)
+(* and pp_xml_sf_value fmt e =
+ * fprintf fmt "%a"
+ * (\* (Utils.fprintf_list ~sep:"; " pp_xml_quantifiers) e.eexpr_quantifiers *\)
+ * (\* (fun fmt -> match e.eexpr_quantifiers *\)
+ * (\* with [] -> () *\)
+ * (\* | _ -> fprintf fmt ";") *\)
+ * pp_xml_expr e.eexpr_qfexpr
+ *
+ * and pp_xml_s_function fmt expr_ann =
+ * let pp_xml_annot fmt (kwds, ee) =
+ * Format.fprintf fmt " %t : %a"
+ * (fun fmt ->
+ * match kwds with
+ * | [] ->
+ * assert false
+ * | [ x ] ->
+ * Format.pp_print_string fmt x
+ * | _ ->
+ * Format.fprintf fmt "%a"
+ * (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "/")
+ * pp_print_string)
+ * kwds)
+ * pp_xml_sf_value ee
+ * in
+ * 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; *)"
@@ -725,7 +723,8 @@ and pp_xml_expr_annot fmt expr_ann =
Format.pp_print_string fmt x
| _ ->
Format.fprintf fmt "/%a/"
- (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "/")
+ (pp_print_list
+ ~pp_sep:(fun fmt () -> pp_print_string fmt "/")
pp_print_string)
kwds)
pp_xml_eexpr ee
diff --git a/src/backends/Horn/horn_backend_printers.mli b/src/backends/Horn/horn_backend_printers.mli
index cefca734..46645330 100644
--- a/src/backends/Horn/horn_backend_printers.mli
+++ b/src/backends/Horn/horn_backend_printers.mli
@@ -2,7 +2,10 @@ open Format
open Lustre_types
open Machine_code_types
-val pp_horn_var: machine_t -> formatter -> var_decl -> unit
-val pp_xml_expr: formatter -> expr -> unit
-val print_sfunction: machine_t list -> formatter -> machine_t -> unit
-val print_machine: machine_t list -> formatter -> machine_t -> unit
+val pp_horn_var : machine_t -> formatter -> var_decl -> unit
+
+val pp_xml_expr : formatter -> expr -> unit
+
+val print_sfunction : machine_t list -> formatter -> machine_t -> unit
+
+val print_machine : machine_t list -> formatter -> machine_t -> unit
diff --git a/src/backends/Horn/horn_backend_traces.ml b/src/backends/Horn/horn_backend_traces.ml
index c2c606b2..df4695ee 100644
--- a/src/backends/Horn/horn_backend_traces.ml
+++ b/src/backends/Horn/horn_backend_traces.ml
@@ -22,8 +22,9 @@ open Machine_code_types
open Horn_backend_common
open Horn_backend_printers
-let pp_traces =
- pp_comma_list (fun fmt (v, e) -> fprintf fmt "%s -> %a" v Printers.pp_expr e)
+(* XXX: UNUSED *)
+(* let pp_traces =
+ * pp_comma_list (fun fmt (v, e) -> fprintf fmt "%s -> %a" v Printers.pp_expr e) *)
(* Compute memories associated to each machine *)
let compute_mems machines m =
@@ -51,8 +52,7 @@ let machines_traces machines =
let filtered =
List.filter (fun (kwds, _) -> kwds = [ "traceability" ]) all_annots
in
- (* List.iter (eprintf "Annots: %a@." Printers.pp_expr_annot)
- (m.mannot); *)
+ (* List.iter (eprintf "Annots: %a@." Printers.pp_expr_annot) (m.mannot); *)
let content = List.map snd filtered in
(* Elements are supposed to be a pair (tuple): variable, expression *)
List.map
@@ -117,8 +117,7 @@ let memories_next machines m =
false)
m.mname.node_stmts
with _ ->
- eprintf
- "Unable to find definition of %s in stmts %a@.prefix=%a@.@?"
+ 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))
@@ -146,10 +145,11 @@ let memories_next machines m =
assert false)
(memories_old machines m)
-let pp_prefix_rev fmt prefix =
- pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ".")
- (fun fmt (id, n) -> fprintf fmt "(%s,%s)" id n.mname.node_id)
- fmt (List.rev prefix)
+(* XXX: UNUSED *)
+(* let pp_prefix_rev fmt prefix =
+ * pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ".")
+ * (fun fmt (id, n) -> fprintf fmt "(%s,%s)" id n.mname.node_id)
+ * fmt (List.rev prefix) *)
let traces_file fmt machines =
let pp_l = pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt " | ") in
@@ -172,14 +172,17 @@ let traces_file fmt machines =
rename_machine_list m.mname.node_id m.mstep.step_outputs
in
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)) input_vars
- (pp_l (pp_horn_var m)) m.mstep.step_inputs;
+ (pp_l (pp_horn_var m))
+ input_vars
+ (pp_l (fun fmt id -> pp_type fmt id.var_type))
+ input_vars
+ (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
- (pp_l (fun fmt id -> pp_type fmt id.var_type)) output_vars
- (pp_l pp_var) m.mstep.step_outputs;
+ (pp_l (fun fmt id -> pp_type fmt id.var_type))
+ output_vars (pp_l pp_var) m.mstep.step_outputs;
let local_vars =
try full_memory_vars ~without_arrow:true machines m
@@ -191,9 +194,9 @@ let traces_file fmt machines =
let step_local_vars = rename_current_list local_vars in
fprintf fmt "<localInit name=\"%a\" type=\"%a\">%t%a</localInit>@ "
- (pp_l pp_var)
+ (pp_l pp_var) init_local_vars
+ (pp_l (fun fmt id -> pp_type fmt id.var_type))
init_local_vars
- (pp_l (fun fmt id -> pp_type fmt id.var_type)) init_local_vars
(fun fmt ->
match memories_next with [] -> () | _ -> fprintf fmt "")
(pp_l (fun fmt (_, ee) -> fprintf fmt "%a" pp_xml_expr ee))
@@ -201,7 +204,8 @@ let traces_file fmt machines =
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
+ (pp_l (fun fmt id -> pp_type fmt id.var_type))
+ step_local_vars
(fun fmt -> match memories_old with [] -> () | _ -> fprintf fmt "")
(pp_l (fun fmt (_, ee) -> fprintf fmt "(%a)" pp_xml_expr ee))
memories_old;
@@ -210,7 +214,8 @@ let traces_file fmt machines =
let arrow_vars_curr = rename_current_list arrow_vars
and arrow_vars_mid = rename_mid_list arrow_vars
and arrow_vars_next = rename_next_list arrow_vars in
- pp_print_list (fun fmt v -> fprintf fmt "<reset name=\"%a\"/>" pp_var v)
+ pp_print_list
+ (fun fmt v -> fprintf fmt "<reset name=\"%a\"/>" pp_var v)
fmt
(arrow_vars_curr @ arrow_vars_mid @ arrow_vars_next);
fprintf fmt "@]@ </Node>"))
diff --git a/src/backends/Horn/horn_backend_traces.mli b/src/backends/Horn/horn_backend_traces.mli
index d17ec562..aca75836 100644
--- a/src/backends/Horn/horn_backend_traces.mli
+++ b/src/backends/Horn/horn_backend_traces.mli
@@ -1 +1 @@
-val traces_file: Format.formatter -> Machine_code_types.machine_t list -> unit
+val traces_file : Format.formatter -> Machine_code_types.machine_t list -> unit
diff --git a/src/backends/backends.ml b/src/backends/backends.ml
index 0f37e533..7032edee 100644
--- a/src/backends/backends.ml
+++ b/src/backends/backends.ml
@@ -11,17 +11,15 @@ let setup () =
let is_functional () =
let open Options in
- match !output with
- | OutHorn | OutLustre | OutEMF ->
- true
- | _ ->
- false
+ match !output with OutHorn | OutLustre | OutEMF -> true | _ -> false
(* Special treatment of arrows in lustre backend. We want to keep them *)
-let unfold_arrow () = match !Options.output with Options.OutLustre -> false | _ -> true
+let unfold_arrow () =
+ match !Options.output with Options.OutLustre -> false | _ -> true
(* Forcing ite normalization *)
-let alias_ite () = match !Options.output with Options.OutEMF -> true | _ -> false
+let alias_ite () =
+ match !Options.output with Options.OutEMF -> true | _ -> false
(* Forcing basic functions normalization *)
let alias_internal_fun () =
diff --git a/src/backends/backends.mli b/src/backends/backends.mli
index ec0b6e10..303d93c7 100644
--- a/src/backends/backends.mli
+++ b/src/backends/backends.mli
@@ -1,4 +1,7 @@
-val setup: unit -> unit
-val is_functional: unit -> bool
-val join_guards: bool ref
-val get_normalization_params: unit -> Normalization.param_t
+val setup : unit -> unit
+
+val is_functional : unit -> bool
+
+val join_guards : bool ref
+
+val get_normalization_params : unit -> Normalization.param_t
diff --git a/src/basic_library.ml b/src/basic_library.ml
index 81b5c6bc..74676522 100644
--- a/src/basic_library.ml
+++ b/src/basic_library.ml
@@ -14,7 +14,6 @@
(*open LustreSpec*)
open Type_predef
open Clock_predef
-open Delay_predef
open Dimension
module TE = Env
@@ -86,49 +85,50 @@ let clock_env =
in
env'
-module DE = Env
-
-let delay_env =
- let init_env = DE.initial in
- let env' =
- List.fold_right
- (fun op env -> DE.add_value env op delay_nullary_poly_op)
- [ "true"; "false" ] init_env
- in
- let env' =
- List.fold_right
- (fun op env -> DE.add_value env op delay_unary_poly_op)
- [ "uminus"; "not" ] env'
- in
- let env' =
- List.fold_right
- (fun op env -> DE.add_value env op delay_binary_poly_op)
- [
- "+";
- "-";
- "*";
- "/";
- "mod";
- "&&";
- "||";
- "xor";
- "equi";
- "impl";
- "<";
- "<=";
- ">";
- ">=";
- "!=";
- "=";
- ]
- env'
- in
- let env' =
- List.fold_right
- (fun op env -> DE.add_value env op delay_ternary_poly_op)
- [] env'
- in
- env'
+(* XXX: UNUSED *)
+(* module DE = Env
+ *
+ * let delay_env =
+ * let init_env = DE.initial in
+ * let env' =
+ * List.fold_right
+ * (fun op env -> DE.add_value env op delay_nullary_poly_op)
+ * [ "true"; "false" ] init_env
+ * in
+ * let env' =
+ * List.fold_right
+ * (fun op env -> DE.add_value env op delay_unary_poly_op)
+ * [ "uminus"; "not" ] env'
+ * in
+ * let env' =
+ * List.fold_right
+ * (fun op env -> DE.add_value env op delay_binary_poly_op)
+ * [
+ * "+";
+ * "-";
+ * "*";
+ * "/";
+ * "mod";
+ * "&&";
+ * "||";
+ * "xor";
+ * "equi";
+ * "impl";
+ * "<";
+ * "<=";
+ * ">";
+ * ">=";
+ * "!=";
+ * "=";
+ * ]
+ * env'
+ * in
+ * let env' =
+ * List.fold_right
+ * (fun op env -> DE.add_value env op delay_ternary_poly_op)
+ * [] env'
+ * in
+ * env' *)
module VE = Env
diff --git a/src/basic_library.mli b/src/basic_library.mli
index f5fd8f4e..b422f219 100644
--- a/src/basic_library.mli
+++ b/src/basic_library.mli
@@ -1,18 +1,33 @@
open Utils
-val internal_funs: ident list
-val arith_funs: ident list
-val bool_funs: ident list
-val rel_funs: ident list
-val eval_dim_env: (Dimension.dim_desc list -> Dimension.dim_desc) Env.t
-val is_homomorphic_fun: ident -> bool
-val is_internal_fun: ident -> Types.t list -> bool
-val is_expr_internal_fun: Lustre_types.expr -> bool
-val is_value_internal_fun: Machine_code_types.value_t -> bool
-val is_stateless_fun: ident -> bool
-val is_numeric_operator: ident -> bool
-
-val type_env: Types.t Env.t
-val clock_env: Clocks.t Env.t
-
-val partial_eval: ident -> Lustre_types.expr -> Lustre_types.expr option -> Lustre_types.expr_desc
+val internal_funs : ident list
+
+val arith_funs : ident list
+
+val bool_funs : ident list
+
+val rel_funs : ident list
+
+val eval_dim_env : (Dimension.dim_desc list -> Dimension.dim_desc) Env.t
+
+val is_homomorphic_fun : ident -> bool
+
+val is_internal_fun : ident -> Types.t list -> bool
+
+val is_expr_internal_fun : Lustre_types.expr -> bool
+
+val is_value_internal_fun : Machine_code_types.value_t -> bool
+
+val is_stateless_fun : ident -> bool
+
+val is_numeric_operator : ident -> bool
+
+val type_env : Types.t Env.t
+
+val clock_env : Clocks.t Env.t
+
+val partial_eval :
+ ident ->
+ Lustre_types.expr ->
+ Lustre_types.expr option ->
+ Lustre_types.expr_desc
diff --git a/src/causality.ml b/src/causality.ml
index a23f9800..3ba5ca91 100644
--- a/src/causality.ml
+++ b/src/causality.ml
@@ -18,7 +18,8 @@ open Utils
open Lustre_types
open Corelang
-type identified_call = eq * tag
+(* XXX: UNUSED *)
+(* type identified_call = eq * tag *)
type error =
| DataCycle of ident list list
@@ -68,19 +69,20 @@ let add_vertices vtc g =
let new_graph () = IdentDepGraph.create ()
+(* XXX: UNUSED *)
(* keep subgraph of [gr] consisting of nodes accessible from node [v] *)
-let slice_graph gr v =
- let gr' = new_graph () in
- IdentDepGraph.add_vertex gr' v;
- Bfs.iter_component
- (fun v ->
- IdentDepGraph.iter_succ
- (fun s ->
- IdentDepGraph.add_vertex gr' s;
- IdentDepGraph.add_edge gr' v s)
- gr v)
- gr v;
- gr'
+(* let slice_graph gr v =
+ * let gr' = new_graph () in
+ * IdentDepGraph.add_vertex gr' v;
+ * Bfs.iter_component
+ * (fun v ->
+ * IdentDepGraph.iter_succ
+ * (fun s ->
+ * IdentDepGraph.add_vertex gr' s;
+ * IdentDepGraph.add_edge gr' v s)
+ * gr v)
+ * gr v;
+ * gr' *)
module ExprDep = struct
let get_node_eqs nd =
@@ -157,8 +159,9 @@ module ExprDep = struct
if v.var_dec_const then ISet.add v.var_id locals else locals)
ISet.empty nd.node_locals
- let node_auxiliary_variables nd =
- ISet.diff (node_local_variables nd) (node_memory_variables nd)
+ (* XXX: UNUSED *)
+ (* let node_auxiliary_variables nd =
+ * ISet.diff (node_local_variables nd) (node_memory_variables nd) *)
let node_variables nd =
let inputs = node_input_variables nd in
@@ -320,10 +323,6 @@ module NodeDep = struct
type t = expr
let compare = compare
-
- let hash n = Hashtbl.hash n
-
- let equal n1 n2 = n1 = n2
end
module ESet = Set.Make (ExprModule)
@@ -542,14 +541,15 @@ module CycleDetection = struct
which is defined by a call, we return the name of the node call and its
specific id *)
+ (* XXX: UNUSED *)
(* Creates the sub-graph of [g] restricted to vertices and edges in partition *)
- let copy_partition g partition =
- let copy_g = IdentDepGraph.create () in
- IdentDepGraph.iter_edges
- (fun src tgt ->
- if List.mem src partition && List.mem tgt partition then
- IdentDepGraph.add_edge copy_g src tgt)
- g
+ (* let copy_partition g partition =
+ * let copy_g = IdentDepGraph.create () in
+ * IdentDepGraph.iter_edges
+ * (fun src tgt ->
+ * if List.mem src partition && List.mem tgt partition then
+ * IdentDepGraph.add_edge copy_g src tgt)
+ * g *)
(* Breaks dependency cycles in a graph [g] by inserting aux variables. [head]
is a head of a non-trivial scc of [g]. In Lustre, this is legal only for
@@ -638,39 +638,42 @@ module Disjunction = struct
vdecls;
(map : disjoint_map)
+ (* XXX: UNUSED *)
(* merge variables [v] and [v'] in disjunction [map]. Then: - the mapping v'
becomes v' |-> (map v) inter (map v') - the mapping v |-> ... then
disappears - other mappings become x |-> (map x) \ (if v in x then v else
v') *)
- let merge_in_disjoint_map map v v' =
- Hashtbl.replace map v'.var_id
- (CISet.inter (Hashtbl.find map v.var_id) (Hashtbl.find map v'.var_id));
- Hashtbl.remove map v.var_id;
- Hashtbl.iter
- (fun x map_x ->
- Hashtbl.replace map x
- (CISet.remove (if CISet.mem v map_x then v else v') map_x))
- map
-
+ (* let merge_in_disjoint_map map v v' =
+ * Hashtbl.replace map v'.var_id
+ * (CISet.inter (Hashtbl.find map v.var_id) (Hashtbl.find map v'.var_id));
+ * Hashtbl.remove map v.var_id;
+ * Hashtbl.iter
+ * (fun x map_x ->
+ * Hashtbl.replace map x
+ * (CISet.remove (if CISet.mem v map_x then v else v') map_x))
+ * map *)
+
+ (* XXX: UNUSED *)
(* replace variable [v] by [v'] in disjunction [map]. [v'] is a dead variable.
Then: - the mapping v' becomes v' |-> (map v) - the mapping v |-> ... then
disappears - all mappings become x |-> ((map x) \ { v}) union ({v'} if v in
map x) *)
- let replace_in_disjoint_map map v v' =
- Hashtbl.replace map v'.var_id (Hashtbl.find map v.var_id);
- Hashtbl.remove map v.var_id;
- Hashtbl.iter
- (fun x mapx ->
- Hashtbl.replace map x
- (if CISet.mem v mapx then CISet.add v' (CISet.remove v mapx)
- else CISet.remove v' mapx))
- map
-
+ (* let replace_in_disjoint_map map v v' =
+ * Hashtbl.replace map v'.var_id (Hashtbl.find map v.var_id);
+ * Hashtbl.remove map v.var_id;
+ * Hashtbl.iter
+ * (fun x mapx ->
+ * Hashtbl.replace map x
+ * (if CISet.mem v mapx then CISet.add v' (CISet.remove v mapx)
+ * else CISet.remove v' mapx))
+ * map *)
+
+ (* XXX: UNUSED *)
(* remove variable [v] in disjunction [map]. Then: - the mapping v |-> ...
then disappears - all mappings become x |-> (map x) \ { v} *)
- let remove_in_disjoint_map map v =
- Hashtbl.remove map v.var_id;
- Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (CISet.remove v mapx)) map
+ (* let remove_in_disjoint_map map v =
+ * Hashtbl.remove map v.var_id;
+ * Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (CISet.remove v mapx)) map *)
let pp_disjoint_map fmt map =
Format.(
@@ -692,15 +695,18 @@ let pp_dep_graph fmt g =
let pp_error fmt err =
match err with
| NodeCycle trace ->
- Format.(fprintf fmt "Causality error, cyclic node calls:@ @[<v 0>%a@]@ "
- (pp_comma_list Format.pp_print_string) trace)
+ Format.(
+ 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@]@ "
- (pp_print_list ~pp_sep:pp_print_semicolon (fun fmt trace ->
- fprintf fmt "@[<v 0>{%a}@]"
- (pp_comma_list Format.pp_print_string) trace))
- traces)
+ Format.(
+ 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}@]"
+ (pp_comma_list Format.pp_print_string)
+ trace))
+ traces)
(* Merges elements of graph [g2] into graph [g1] *)
let merge_with g1 g2 =
diff --git a/src/causality.mli b/src/causality.mli
index a520a169..b222cbb9 100644
--- a/src/causality.mli
+++ b/src/causality.mli
@@ -8,69 +8,83 @@ type error =
exception Error of error
-val pp_error: Format.formatter -> error -> unit
+val pp_error : Format.formatter -> error -> unit
-val world: ident
+val world : ident
-module NodeDep: sig
- val dependence_graph: program_t -> IdentDepGraph.t
- val filter_static_inputs: var_decl list -> expr list -> Dimension.t list
- val compute_generic_calls: program_t -> unit
- val get_callee: expr -> (ident * expr list) option
- val get_calls: (ident -> bool) -> node_desc -> expr list
+module NodeDep : sig
+ val dependence_graph : program_t -> IdentDepGraph.t
+
+ val filter_static_inputs : var_decl list -> expr list -> Dimension.t list
+
+ val compute_generic_calls : program_t -> unit
+
+ val get_callee : expr -> (ident * expr list) option
+
+ val get_calls : (ident -> bool) -> node_desc -> expr list
end
(* Look for cycles in a dependency graph *)
-module CycleDetection: sig
- val check_cycles: IdentDepGraph.t -> unit
+module CycleDetection : sig
+ val check_cycles : IdentDepGraph.t -> unit
end
(* A module to sort dependencies among local variables when relying on clocked
declarations *)
-module VarClockDep: sig
- val sort: var_decl list -> var_decl list
+module VarClockDep : sig
+ val sort : var_decl list -> var_decl list
end
-module ExprDep: sig
+module ExprDep : sig
(* instance vars represent node instance calls, they are not part of the
program/schedule, but used to simplify causality analysis *)
- val mk_instance_var: ident -> ident
- val is_instance_var: ident -> bool
- val is_ghost_var: ident -> bool
- val is_read_var: ident -> bool
- val undo_instance_var: ident -> ident
- val undo_read_var: ident -> ident
- val node_eq_equiv: node_desc -> (ident, ident) Hashtbl.t
- val node_input_variables: node_desc -> ISet.t
- val node_local_variables: node_desc -> ISet.t
- val node_output_variables: node_desc -> ISet.t
- val node_memory_variables: node_desc -> ISet.t
+ val mk_instance_var : ident -> ident
+
+ val is_instance_var : ident -> bool
+
+ val is_ghost_var : ident -> bool
+
+ val is_read_var : ident -> bool
+
+ val undo_instance_var : ident -> ident
+
+ val undo_read_var : ident -> ident
+
+ val node_eq_equiv : node_desc -> (ident, ident) Hashtbl.t
+
+ val node_input_variables : node_desc -> ISet.t
+
+ val node_local_variables : node_desc -> ISet.t
+
+ val node_output_variables : node_desc -> ISet.t
+
+ val node_memory_variables : node_desc -> ISet.t
end
(* Module used to compute static disjunction of variables based upon their
clocks. *)
-module Disjunction: sig
- module CISet: Set.S with type elt = var_decl
+module Disjunction : sig
+ module CISet : Set.S with type elt = var_decl
(* map: var |-> list of disjoint vars, sorted in increasing branch length
order, maybe removing shorter branches *)
type disjoint_map = (ident, CISet.t) Hashtbl.t
- val pp_ciset: Format.formatter -> CISet.t -> unit
+ val pp_ciset : Format.formatter -> CISet.t -> unit
- val clock_disjoint_map: var_decl list -> disjoint_map
+ val clock_disjoint_map : var_decl list -> disjoint_map
- val pp_disjoint_map: Format.formatter -> disjoint_map -> unit
+ val pp_disjoint_map : Format.formatter -> disjoint_map -> unit
end
(* Tests whether [v] is a root of graph [g], i.e. a source *)
-val is_graph_root: ident -> IdentDepGraph.t -> bool
+val is_graph_root : ident -> IdentDepGraph.t -> bool
(* Computes the set of graph roots, i.e. the sources of acyclic graph [g] *)
-val graph_roots: IdentDepGraph.t -> ident list
+val graph_roots : IdentDepGraph.t -> ident list
(* Takes a node and return a pair (node', graph) where node' is node rebuilt
with the equations enriched with new ones introduced to "break cycles" *)
-val global_dependency: node_desc -> node_desc * IdentDepGraph.t
+val global_dependency : node_desc -> node_desc * IdentDepGraph.t
-val pp_dep_graph: Format.formatter -> IdentDepGraph.t -> unit
+val pp_dep_graph : Format.formatter -> IdentDepGraph.t -> unit
diff --git a/src/checks/access.ml b/src/checks/access.ml
index 36fa1e0c..80f8c57d 100644
--- a/src/checks/access.ml
+++ b/src/checks/access.ml
@@ -12,15 +12,10 @@
(** Access checking module. Done after typing. Generates dimension constraints
stored in nodes *)
-let debug _fmt _args = ()
-
-(* Format.eprintf "%a" *)
(* Though it shares similarities with the clock calculus module, no code is
shared. Simple environments, very limited identifier scoping, no identifier
redefinition allowed. *)
-open Utils
-
(* Yes, opening both modules is dirty as some type names will be overwritten,
yet this makes notations far lighter.*)
open Lustre_types
@@ -34,8 +29,6 @@ module ConstraintModule = struct
let compare d1 d2 =
if equal d1 d2 then 0 else compare d1.Dimension.dim_id d2.Dimension.dim_id
-
- let hash n = Hashtbl.hash n
end
module CSet = Set.Make (ConstraintModule)
diff --git a/src/checks/access.mli b/src/checks/access.mli
index b17b3877..343801ad 100644
--- a/src/checks/access.mli
+++ b/src/checks/access.mli
@@ -1 +1 @@
-val check_prog: Lustre_types.program_t -> unit
+val check_prog : Lustre_types.program_t -> unit
diff --git a/src/checks/algebraicLoop.ml b/src/checks/algebraicLoop.ml
index 07de6846..1519656b 100644
--- a/src/checks/algebraicLoop.ml
+++ b/src/checks/algebraicLoop.ml
@@ -31,7 +31,8 @@ type algebraic_loop = ident list * (call * bool) list * bool
type report = (node_desc * algebraic_loop list) list
-exception Error of report
+(* XXX: UNUSED *)
+(* exception Error of report *)
(* Module that extract from the DataCycle the set of node that could be inlined
to solve the problem. *)
@@ -76,11 +77,12 @@ end
(* Format.fprintf fmt "@[<v 2>Possible resolution:@ %a@]" pp_resolution
resolution*)
-let pp_resolution fmt resolution =
- Format.(pp_print_list
- (fun fmt (eq, _) ->
- fprintf fmt "inlining: %a" Printers.pp_node_eq eq)
- fmt resolution)
+(* XXX: UNUSED *)
+(* let pp_resolution fmt resolution =
+ * Format.(pp_print_list
+ * (fun fmt (eq, _) ->
+ * fprintf fmt "inlining: %a" Printers.pp_node_eq eq)
+ * fmt resolution) *)
let al_is_solved (_, als) = List.for_all (fun (_, _, status) -> status) als
@@ -131,12 +133,13 @@ let is_expr_inlined nd expr =
| _ ->
assert false)
-let pp_calls nd fmt calls =
- Format.(fprintf fmt "@[<v 0>%a@]"
- (pp_print_list (fun fmt (funid, expr, _) ->
- fprintf fmt "%s: %i (inlined:%b)" funid expr.expr_tag
- (is_expr_inlined nd expr)))
- calls)
+(* XXX: UNUSED *)
+(* let pp_calls nd fmt calls =
+ * Format.(fprintf fmt "@[<v 0>%a@]"
+ * (pp_print_list (fun fmt (funid, expr, _) ->
+ * fprintf fmt "%s: %i (inlined:%b)" funid expr.expr_tag
+ * (is_expr_inlined nd expr)))
+ * calls) *)
(* Inline the provided expression *)
let inline_expr node expr =
@@ -385,7 +388,8 @@ let pp_report fmt report =
in
pp top.top_decl_loc (fun fmt ->
fprintf fmt "algebraic loop in node %s: {@[<v 0>%a@]}" nd.node_id
- (pp_print_list (pp_al nd)) als))
+ (pp_print_list (pp_al nd))
+ als))
fmt report;
fprintf fmt "@."
diff --git a/src/checks/algebraicLoop.mli b/src/checks/algebraicLoop.mli
index ea154812..aab9d675 100644
--- a/src/checks/algebraicLoop.mli
+++ b/src/checks/algebraicLoop.mli
@@ -1,4 +1,4 @@
open Utils
open Lustre_types
-val analyze: program_t -> program_t * Scheduling_type.schedule_report IMap.t
+val analyze : program_t -> program_t * Scheduling_type.schedule_report IMap.t
diff --git a/src/checks/liveness.ml b/src/checks/liveness.ml
index dea8fd0c..3093b69e 100644
--- a/src/checks/liveness.ml
+++ b/src/checks/liveness.ml
@@ -74,14 +74,15 @@ let compute_unused_variables n g =
(fun var unused -> ISet.diff unused (cone_of_influence g var))
(ISet.union outputs mems) (ISet.union inputs mems)
+(* XXX: UNUSED *)
(* computes the set of potentially reusable variables. We don't reuse input
variables, due to possible aliasing *)
-let node_reusable_variables node =
- let mems = ExprDep.node_memory_variables node in
- List.fold_left
- (fun acc l ->
- if ISet.mem l.var_id mems then acc else Disjunction.CISet.add l acc)
- Disjunction.CISet.empty node.node_locals
+(* let node_reusable_variables node =
+ * let mems = ExprDep.node_memory_variables node in
+ * List.fold_left
+ * (fun acc l ->
+ * if ISet.mem l.var_id mems then acc else Disjunction.CISet.add l acc)
+ * Disjunction.CISet.empty node.node_locals *)
let kill_instance_variables ctx inst =
IdentDepGraph.remove_vertex ctx.dep_graph inst
@@ -174,10 +175,11 @@ let compute_dependencies heads ctx =
List.iter (kill_root ctx) heads;
remove_roots ctx
-let compute_evaluated heads ctx =
- List.iter
- (fun head -> ctx.evaluated <- Disjunction.CISet.add head ctx.evaluated)
- heads
+(* XXX: UNUSED *)
+(* let compute_evaluated heads ctx =
+ * List.iter
+ * (fun head -> ctx.evaluated <- Disjunction.CISet.add head ctx.evaluated)
+ * heads *)
(* tests whether a variable [v] may be (re)used instead of [var]. The conditions
are: - [v] has been really used ([v] is its own representative) - same type -
diff --git a/src/checks/liveness.mli b/src/checks/liveness.mli
index e6078ad6..7b68f72a 100644
--- a/src/checks/liveness.mli
+++ b/src/checks/liveness.mli
@@ -1,18 +1,22 @@
open Utils
open Lustre_types
-val compute_unused_variables: node_desc -> IdentDepGraph.t -> ISet.t
+val compute_unused_variables : node_desc -> IdentDepGraph.t -> ISet.t
type fanin = (ident, tag) Hashtbl.t
- (* computes the in-degree for each local variable of node [n], according to dep
+(* computes the in-degree for each local variable of node [n], according to dep
graph [g]. *)
-val compute_fanin: node_desc -> IdentDepGraph.t -> fanin
+val compute_fanin : node_desc -> IdentDepGraph.t -> fanin
-val pp_fanin: Format.formatter -> fanin -> unit
+val pp_fanin : Format.formatter -> fanin -> unit
-val compute_reuse_policy: node_desc -> ident list list ->
- Causality.Disjunction.disjoint_map -> IdentDepGraph.t -> (ident, var_decl) Hashtbl.t
+val compute_reuse_policy :
+ node_desc ->
+ ident list list ->
+ Causality.Disjunction.disjoint_map ->
+ IdentDepGraph.t ->
+ (ident, var_decl) Hashtbl.t
(* replace variable [v] by [v'] in graph [g]. [v'] is a dead variable *)
-val replace_in_dep_graph: ident -> ident -> IdentDepGraph.t -> unit
+val replace_in_dep_graph : ident -> ident -> IdentDepGraph.t -> unit
diff --git a/src/checks/stateless.mli b/src/checks/stateless.mli
index 33f466d3..41d4d96c 100644
--- a/src/checks/stateless.mli
+++ b/src/checks/stateless.mli
@@ -8,9 +8,12 @@ type error =
exception Error of Location.t * error
-val check_node: top_decl -> bool
-val check_prog: program_t -> unit
-val force_prog: program_t -> unit
-val check_compat: top_decl list -> unit
+val check_node : top_decl -> bool
-val pp_error: Format.formatter -> error -> unit
+val check_prog : program_t -> unit
+
+val force_prog : program_t -> unit
+
+val check_compat : top_decl list -> unit
+
+val pp_error : Format.formatter -> error -> unit
diff --git a/src/clock_calculus.ml b/src/clock_calculus.ml
index 05b45a75..278a0a95 100644
--- a/src/clock_calculus.ml
+++ b/src/clock_calculus.ml
@@ -308,14 +308,15 @@ let rec semi_unify ck1 ck2 =
| _, _ ->
raise (Unify (ck1, ck2))
+(* XXX: UNUSED *)
(* Returns the value corresponding to a pclock (integer) factor expression.
Expects a constant expression (checked by typing). *)
-let int_factor_of_expr e =
- match e.expr_desc with
- | Expr_const (Const_int i) ->
- i
- | _ ->
- failwith "Internal error: int_factor_of_expr"
+(* let int_factor_of_expr e =
+ * match e.expr_desc with
+ * | Expr_const (Const_int i) ->
+ * i
+ * | _ ->
+ * failwith "Internal error: int_factor_of_expr" *)
(** [clock_uncarry ck] drops the possible carrier(s) name(s) from clock [ck] *)
let rec clock_uncarry ck =
@@ -738,14 +739,16 @@ let clock_imported_node env loc nd =
nd.nodei_clock <- ck_node;
Env.add_value env nd.nodei_id ck_node
-let new_env = clock_var_decl_list
+(* XXX: UNUSED *)
+(* let new_env = clock_var_decl_list *)
let clock_top_const env cdecl =
let ck = new_var false in
try_generalize ck cdecl.const_loc;
Env.add_value env cdecl.const_id ck
-let clock_top_consts env clist = List.fold_left clock_top_const env clist
+(* XXX: UNUSED *)
+(* let clock_top_consts env clist = List.fold_left clock_top_const env clist *)
let rec clock_top_decl env decl =
match decl.top_decl_desc with
diff --git a/src/clock_calculus.mli b/src/clock_calculus.mli
index 130c0735..5af4f6fc 100644
--- a/src/clock_calculus.mli
+++ b/src/clock_calculus.mli
@@ -1,11 +1,11 @@
open Lustre_types
-val clock_node: Clocks.t Env.t -> Location.t -> node_desc -> Clocks.t Env.t
+val clock_node : Clocks.t Env.t -> Location.t -> node_desc -> Clocks.t Env.t
-val compute_root_clock: Clocks.t -> Clocks.t
+val compute_root_clock : Clocks.t -> Clocks.t
-val clock_prog: Clocks.t Env.t -> program_t -> Clocks.t Env.t
+val clock_prog : Clocks.t Env.t -> program_t -> Clocks.t Env.t
-val check_env_compat: top_decl list -> Clocks.t Env.t -> Clocks.t Env.t -> unit
+val check_env_compat : top_decl list -> Clocks.t Env.t -> Clocks.t Env.t -> unit
-val uneval_prog_generics: program_t -> unit
+val uneval_prog_generics : program_t -> unit
diff --git a/src/clock_predef.ml b/src/clock_predef.ml
index 790fcba4..06e38d4f 100644
--- a/src/clock_predef.ml
+++ b/src/clock_predef.ml
@@ -20,9 +20,10 @@ let ck_bin_univ =
let univ = new_univar () in
new_ck (Carrow (new_ck (Ctuple [ univ; univ ]) true, univ)) true
-let ck_ite =
- let univ = new_univar () in
- new_ck (Carrow (new_ck (Ctuple [ univ; univ; univ ]) true, univ)) true
+(* XXX: UNUSED *)
+(* let ck_ite =
+ * let univ = new_univar () in
+ * new_ck (Carrow (new_ck (Ctuple [ univ; univ; univ ]) true, univ)) true *)
let ck_nullary_univ =
let univ = new_univar () in
@@ -32,18 +33,22 @@ let ck_unary_univ =
let univ = new_univar () in
new_ck (Carrow (univ, univ)) true
-let ck_bool_to_clock =
- let univ = new_univar () in
- let cuniv = new_carrier Carry_var false in
- new_ck (Carrow (univ, new_ck (Ccarrying (cuniv, univ)) false))
+(* XXX: UNUSED *)
+(* let ck_bool_to_clock =
+ * let univ = new_univar () in
+ * let cuniv = new_carrier Carry_var false in
+ * new_ck (Carrow (univ, new_ck (Ccarrying (cuniv, univ)) false)) *)
-let ck_clock_to_bool =
- let univ = new_univar () in
- let cuniv = new_carrier Carry_var false in
- new_ck (Carrow (new_ck (Ccarrying (cuniv, univ)) false, univ))
+(* XXX: UNUSED *)
+(* let ck_clock_to_bool =
+ * let univ = new_univar () in
+ * let cuniv = new_carrier Carry_var false in
+ * new_ck (Carrow (new_ck (Ccarrying (cuniv, univ)) false, univ)) *)
+
+(* XXX: UNUSED *)
+(* let ck_carrier id ck =
+ * new_ck (Ccarrying (new_carrier (Carry_const id) true, ck)) true *)
-let ck_carrier id ck =
- new_ck (Ccarrying (new_carrier (Carry_const id) true, ck)) true
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/clock_predef.mli b/src/clock_predef.mli
index 5558c9fa..6f6ce618 100644
--- a/src/clock_predef.mli
+++ b/src/clock_predef.mli
@@ -1,4 +1,7 @@
-val ck_nullary_univ: Clocks.t
-val ck_unary_univ: Clocks.t
-val ck_bin_univ: Clocks.t
-val ck_tuple: Clocks.t list -> Clocks.t
+val ck_nullary_univ : Clocks.t
+
+val ck_unary_univ : Clocks.t
+
+val ck_bin_univ : Clocks.t
+
+val ck_tuple : Clocks.t list -> Clocks.t
diff --git a/src/clocks.ml b/src/clocks.ml
index 046693f8..1e37891c 100644
--- a/src/clocks.ml
+++ b/src/clocks.ml
@@ -36,11 +36,7 @@ and carrier_expr = {
carrier_id : int;
}
-type t = {
- mutable cdesc : clock_desc;
- mutable cscoped : bool;
- cid : int;
-}
+type t = { mutable cdesc : clock_desc; mutable cscoped : bool; cid : int }
(* pck stands for periodic clock. Easier not to separate pck from other clocks *)
and clock_desc =
@@ -102,8 +98,11 @@ 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)" (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt " * ")
- print_ck_long) cklist
+ fprintf fmt "(%a)"
+ (pp_print_list
+ ~pp_sep:(fun fmt () -> pp_print_string fmt " * ")
+ print_ck_long)
+ cklist
| Con (ck, c, l) ->
fprintf fmt "%a on %s(%a)" print_ck_long ck l print_carrier c
| Cvar ->
@@ -133,7 +132,8 @@ let new_carrier desc scoped =
incr new_carrier_id;
{ carrier_desc = desc; carrier_id = !new_carrier_id; carrier_scoped = scoped }
-let new_carrier_name () = new_carrier Carry_name true
+(* XXX: UNUSED *)
+(* let new_carrier_name () = new_carrier Carry_name true *)
let rec repr = function { cdesc = Clink ck'; _ } -> repr ck' | ck -> ck
@@ -146,32 +146,35 @@ let rec carrier_repr = function
let get_carrier_name ck =
match (repr ck).cdesc with Ccarrying (cr, _) -> Some cr | _ -> None
-let rename_carrier_static rename cr =
- match (carrier_repr cr).carrier_desc with
- | Carry_const id ->
- { cr with carrier_desc = Carry_const (rename id) }
- | _ ->
- Format.eprintf "internal error: Clocks.rename_carrier_static %a@."
- print_carrier cr;
- assert false
-
-let rec rename_static rename ck =
- match (repr ck).cdesc with
- | Ccarrying (cr, ck') ->
- {
- ck with
- cdesc =
- Ccarrying (rename_carrier_static rename cr, rename_static rename ck');
- }
- | Con (ck', cr, l) ->
- {
- ck with
- cdesc = Con (rename_static rename ck', rename_carrier_static rename cr, l);
- }
- | _ ->
- ck
-
-let uncarrier ck = match ck.cdesc with Ccarrying (_, ck') -> ck' | _ -> ck
+(* XXX: UNUSED *)
+(* let rename_carrier_static rename cr =
+ * match (carrier_repr cr).carrier_desc with
+ * | Carry_const id ->
+ * { cr with carrier_desc = Carry_const (rename id) }
+ * | _ ->
+ * Format.eprintf "internal error: Clocks.rename_carrier_static %a@."
+ * print_carrier cr;
+ * assert false *)
+
+(* XXX: UNUSED *)
+(* let rec rename_static rename ck =
+ * match (repr ck).cdesc with
+ * | Ccarrying (cr, ck') ->
+ * {
+ * ck with
+ * cdesc =
+ * Ccarrying (rename_carrier_static rename cr, rename_static rename ck');
+ * }
+ * | Con (ck', cr, l) ->
+ * {
+ * ck with
+ * cdesc = Con (rename_static rename ck', rename_carrier_static rename cr, l);
+ * }
+ * | _ ->
+ * ck *)
+
+(* XXX: UNUSED *)
+(* let uncarrier ck = match ck.cdesc with Ccarrying (_, ck') -> ck' | _ -> ck *)
(* Removes all links in a clock. Only used for clocks simplification though. *)
let rec simplify ck =
@@ -224,33 +227,35 @@ let clock_current ck =
assert false)
(clock_list_of_clock ck))
-let clock_of_impnode_clock ck =
- let ck = repr ck in
- match ck.cdesc with
- | Carrow _ | Clink _ | Cvar | Cunivar ->
- failwith "internal error clock_of_impnode_clock"
- | Ctuple cklist ->
- List.hd cklist
- | Con (_, _, _) | Ccarrying (_, _) ->
- ck
-
+(* XXX: UNUSED *)
+(* let clock_of_impnode_clock ck =
+ * let ck = repr ck in
+ * match ck.cdesc with
+ * | Carrow _ | Clink _ | Cvar | Cunivar ->
+ * failwith "internal error clock_of_impnode_clock"
+ * | Ctuple cklist ->
+ * List.hd cklist
+ * | Con (_, _, _) | Ccarrying (_, _) ->
+ * ck *)
+
+(* XXX: UNUSED *)
(** [is_polymorphic ck] returns true if [ck] is polymorphic. *)
-let rec is_polymorphic ck =
- match ck.cdesc with
- | Cvar ->
- false
- | Carrow (ck1, ck2) ->
- is_polymorphic ck1 || is_polymorphic ck2
- | Ctuple ckl ->
- List.exists (fun c -> is_polymorphic c) ckl
- | Con (ck', _, _) ->
- is_polymorphic ck'
- | Cunivar ->
- true
- | Clink ck' ->
- is_polymorphic ck'
- | Ccarrying (_, ck') ->
- is_polymorphic ck'
+(* let rec is_polymorphic ck =
+ * match ck.cdesc with
+ * | Cvar ->
+ * false
+ * | Carrow (ck1, ck2) ->
+ * is_polymorphic ck1 || is_polymorphic ck2
+ * | Ctuple ckl ->
+ * List.exists (fun c -> is_polymorphic c) ckl
+ * | Con (ck', _, _) ->
+ * is_polymorphic ck'
+ * | Cunivar ->
+ * true
+ * | Clink ck' ->
+ * is_polymorphic ck'
+ * | Ccarrying (_, ck') ->
+ * is_polymorphic ck' *)
(* Used mainly for debug, non-linear complexity. *)
@@ -357,7 +362,9 @@ let pp fmt ck =
| Carrow (ck1, ck2) ->
fprintf fmt "%a -> %a" aux ck1 aux ck2
| Ctuple cklist ->
- fprintf fmt "(%a)" (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt " * ") aux) cklist
+ fprintf fmt "(%a)"
+ (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt " * ") aux)
+ cklist
| Con (ck, c, l) ->
fprintf fmt "%a on %s(%a)" aux ck l print_carrier c
| Cvar ->
@@ -373,8 +380,7 @@ let pp fmt ck =
in
let cvars = constrained_vars_of_clock ck in
aux fmt ck;
- if cvars <> [] then
- fprintf fmt " (where %a)" (pp_comma_list print_cvar) cvars
+ if cvars <> [] then fprintf fmt " (where %a)" (pp_comma_list print_cvar) cvars
(* prints only the Con components of a clock, useful for printing nodes *)
let rec pp_suffix fmt ck =
@@ -398,8 +404,7 @@ let pp_error fmt = function
cr1 print_carrier cr2
| Cannot_be_polymorphic ck ->
reset_names ();
- fprintf fmt "The main node cannot have a polymorphic clock: %a@." pp
- ck
+ fprintf fmt "The main node cannot have a polymorphic clock: %a@." pp ck
| Invalid_imported_clock ck ->
reset_names ();
fprintf fmt "Not a valid imported node clock: %a@." pp ck
@@ -448,24 +453,25 @@ let uneval const cr =
with | Carry_const id -> Carry_const (f id) | Carry_link ce -> Carry_link (re
ce) | _ -> cd *)
-let rec rename_clock_expr fvar c =
- { c with cdesc = rename_clock_desc fvar c.cdesc }
-
-and rename_clock_desc fvar cd =
- let re = rename_clock_expr fvar in
- match cd with
- | Carrow (c1, c2) ->
- Carrow (re c1, re c2)
- | Ctuple cl ->
- Ctuple (List.map re cl)
- | Con (c1, car, id) ->
- Con (re c1, car, fvar id)
- | Cvar | Cunivar ->
- cd
- | Clink c ->
- Clink (re c)
- | Ccarrying (car, c) ->
- Ccarrying (car, re c)
+(* XXX: UNUSED *)
+(* let rec rename_clock_expr fvar c =
+ * { c with cdesc = rename_clock_desc fvar c.cdesc }
+ *
+ * and rename_clock_desc fvar cd =
+ * let re = rename_clock_expr fvar in
+ * match cd with
+ * | Carrow (c1, c2) ->
+ * Carrow (re c1, re c2)
+ * | Ctuple cl ->
+ * Ctuple (List.map re cl)
+ * | Con (c1, car, id) ->
+ * Con (re c1, car, fvar id)
+ * | Cvar | Cunivar ->
+ * cd
+ * | Clink c ->
+ * Clink (re c)
+ * | Ccarrying (car, c) ->
+ * Ccarrying (car, re c) *)
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/clocks.mli b/src/clocks.mli
index d7a19be6..9d9658a9 100644
--- a/src/clocks.mli
+++ b/src/clocks.mli
@@ -15,11 +15,7 @@ and carrier_expr = {
carrier_id : int;
}
-type t = {
- mutable cdesc : clock_desc;
- mutable cscoped : bool;
- cid : int;
-}
+type t = { mutable cdesc : clock_desc; mutable cscoped : bool; cid : int }
(* pck stands for periodic clock. Easier not to separate pck from other clocks *)
and clock_desc =
@@ -47,57 +43,66 @@ type error =
(* Nice pretty-printing. Simplifies expressions before printing them. Non-linear
complexity. *)
-val pp: Format.formatter -> t -> unit
+val pp : Format.formatter -> t -> unit
+
+val pp_suffix : Format.formatter -> t -> unit
-val pp_suffix: Format.formatter -> t -> unit
+val new_var : bool -> t
-val new_var: bool -> t
+val new_univar : unit -> t
-val new_univar: unit -> t
+val new_ck : clock_desc -> bool -> t
-val new_ck: clock_desc -> bool -> t
+val new_carrier : carrier_desc -> bool -> carrier_expr
-val new_carrier: carrier_desc -> bool -> carrier_expr
+val bottom : t
-val bottom: t
+val repr : t -> t
-val repr: t -> t
-val carrier_repr: carrier_expr -> carrier_expr
+val carrier_repr : carrier_expr -> carrier_expr
-val simplify: t -> t
+val simplify : t -> t
-val clock_on: t -> carrier_expr -> ident -> t
+val clock_on : t -> carrier_expr -> ident -> t
-val clock_of_clock_list: t list -> t
-val clock_list_of_clock: t -> t list
+val clock_of_clock_list : t list -> t
-val root: t -> t
+val clock_list_of_clock : t -> t list
-val branch: t -> (carrier_expr * ident) list
+val root : t -> t
-val common_prefix: (carrier_expr * ident) list -> (carrier_expr * ident) list -> (carrier_expr * ident) list
+val branch : t -> (carrier_expr * ident) list
-val clock_of_root_branch: t -> (carrier_expr * ident) list -> t
+val common_prefix :
+ (carrier_expr * ident) list ->
+ (carrier_expr * ident) list ->
+ (carrier_expr * ident) list
-val split_arrow: t -> t * t
+val clock_of_root_branch : t -> (carrier_expr * ident) list -> t
-val clock_current: t -> t
+val split_arrow : t -> t * t
-val uneval: ident -> carrier_expr -> unit
+val clock_current : t -> t
-val get_carrier_name: t -> carrier_expr option
+val uneval : ident -> carrier_expr -> unit
-val equal: t -> t -> bool
+val get_carrier_name : t -> carrier_expr option
+
+val equal : t -> t -> bool
(* Disjunction relation between variables based upon their static clocks. *)
-val disjoint: t -> t -> bool
+val disjoint : t -> t -> bool
-val const_of_carrier: carrier_expr -> ident
+val const_of_carrier : carrier_expr -> ident
-val pp_error: Format.formatter -> error -> unit
+val pp_error : Format.formatter -> error -> unit
exception Unify of t * t
+
exception Scope_carrier of carrier_expr
+
exception Scope_clock of t
+
exception Error of Location.t * error
+
exception Mismatch of carrier_expr * carrier_expr
diff --git a/src/compiler_common.ml b/src/compiler_common.ml
index 60269c47..ce29bbdb 100644
--- a/src/compiler_common.ml
+++ b/src/compiler_common.ml
@@ -16,8 +16,7 @@ open Corelang
let check_main () =
if !Options.main_node = "" then (
- eprintf "Code generation error: %a@." Error.pp
- Error.No_main_specified;
+ eprintf "Code generation error: %a@." Error.pp Error.No_main_specified;
raise (Error.Error (Location.dummy, Error.No_main_specified)))
let create_dest_dir () =
@@ -76,16 +75,16 @@ 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 loc;
+ eprintf "Stateless status error: %a%a@." Stateless.pp_error err Location.pp
+ loc;
raise exc
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 loc;
+ eprintf "Stateless status error: %a%a@." Stateless.pp_error err Location.pp
+ loc;
raise exc
let type_decls env decls =
@@ -107,8 +106,7 @@ let clock_decls env decls =
let new_env =
try Clock_calculus.clock_prog env decls
with Clocks.Error (loc, err) as exc ->
- eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp
- loc;
+ eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp loc;
raise exc
in
Log.report ~level:1 (fun fmt -> fprintf fmt "@]");
@@ -117,13 +115,14 @@ let clock_decls env decls =
fprintf fmt "@[<v 2> %a@]@ " Corelang.pp_prog_clock decls);
new_env
+(* XXX: UNUSED *)
(* Typing/Clocking with an empty env *)
-let check_top_decls header =
- let new_tenv = type_decls Basic_library.type_env header in
- (* Typing *)
- let new_cenv = clock_decls Basic_library.clock_env header in
- (* Clock calculus *)
- header, new_tenv, new_cenv
+(* let check_top_decls header =
+ * let new_tenv = type_decls Basic_library.type_env header in
+ * (\* Typing *\)
+ * let new_cenv = clock_decls Basic_library.clock_env header in
+ * (\* Clock calculus *\)
+ * header, new_tenv, new_cenv *)
(* List.fold_right (fun top_decl (ty_env, ck_env) -> match
top_decl.top_decl_desc with | Node nd -> (Env.add_value ty_env nd.node_id
diff --git a/src/compiler_common.mli b/src/compiler_common.mli
index 28400a58..5b686c31 100644
--- a/src/compiler_common.mli
+++ b/src/compiler_common.mli
@@ -1,28 +1,30 @@
open Lustre_types
-val check_main: unit -> unit
+val check_main : unit -> unit
(* Loading Lus/Lusi file and filling type tables with parsed functions/nodes *)
-val parse: string -> string -> program_t
+val parse : string -> string -> program_t
-val check_compatibility: program_t * Types.t Env.t * Clocks.t Env.t ->
- top_decl list * Types.t Env.t * Clocks.t Env.t -> unit
+val check_compatibility :
+ program_t * Types.t Env.t * Clocks.t Env.t ->
+ top_decl list * Types.t Env.t * Clocks.t Env.t ->
+ unit
-val update_vdecl_parents_prog: program_t -> unit
+val update_vdecl_parents_prog : program_t -> unit
-val expand_automata: program_t -> program_t
+val expand_automata : program_t -> program_t
(* Process each node/imported node and introduce the associated contract node *)
-val resolve_contracts: program_t -> program_t
+val resolve_contracts : program_t -> program_t
-val force_stateful_decls: program_t -> unit
+val force_stateful_decls : program_t -> unit
-val check_stateless_decls: program_t -> unit
+val check_stateless_decls : program_t -> unit
-val type_decls: Types.t Env.t -> program_t -> Types.t Env.t
+val type_decls : Types.t Env.t -> program_t -> Types.t Env.t
-val clock_decls: Clocks.t Env.t -> program_t -> Clocks.t Env.t
+val clock_decls : Clocks.t Env.t -> program_t -> Clocks.t Env.t
-val create_dest_dir: unit -> unit
+val create_dest_dir : unit -> unit
-val track_exception: unit -> unit
+val track_exception : unit -> unit
diff --git a/src/compiler_stages.mli b/src/compiler_stages.mli
index a1a2eb55..da09dd47 100644
--- a/src/compiler_stages.mli
+++ b/src/compiler_stages.mli
@@ -3,6 +3,15 @@ open Machine_code_types
exception StopPhase1 of program_t
-val stage1: Normalization.param_t -> program_t -> string -> string -> string -> program_t * dep_t list
-val stage2: Normalization.param_t -> program_t -> program_t * machine_t list
-val stage3: program_t -> machine_t list -> dep_t list -> string -> string -> unit
+val stage1 :
+ Normalization.param_t ->
+ program_t ->
+ string ->
+ string ->
+ string ->
+ program_t * dep_t list
+
+val stage2 : Normalization.param_t -> program_t -> program_t * machine_t list
+
+val stage3 :
+ program_t -> machine_t list -> dep_t list -> string -> string -> unit
diff --git a/src/corelang.ml b/src/corelang.ml
index 2c8097f2..d8a00ec0 100644
--- a/src/corelang.ml
+++ b/src/corelang.ml
@@ -35,20 +35,16 @@ with type elt = var_decl = struct
include Set.Make (VDeclModule)
let pp fmt s =
- Format.fprintf fmt "{@[%a}@]"
- (pp_comma_list Printers.pp_var)
- (elements s)
+ Format.fprintf fmt "{@[%a}@]" (pp_comma_list Printers.pp_var) (elements s)
(* Strangley the find_first function of Set.Make is incorrect (at the current
time of writting this comment. Had to switch to lists *)
let get id s = List.find (fun v -> v.var_id = id) (elements s)
end
-let dummy_type_dec =
- { ty_dec_desc = Tydec_any; ty_dec_loc = Location.dummy }
+let dummy_type_dec = { ty_dec_desc = Tydec_any; ty_dec_loc = Location.dummy }
-let dummy_clock_dec =
- { ck_dec_desc = Ckdec_any; ck_dec_loc = Location.dummy }
+let dummy_clock_dec = { ck_dec_desc = Ckdec_any; ck_dec_loc = Location.dummy }
(************************************************************)
(* *)
@@ -1204,7 +1200,8 @@ let pp_decl_clock fmt cdecl =
| Const _ | Include _ | Open _ | TypeDef _ ->
()
-let pp_prog_clock fmt prog = pp_print_list ~pp_sep:pp_print_nothing pp_decl_clock fmt prog
+let pp_prog_clock fmt prog =
+ pp_print_list ~pp_sep:pp_print_nothing pp_decl_clock fmt prog
(* filling node table with internal functions *)
let vdecls_of_typ_ck cpt ty =
diff --git a/src/corelang.mli b/src/corelang.mli
index 43bc642c..48f46d76 100644
--- a/src/corelang.mli
+++ b/src/corelang.mli
@@ -221,8 +221,7 @@ val get_dependencies : program_t -> top_decl list
val get_node : ident -> program_t -> node_desc
(** Returns the node named ident in the provided program. Raise Not_found *)
-val rename_static :
- (ident -> Dimension.t) -> type_dec_desc -> type_dec_desc
+val rename_static : (ident -> Dimension.t) -> type_dec_desc -> type_dec_desc
val rename_carrier : (ident -> ident) -> clock_dec_desc -> clock_dec_desc
@@ -294,11 +293,7 @@ val reset_cpt_fresh : unit -> unit
(* mk_fresh_var parentid to be registered as parent_nodeid, vars is the list of
existing vars in that context *)
val mk_fresh_var :
- ident * var_decl list ->
- Location.t ->
- Types.t ->
- Clocks.t ->
- var_decl
+ ident * var_decl list -> Location.t -> Types.t -> Clocks.t -> var_decl
val find_eq : ident list -> eq list -> eq * eq list
diff --git a/src/delay.ml b/src/delay.ml
index bd257c6b..114267d6 100644
--- a/src/delay.ml
+++ b/src/delay.ml
@@ -9,7 +9,6 @@
(* *)
(********************************************************************)
-open Utils
(** Types definitions and a few utility functions on delay types. Delay analysis
by type polymorphism instead of constraints *)
@@ -25,12 +24,6 @@ and delay_desc =
| Dunivar
(* Polymorphic type variable *)
-type error = Delay_clash of t * t
-
-exception Unify of t * t
-
-exception Error of Location.t * error
-
let new_id = ref (-1)
let new_delay desc =
@@ -41,60 +34,58 @@ let new_var () = new_delay Dvar
let new_univar () = new_delay Dunivar
-let rec repr = function { ddesc = Dlink i'; _ } -> repr i' | i -> i
+(* XXX: UNUSED *)
+(* let rec repr = function { ddesc = Dlink i'; _ } -> repr i' | i -> i *)
+(* XXX: UNUSED *)
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type
(ensured by language syntax) *)
-let split_arrow de =
- match (repr de).ddesc with
- | Darrow (din, dout) ->
- din, dout
- (* Functions are not first order, I don't think the var case needs to be
- considered here *)
- | _ ->
- failwith "Internal error: not an arrow type"
-
+(* let split_arrow de =
+ * match (repr de).ddesc with
+ * | Darrow (din, dout) ->
+ * din, dout
+ * (\* Functions are not first order, I don't think the var case needs to be
+ * considered here *\)
+ * | _ ->
+ * failwith "Internal error: not an arrow type" *)
+
+(* XXX: UNUSED *)
(** Returns the type corresponding to a type list. *)
-let of_delay_list de =
- if List.length de > 1 then new_delay (Dtuple de) else List.hd de
+(* let of_delay_list de =
+ * if List.length de > 1 then new_delay (Dtuple de) else List.hd de *)
+(* XXX: UNUSED *)
(** [is_polymorphic de] returns true if [de] is polymorphic. *)
-let rec is_polymorphic de =
- match de.ddesc with
- | Dvar ->
- false
- | Dundef ->
- false
- | Darrow (de1, de2) ->
- is_polymorphic de1 || is_polymorphic de2
- | Dtuple dl ->
- List.exists is_polymorphic dl
- | Dlink d' ->
- is_polymorphic d'
- | Dunivar ->
- true
+(* let rec is_polymorphic de =
+ * match de.ddesc with
+ * | Dvar ->
+ * false
+ * | Dundef ->
+ * false
+ * | Darrow (de1, de2) ->
+ * is_polymorphic de1 || is_polymorphic de2
+ * | Dtuple dl ->
+ * List.exists is_polymorphic dl
+ * | Dlink d' ->
+ * is_polymorphic d'
+ * | Dunivar ->
+ * true *)
(* Pretty-print*)
-open Utils.Format
-
-let rec pp fmt de =
- match de.ddesc with
- | Dvar ->
- fprintf fmt "'_%s" (name_of_type de.did)
- | Dundef ->
- fprintf fmt "1"
- | Darrow (de1, de2) ->
- fprintf fmt "%a->%a" pp de1 pp de2
- | Dtuple delist ->
- fprintf fmt "(%a)" (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "*")
- pp) delist
- | Dlink de ->
- pp fmt de
- | Dunivar ->
- fprintf fmt "'%s" (name_of_delay de.did)
-let pp_error fmt = function
- | Delay_clash (de1, de2) ->
- Utils.reset_names ();
- fprintf fmt "Expected delay %a, got delay %a@." pp de1 pp
- de2
+(* XXX: UNUSED *)
+(* let rec pp fmt de =
+ * match de.ddesc with
+ * | Dvar ->
+ * fprintf fmt "'_%s" (name_of_type de.did)
+ * | Dundef ->
+ * fprintf fmt "1"
+ * | Darrow (de1, de2) ->
+ * fprintf fmt "%a->%a" pp de1 pp de2
+ * | Dtuple delist ->
+ * fprintf fmt "(%a)" (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "*")
+ * pp) delist
+ * | Dlink de ->
+ * pp fmt de
+ * | Dunivar ->
+ * fprintf fmt "'%s" (name_of_delay de.did) *)
diff --git a/src/delay.mli b/src/delay.mli
index d5132c7a..57e4739b 100644
--- a/src/delay.mli
+++ b/src/delay.mli
@@ -10,8 +10,8 @@ and delay_desc =
| Dunivar
(* Polymorphic type variable *)
-val new_var: unit -> t
+val new_var : unit -> t
-val new_univar: unit -> t
+val new_univar : unit -> t
-val new_delay: delay_desc -> t
+val new_delay : delay_desc -> t
diff --git a/src/delay_predef.ml b/src/delay_predef.ml
index a9aa36b2..1e8692a4 100644
--- a/src/delay_predef.ml
+++ b/src/delay_predef.ml
@@ -12,9 +12,11 @@
open Delay
(** Base types and predefined operator types. *)
-let delay_zero () = new_univar ()
+(* XXX: UNUSED *)
+(* let delay_zero () = new_univar () *)
-let delay_un = new_delay Dundef
+(* XXX: UNUSED *)
+(* let delay_un = new_delay Dundef *)
let delay_nullary_poly_op =
let univ = new_univar () in
diff --git a/src/delay_predef.mli b/src/delay_predef.mli
index 8f323305..d9dd4ec9 100644
--- a/src/delay_predef.mli
+++ b/src/delay_predef.mli
@@ -1,4 +1,7 @@
-val delay_nullary_poly_op: Delay.t
-val delay_unary_poly_op: Delay.t
-val delay_binary_poly_op: Delay.t
-val delay_ternary_poly_op: Delay.t
+val delay_nullary_poly_op : Delay.t
+
+val delay_unary_poly_op : Delay.t
+
+val delay_binary_poly_op : Delay.t
+
+val delay_ternary_poly_op : Delay.t
diff --git a/src/dune b/src/dune
index 4a73229b..1289854a 100644
--- a/src/dune
+++ b/src/dune
@@ -142,6 +142,7 @@
(name verifier_register)
(package lustrec)
(wrapped false)
+ (modules_without_implementation verifierType)
(modules verifierList verifierType)
(libraries lustrec_interface))
diff --git a/src/error.mli b/src/error.mli
index 0d5695ae..0dffec45 100644
--- a/src/error.mli
+++ b/src/error.mli
@@ -13,8 +13,10 @@ type t =
exception Error of Location.t * t
-val return_code: t -> int
+val return_code : t -> int
-val pp: Format.formatter -> t -> unit
-val pp_error: Location.t -> (Format.formatter -> unit) -> unit
-val pp_warning: Location.t -> (Format.formatter -> unit) -> unit
+val pp : Format.formatter -> t -> unit
+
+val pp_error : Location.t -> (Format.formatter -> unit) -> unit
+
+val pp_warning : Location.t -> (Format.formatter -> unit) -> unit
diff --git a/src/features/machine_types/machine_types.ml b/src/features/machine_types/machine_types.ml
index 25d82ca4..c5e9d7a5 100644
--- a/src/features/machine_types/machine_types.ml
+++ b/src/features/machine_types/machine_types.ml
@@ -281,8 +281,7 @@ end
module Typing = Typing.Make (MTypes) (ConvTypes)
(* Associate to each (node_id, var_id) its machine type *)
-let machine_type_table : (var_decl, MTypes.t) Hashtbl.t =
- Hashtbl.create 13
+let machine_type_table : (var_decl, MTypes.t) Hashtbl.t = Hashtbl.create 13
(* Store the node signatures, with machine types when available *)
let typing_env = ref Env.initial
@@ -335,8 +334,8 @@ let pp_c_var_type fmt v =
(************** Checking types ******************)
let erroneous_annotation loc =
- Format.eprintf "Invalid annotation for machine_type at loc %a@."
- Location.pp loc;
+ Format.eprintf "Invalid annotation for machine_type at loc %a@." Location.pp
+ loc;
assert false
let valid_subtype subtype typ =
diff --git a/src/global.ml b/src/global.ml
index d9c43e37..df1118a0 100644
--- a/src/global.ml
+++ b/src/global.ml
@@ -4,19 +4,21 @@ let type_env : Types.t Env.t ref = ref Env.initial
let clock_env : Clocks.t Env.t ref = ref Env.initial
(*Basic_library.clock_env *)
-let basename = ref ""
+(* XXX: UNUSED *)
+(* let basename = ref "" *)
let main_node = ref ""
-module TypeEnv = struct
- let lookup_value ident = Env.lookup_value !type_env ident
-
- let exists_value ident = Env.exists_value !type_env ident
-
- let iter f = Env.iter !type_env f
-
- let pp pp_fun fmt () = Env.pp pp_fun fmt !type_env
-end
+(* XXX: UNUSED *)
+(* module TypeEnv = struct
+ * let lookup_value ident = Env.lookup_value !type_env ident
+ *
+ * let exists_value ident = Env.exists_value !type_env ident
+ *
+ * let iter f = Env.iter !type_env f
+ *
+ * let pp pp_fun fmt () = Env.pp pp_fun fmt !type_env
+ * end *)
let initialize () = main_node := !Options.main_node
diff --git a/src/global.mli b/src/global.mli
index 49d2f8de..3228633f 100644
--- a/src/global.mli
+++ b/src/global.mli
@@ -1,5 +1,7 @@
-val type_env: Types.t Env.t ref
-val clock_env: Clocks.t Env.t ref
-val main_node: string ref
+val type_env : Types.t Env.t ref
-val initialize: unit -> unit
+val clock_env : Clocks.t Env.t ref
+
+val main_node : string ref
+
+val initialize : unit -> unit
diff --git a/src/inliner.ml b/src/inliner.ml
index bfa3507d..f731378f 100644
--- a/src/inliner.ml
+++ b/src/inliner.ml
@@ -374,146 +374,147 @@ let inline_all_calls node nodes =
let nd = match node.top_decl_desc with Node nd -> nd | _ -> assert false in
{ node with top_decl_desc = Node (inline_node nd nodes) }
-let witness filename main_name orig inlined (* type_env clock_env *) =
- let loc = Location.dummy in
- let rename_local_node nodes prefix id =
- if List.exists (check_node_name id) nodes then prefix ^ id else id
- in
- let main_orig_node =
- match (List.find (check_node_name main_name) orig).top_decl_desc with
- | Node nd ->
- nd
- | _ ->
- assert false
- in
-
- let orig_rename = rename_local_node orig "orig_" in
- let inlined_rename = rename_local_node inlined "inlined_" in
- let identity x = x in
- let is_node top =
- match top.top_decl_desc with Node _ -> true | _ -> false
- in
- let orig =
- rename_prog orig_rename (* f_node *) identity (* f_var *) identity
- (* f_const *) orig
- in
- let inlined = rename_prog inlined_rename identity identity inlined in
- let nodes_origs, others = List.partition is_node orig in
- let nodes_inlined, _ = List.partition is_node inlined in
-
- (* One ok_i boolean variable per output var *)
- let nb_outputs = List.length main_orig_node.node_outputs in
- let ok_ident = "OK" in
- let ok_i =
- List.map
- (fun id ->
- mkvar_decl loc
- ( Format.sprintf "%s_%i" ok_ident id,
- { ty_dec_desc = Tydec_bool; ty_dec_loc = loc },
- { ck_dec_desc = Ckdec_any; ck_dec_loc = loc },
- false,
- None,
- None ))
- (Utils.enumerate nb_outputs)
- in
-
- (* OK = ok_1 and ok_2 and ... ok_n-1 *)
- let ok_output =
- mkvar_decl loc
- ( ok_ident,
- { ty_dec_desc = Tydec_bool; ty_dec_loc = loc },
- { ck_dec_desc = Ckdec_any; ck_dec_loc = loc },
- false,
- None,
- None )
- in
- let main_ok_expr =
- let mkv x = mkexpr loc (Expr_ident x) in
- match ok_i with
- | [] ->
- assert false
- | [ x ] ->
- mkv x.var_id
- | hd :: tl ->
- List.fold_left
- (fun accu elem -> mkpredef_call loc "&&" [ mkv elem.var_id; accu ])
- (mkv hd.var_id) tl
- in
-
- (* Building main node *)
- let ok_i_eq =
- {
- eq_loc = loc;
- eq_lhs = List.map (fun v -> v.var_id) ok_i;
- eq_rhs =
- (let inputs =
- expr_of_expr_list loc
- (List.map
- (fun v -> mkexpr loc (Expr_ident v.var_id))
- main_orig_node.node_inputs)
- in
- let call_orig =
- mkexpr loc (Expr_appl ("orig_" ^ main_name, inputs, None))
- in
- let call_inlined =
- mkexpr loc (Expr_appl ("inlined_" ^ main_name, inputs, None))
- in
- let args = mkexpr loc (Expr_tuple [ call_orig; call_inlined ]) in
- mkexpr loc (Expr_appl ("=", args, None)));
- }
- in
- let ok_eq = { eq_loc = loc; eq_lhs = [ ok_ident ]; eq_rhs = main_ok_expr } in
- let main_node =
- {
- node_id = "check";
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = main_orig_node.node_inputs;
- node_outputs = [ ok_output ];
- node_locals = ok_i;
- node_gencalls = [];
- node_checks = [];
- node_asserts = [];
- node_stmts = [ Eq ok_i_eq; Eq ok_eq ];
- node_dec_stateless = false;
- node_stateless = None;
- node_spec =
- Some
- (Contract
- (mk_contract_guarantees None
- (mkeexpr loc (mkexpr loc (Expr_ident ok_ident)))));
- node_annot = [];
- node_iscontract = true;
- }
- in
- let main =
- [
- {
- top_decl_desc = Node main_node;
- top_decl_loc = loc;
- top_decl_owner = filename;
- top_decl_itf = false;
- };
- ]
- in
- let new_prog = others @ nodes_origs @ nodes_inlined @ main in
-
- (* let _ = Typing.type_prog type_env new_prog in let _ =
- Clock_calculus.clock_prog clock_env new_prog in *)
- let witness_file =
- Options_management.get_witness_dir filename ^ "/" ^ "inliner_witness.lus"
- in
- let witness_out = open_out witness_file in
- let witness_fmt = Format.formatter_of_out_channel witness_out in
- List.iter
- (fun vdecl ->
- Typing.try_unify Type_predef.type_bool vdecl.var_type vdecl.var_loc)
- (ok_output :: ok_i);
- Format.fprintf witness_fmt
- "(* Generated lustre file to check validity of inlining process *)@.";
- Printers.pp_prog witness_fmt new_prog;
- Format.fprintf witness_fmt "@.";
- ()
+(* XXX: UNUSED *)
+(* let witness filename main_name orig inlined (\* type_env clock_env *\) =
+ * let loc = Location.dummy in
+ * let rename_local_node nodes prefix id =
+ * if List.exists (check_node_name id) nodes then prefix ^ id else id
+ * in
+ * let main_orig_node =
+ * match (List.find (check_node_name main_name) orig).top_decl_desc with
+ * | Node nd ->
+ * nd
+ * | _ ->
+ * assert false
+ * in
+ *
+ * let orig_rename = rename_local_node orig "orig_" in
+ * let inlined_rename = rename_local_node inlined "inlined_" in
+ * let identity x = x in
+ * let is_node top =
+ * match top.top_decl_desc with Node _ -> true | _ -> false
+ * in
+ * let orig =
+ * rename_prog orig_rename (\* f_node *\) identity (\* f_var *\) identity
+ * (\* f_const *\) orig
+ * in
+ * let inlined = rename_prog inlined_rename identity identity inlined in
+ * let nodes_origs, others = List.partition is_node orig in
+ * let nodes_inlined, _ = List.partition is_node inlined in
+ *
+ * (\* One ok_i boolean variable per output var *\)
+ * let nb_outputs = List.length main_orig_node.node_outputs in
+ * let ok_ident = "OK" in
+ * let ok_i =
+ * List.map
+ * (fun id ->
+ * mkvar_decl loc
+ * ( Format.sprintf "%s_%i" ok_ident id,
+ * { ty_dec_desc = Tydec_bool; ty_dec_loc = loc },
+ * { ck_dec_desc = Ckdec_any; ck_dec_loc = loc },
+ * false,
+ * None,
+ * None ))
+ * (Utils.enumerate nb_outputs)
+ * in
+ *
+ * (\* OK = ok_1 and ok_2 and ... ok_n-1 *\)
+ * let ok_output =
+ * mkvar_decl loc
+ * ( ok_ident,
+ * { ty_dec_desc = Tydec_bool; ty_dec_loc = loc },
+ * { ck_dec_desc = Ckdec_any; ck_dec_loc = loc },
+ * false,
+ * None,
+ * None )
+ * in
+ * let main_ok_expr =
+ * let mkv x = mkexpr loc (Expr_ident x) in
+ * match ok_i with
+ * | [] ->
+ * assert false
+ * | [ x ] ->
+ * mkv x.var_id
+ * | hd :: tl ->
+ * List.fold_left
+ * (fun accu elem -> mkpredef_call loc "&&" [ mkv elem.var_id; accu ])
+ * (mkv hd.var_id) tl
+ * in
+ *
+ * (\* Building main node *\)
+ * let ok_i_eq =
+ * {
+ * eq_loc = loc;
+ * eq_lhs = List.map (fun v -> v.var_id) ok_i;
+ * eq_rhs =
+ * (let inputs =
+ * expr_of_expr_list loc
+ * (List.map
+ * (fun v -> mkexpr loc (Expr_ident v.var_id))
+ * main_orig_node.node_inputs)
+ * in
+ * let call_orig =
+ * mkexpr loc (Expr_appl ("orig_" ^ main_name, inputs, None))
+ * in
+ * let call_inlined =
+ * mkexpr loc (Expr_appl ("inlined_" ^ main_name, inputs, None))
+ * in
+ * let args = mkexpr loc (Expr_tuple [ call_orig; call_inlined ]) in
+ * mkexpr loc (Expr_appl ("=", args, None)));
+ * }
+ * in
+ * let ok_eq = { eq_loc = loc; eq_lhs = [ ok_ident ]; eq_rhs = main_ok_expr } in
+ * let main_node =
+ * {
+ * node_id = "check";
+ * node_type = Types.new_var ();
+ * node_clock = Clocks.new_var true;
+ * node_inputs = main_orig_node.node_inputs;
+ * node_outputs = [ ok_output ];
+ * node_locals = ok_i;
+ * node_gencalls = [];
+ * node_checks = [];
+ * node_asserts = [];
+ * node_stmts = [ Eq ok_i_eq; Eq ok_eq ];
+ * node_dec_stateless = false;
+ * node_stateless = None;
+ * node_spec =
+ * Some
+ * (Contract
+ * (mk_contract_guarantees None
+ * (mkeexpr loc (mkexpr loc (Expr_ident ok_ident)))));
+ * node_annot = [];
+ * node_iscontract = true;
+ * }
+ * in
+ * let main =
+ * [
+ * {
+ * top_decl_desc = Node main_node;
+ * top_decl_loc = loc;
+ * top_decl_owner = filename;
+ * top_decl_itf = false;
+ * };
+ * ]
+ * in
+ * let new_prog = others @ nodes_origs @ nodes_inlined @ main in
+ *
+ * (\* let _ = Typing.type_prog type_env new_prog in let _ =
+ * Clock_calculus.clock_prog clock_env new_prog in *\)
+ * let witness_file =
+ * Options_management.get_witness_dir filename ^ "/" ^ "inliner_witness.lus"
+ * in
+ * let witness_out = open_out witness_file in
+ * let witness_fmt = Format.formatter_of_out_channel witness_out in
+ * List.iter
+ * (fun vdecl ->
+ * Typing.try_unify Type_predef.type_bool vdecl.var_type vdecl.var_loc)
+ * (ok_output :: ok_i);
+ * Format.fprintf witness_fmt
+ * "(\* Generated lustre file to check validity of inlining process *\)@.";
+ * Printers.pp_prog witness_fmt new_prog;
+ * Format.fprintf witness_fmt "@.";
+ * () *)
(* xx *)
let global_inline prog (*type_env clock_env*) =
@@ -546,26 +547,27 @@ let global_inline prog (*type_env clock_env*) =
assert false) prog res type_env clock_env ); *)
res
-let pp_inline_calls fmt prog =
- let local_anns = Annotations.get_expr_annotations keyword in
- let nodes_with_anns =
- List.fold_left (fun accu (k, _) -> ISet.add k accu) ISet.empty local_anns
- in
- Format.(fprintf fmt "@[<v 0>Inlined expresssions in node (by tags):@ %a@]"
- (pp_print_list ~pp_sep:pp_print_nothing (fun fmt top ->
- match top.top_decl_desc with
- | Node nd when ISet.mem nd.node_id nodes_with_anns ->
- fprintf fmt "%s: {@[<v 0>%a}@]@ " nd.node_id
- (pp_print_list pp_print_int)
- (List.fold_left
- (fun accu (id, tag) ->
- if id = nd.node_id then tag :: accu else accu)
- [] local_anns)
- (* | Node nd -> Format.fprintf fmt "%s: no inline annotations"
- nd.node_id *)
- | _ ->
- ())))
- prog
+(* XXX: UNUSED *)
+(* let pp_inline_calls fmt prog =
+ * let local_anns = Annotations.get_expr_annotations keyword in
+ * let nodes_with_anns =
+ * List.fold_left (fun accu (k, _) -> ISet.add k accu) ISet.empty local_anns
+ * in
+ * Format.(fprintf fmt "@[<v 0>Inlined expresssions in node (by tags):@ %a@]"
+ * (pp_print_list ~pp_sep:pp_print_nothing (fun fmt top ->
+ * match top.top_decl_desc with
+ * | Node nd when ISet.mem nd.node_id nodes_with_anns ->
+ * fprintf fmt "%s: {@[<v 0>%a}@]@ " nd.node_id
+ * (pp_print_list pp_print_int)
+ * (List.fold_left
+ * (fun accu (id, tag) ->
+ * if id = nd.node_id then tag :: accu else accu)
+ * [] local_anns)
+ * (\* | Node nd -> Format.fprintf fmt "%s: no inline annotations"
+ * nd.node_id *\)
+ * | _ ->
+ * ())))
+ * prog *)
let local_inline prog (* type_env clock_env *) =
Log.report ~level:2 (fun fmt -> Format.fprintf fmt ".. @[<v 2>Inlining@,");
diff --git a/src/inliner.mli b/src/inliner.mli
index 53902b18..a257d505 100644
--- a/src/inliner.mli
+++ b/src/inliner.mli
@@ -1,7 +1,8 @@
open Utils
open Lustre_types
-val global_inline: program_t -> program_t
-val local_inline: program_t -> program_t
+val global_inline : program_t -> program_t
-val keyword: ident list
+val local_inline : program_t -> program_t
+
+val keyword : ident list
diff --git a/src/log.ml b/src/log.ml
index 8acc242a..17d7892d 100644
--- a/src/log.ml
+++ b/src/log.ml
@@ -9,8 +9,8 @@
(* *)
(********************************************************************)
-let report ?plugin:(modulename = "") ?(verbose_level = (fun () -> !Options.verbose_level) ())
- ~level p =
+let report ?plugin:(modulename = "")
+ ?(verbose_level = (fun () -> !Options.verbose_level) ()) ~level p =
if verbose_level >= level then
if modulename = "" then Format.eprintf "%t" p
else Format.eprintf "[%s] @[%t@]" modulename p
diff --git a/src/log.mli b/src/log.mli
index 3a728392..65fb8319 100644
--- a/src/log.mli
+++ b/src/log.mli
@@ -1 +1,6 @@
-val report: ?plugin:string -> ?verbose_level:int -> level:int -> (Format.formatter -> unit) -> unit
+val report :
+ ?plugin:string ->
+ ?verbose_level:int ->
+ level:int ->
+ (Format.formatter -> unit) ->
+ unit
diff --git a/src/lusic.mli b/src/lusic.mli
index e2068d98..edfe04a4 100644
--- a/src/lusic.mli
+++ b/src/lusic.mli
@@ -3,12 +3,12 @@ open Lustre_types
type t = { obsolete : bool; from_lusi : bool; contents : program_t }
(* extracts a header from a program representing module owner = dirname/basename *)
-val extract_header: string -> string -> program_t -> top_decl list
+val extract_header : string -> string -> program_t -> top_decl list
(* read and decode a header from a file *)
-val read_lusic: string -> string -> t
+val read_lusic : string -> string -> t
(* encode and write a header in a file *)
-val write_lusic: bool -> program_t -> string -> string -> unit
+val write_lusic : bool -> program_t -> string -> string -> unit
-val check_obsolete: t -> string -> unit
+val check_obsolete : t -> string -> unit
diff --git a/src/lustre_live.mli b/src/lustre_live.mli
index ae457e82..1d3eeccf 100644
--- a/src/lustre_live.mli
+++ b/src/lustre_live.mli
@@ -1,6 +1,8 @@
open Utils
open Lustre_types
-val inter_live_i_with: ident -> int -> var_decl list -> var_decl list
-val set_live_of: ident -> var_decl list -> var_decl list -> eq list -> unit
-val existential_vars: ident -> int -> eq -> var_decl list -> var_decl list
+val inter_live_i_with : ident -> int -> var_decl list -> var_decl list
+
+val set_live_of : ident -> var_decl list -> var_decl list -> eq list -> unit
+
+val existential_vars : ident -> int -> eq -> var_decl list -> var_decl list
diff --git a/src/lustre_types.mli b/src/lustre_types.mli
index 438158e6..07b760b4 100644
--- a/src/lustre_types.mli
+++ b/src/lustre_types.mli
@@ -225,5 +225,6 @@ type spec_types =
| LocalContract of contract_desc
| TopContract of top_decl list
-val tag_true: label
-val tag_false: label
+val tag_true : label
+
+val tag_false : label
diff --git a/src/machine_code.ml b/src/machine_code.ml
index 1400cbe8..3c6ad318 100644
--- a/src/machine_code.ml
+++ b/src/machine_code.ml
@@ -120,8 +120,8 @@ 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
diff --git a/src/machine_code_common.ml b/src/machine_code_common.ml
index a904c679..8b652574 100644
--- a/src/machine_code_common.ml
+++ b/src/machine_code_common.ml
@@ -219,9 +219,7 @@ let pp_step m fmt s =
s.step_asserts
let pp_static_call fmt (node, args) =
- fprintf fmt "%s<%a>" (node_name node)
- (pp_comma_list Dimension.pp)
- args
+ fprintf fmt "%s<%a>" (node_name node) (pp_comma_list Dimension.pp) args
let pp_instance fmt (o1, o2) = fprintf fmt "(%s, %a)" o1 pp_static_call o2
diff --git a/src/machine_code_common.mli b/src/machine_code_common.mli
index 2434f8e1..b920f694 100644
--- a/src/machine_code_common.mli
+++ b/src/machine_code_common.mli
@@ -2,11 +2,7 @@ open Utils
open Lustre_types
open Machine_code_types
-val pp_val :
- machine_t ->
- Format.formatter ->
- value_t ->
- unit
+val pp_val : machine_t -> Format.formatter -> value_t -> unit
val is_memory : machine_t -> var_decl -> bool
@@ -16,10 +12,7 @@ val is_output : machine_t -> var_decl -> bool
val is_const_value : value_t -> bool
-val get_const_assign :
- machine_t ->
- var_decl ->
- value_t
+val get_const_assign : machine_t -> var_decl -> value_t
val get_stateless_status_node : node_desc -> bool * bool
@@ -29,94 +22,53 @@ val get_stateless_status_top_decl : top_decl -> bool * bool
val is_stateless : machine_t -> bool
-val mk_val :
- value_t_desc ->
- Types.t ->
- value_t
+val mk_val : value_t_desc -> Types.t -> value_t
val vdecl_to_val : var_decl -> value_t
-val vdecls_to_vals :
- var_decl list -> value_t list
+val vdecls_to_vals : var_decl list -> value_t list
val id_to_tag : ident -> value_t
val mk_conditional :
- ?lustre_eq:eq ->
- value_t ->
- instr_t list ->
- instr_t list ->
- instr_t
+ ?lustre_eq:eq -> value_t -> instr_t list -> instr_t list -> instr_t
val mk_branch :
- ?lustre_eq:eq ->
- value_t ->
- (label * instr_t list) list ->
- instr_t
+ ?lustre_eq:eq -> value_t -> (label * instr_t list) list -> instr_t
val mk_branch' :
- ?lustre_eq:eq ->
- var_decl ->
- (label * instr_t list) list ->
- instr_t
+ ?lustre_eq:eq -> var_decl -> (label * instr_t list) list -> instr_t
-val mk_assign :
- ?lustre_eq:eq ->
- var_decl ->
- value_t ->
- instr_t
+val mk_assign : ?lustre_eq:eq -> var_decl -> value_t -> instr_t
val empty_machine : machine_t
val arrow_machine : machine_t
-val new_instance :
- top_decl -> tag -> ident
+val new_instance : top_decl -> tag -> ident
-val value_of_dimension :
- machine_t ->
- Dimension.t ->
- value_t
+val value_of_dimension : machine_t -> Dimension.t -> value_t
val dimension_of_value : value_t -> Dimension.t
-val pp_instr :
- machine_t ->
- Format.formatter ->
- instr_t ->
- unit
+val pp_instr : machine_t -> Format.formatter -> instr_t -> unit
-val pp_instrs :
- machine_t ->
- Format.formatter ->
- instr_t list ->
- unit
+val pp_instrs : machine_t -> Format.formatter -> instr_t list -> unit
val pp_machines : Format.formatter -> machine_t list -> unit
-val get_machine_opt :
- machine_t list ->
- string ->
- machine_t option
+val get_machine_opt : machine_t list -> string -> machine_t option
(* Same function but fails if no such a machine exists *)
-val get_machine :
- machine_t list -> string -> machine_t
+val get_machine : machine_t list -> string -> machine_t
-val get_node_def :
- string -> machine_t -> node_desc
+val get_node_def : string -> machine_t -> node_desc
-val join_guards_list :
- instr_t list -> instr_t list
+val join_guards_list : instr_t list -> instr_t list
val machine_vars : machine_t -> var_decl list
-val get_machine: machine_t list -> ident -> machine_t
-
module PrintSpec : sig
val pp_spec :
- machine_t ->
- Format.formatter ->
- value_t Spec_types.formula_t ->
- unit
+ machine_t -> Format.formatter -> value_t Spec_types.formula_t -> unit
end
diff --git a/src/main_lustre_testgen.ml b/src/main_lustre_testgen.ml
index a1bbb0a1..1b958e7a 100644
--- a/src/main_lustre_testgen.ml
+++ b/src/main_lustre_testgen.ml
@@ -23,12 +23,13 @@ let extensions = [ ".lus" ]
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@ }@]@.@?"
- (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
- mutation_loc))
- mutation_list)
+ Format.(
+ 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
+ mutation_loc))
+ mutation_list)
let testgen_source dirname basename extension =
let source_name = dirname ^ "/" ^ basename ^ extension in
diff --git a/src/modules.mli b/src/modules.mli
index cb792261..e6801547 100644
--- a/src/modules.mli
+++ b/src/modules.mli
@@ -17,5 +17,4 @@ val load :
program_t * dep_t list * (Types.t Env.t * Clocks.t Env.t)
(* Returns an updated env with the type/clock declaration of the program *)
-val get_envs_from_top_decls :
- program_t -> Types.t Env.t * Clocks.t Env.t
+val get_envs_from_top_decls : program_t -> Types.t Env.t * Clocks.t Env.t
diff --git a/src/mutation.ml b/src/mutation.ml
index b20ab15b..b250d156 100644
--- a/src/mutation.ml
+++ b/src/mutation.ml
@@ -13,29 +13,40 @@ open Format
let random_seed = ref 0
-let threshold_delay = 95
+(* XXX: UNUSED *)
+(* let threshold_delay = 95 *)
-let threshold_inc_int = 97
+(* XXX: UNUSED *)
+(* let threshold_inc_int = 97 *)
-let threshold_dec_int = 97
+(* XXX: UNUSED *)
+(* let threshold_dec_int = 97 *)
-let threshold_random_int = 96
+(* XXX: UNUSED *)
+(* let threshold_random_int = 96 *)
-let threshold_switch_int = 100
+(* XXX: UNUSED *)
+(* let threshold_switch_int = 100 *)
(* not implemented yet *)
-let threshold_random_float = 100
+(* XXX: UNUSED *)
+(* let threshold_random_float = 100 *)
(* not used yet *)
-let threshold_negate_bool_var = 95
+(* XXX: UNUSED *)
+(* let threshold_negate_bool_var = 95 *)
-let threshold_arith_op = 95
+(* XXX: UNUSED *)
+(* let threshold_arith_op = 95 *)
-let threshold_rel_op = 95
+(* XXX: UNUSED *)
+(* let threshold_rel_op = 95 *)
-let threshold_bool_op = 95
+(* XXX: UNUSED *)
+(* let threshold_bool_op = 95 *)
-let int_consts = ref []
+(* XXX: UNUSED *)
+(* let int_consts = ref [] *)
let rename_app id =
if List.mem id Basic_library.internal_funs || !Options.no_mutation_suffix then
@@ -79,7 +90,8 @@ let rel_op = [ "<"; "<="; ">"; ">="; "!="; "=" ]
let ops = arith_op @ bool_op @ rel_op
-let all_ops = "not" :: ops
+(* XXX: UNUSED *)
+(* let all_ops = "not" :: ops *)
let empty_records =
{
@@ -177,218 +189,219 @@ let compute_records prog =
(* Random mutation *)
(*****************************************************************)
-let check_mut e1 e2 =
- let rec eq e1 e2 =
- match e1.expr_desc, e2.expr_desc with
- | Expr_const c1, Expr_const c2 ->
- c1 = c2
- | Expr_ident id1, Expr_ident id2 ->
- id1 = id2
- | Expr_tuple el1, Expr_tuple el2 ->
- List.length el1 = List.length el2 && List.for_all2 eq el1 el2
- | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) ->
- eq i1 i2 && eq t1 t2 && eq e1 e2
- | Expr_arrow (x1, y1), Expr_arrow (x2, y2) ->
- eq x1 x2 && eq y1 y2
- | Expr_pre e1, Expr_pre e2 ->
- eq e1 e2
- | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) ->
- id1 = id2 && eq e1 e2
- | _ ->
- false
- in
- if not (eq e1 e2) then Some (e1, e2) else None
-
-let mk_cst_expr c = mkexpr Location.dummy (Expr_const c)
-
-let rdm_mutate_int i =
- if Random.int 100 > threshold_inc_int then i + 1
- else if Random.int 100 > threshold_dec_int then i - 1
- else if Random.int 100 > threshold_random_int then Random.int 10
- else if Random.int 100 > threshold_switch_int then
- let idx = Random.int (List.length !int_consts) in
- List.nth !int_consts idx
- else i
-
-let rdm_mutate_real r =
- if Random.int 100 > threshold_random_float then
- (* interval [0, bound] for random values *)
- let bound = 10 in
- (* max number of digits after comma *)
- let digits = 5 in
- (* number of digits after comma *)
- let shift = Random.int (digits + 1) in
- let eshift = 10. ** float_of_int shift in
- let i = Random.int (1 + (bound * int_of_float eshift)) in
- let f = float_of_int i /. eshift in
- Real.create (string_of_int i) shift (string_of_float f)
- else r
-
-let rdm_mutate_op op =
- match op with
- | ("+" | "-" | "*" | "/") when Random.int 100 > threshold_arith_op ->
- let filtered = List.filter (fun x -> x <> op) [ "+"; "-"; "*"; "/" ] in
- List.nth filtered (Random.int 3)
- | ("&&" | "||" | "xor" | "impl") when Random.int 100 > threshold_bool_op ->
- let filtered =
- List.filter (fun x -> x <> op) [ "&&"; "||"; "xor"; "impl" ]
- in
- List.nth filtered (Random.int 3)
- | ("<" | "<=" | ">" | ">=" | "!=" | "=")
- when Random.int 100 > threshold_rel_op ->
- let filtered =
- List.filter (fun x -> x <> op) [ "<"; "<="; ">"; ">="; "!="; "=" ]
- in
- List.nth filtered (Random.int 5)
- | _ ->
- op
-
-let rdm_mutate_var expr =
- if Types.is_bool_type expr.expr_type then
- (* if Random.int 100 > threshold_negate_bool_var then *)
- let new_e = mkpredef_call expr.expr_loc "not" [ expr ] in
- Some (expr, new_e), new_e
- (* else *)
- (* expr *)
- else None, expr
-
-let rdm_mutate_pre orig_expr =
- let new_e = Expr_pre orig_expr in
- Some (orig_expr, { orig_expr with expr_desc = new_e }), new_e
-
-let rdm_mutate_const_value c =
- match c with
- | Const_int i ->
- Const_int (rdm_mutate_int i)
- | Const_real r ->
- Const_real (rdm_mutate_real r)
- | Const_array _
- | Const_string _
- | Const_modeid _
- | Const_struct _
- | Const_tag _ ->
- c
-
-let rdm_mutate_const c =
- let new_const = rdm_mutate_const_value c.const_value in
- let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
- mut, { c with const_value = new_const }
-
-let select_in_list list rdm_mutate_elem =
- let selected = Random.int (List.length list) in
- let mutation_opt, new_list, _ =
- List.fold_right
- (fun elem (mutation_opt, res, cpt) ->
- if cpt = selected then
- let mutation, new_elem = rdm_mutate_elem elem in
- Some mutation, new_elem :: res, cpt + 1
- else mutation_opt, elem :: res, cpt + 1)
- list (None, [], 0)
- in
- match mutation_opt with Some mut -> mut, new_list | _ -> assert false
-
-let rec rdm_mutate_expr expr =
- let mk_e d = { expr with expr_desc = d } in
- match expr.expr_desc with
- | Expr_ident _ ->
- rdm_mutate_var expr
- | Expr_const c ->
- let new_const = rdm_mutate_const_value c in
- let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
- mut, mk_e (Expr_const new_const)
- | Expr_tuple l ->
- let mut, l' = select_in_list l rdm_mutate_expr in
- mut, mk_e (Expr_tuple l')
- | Expr_ite (i, t, e) -> (
- let mut, l = select_in_list [ i; t; e ] rdm_mutate_expr in
- match l with
- | [ i'; t'; e' ] ->
- mut, mk_e (Expr_ite (i', t', e'))
- | _ ->
- assert false)
- | Expr_arrow (e1, e2) -> (
- let mut, l = select_in_list [ e1; e2 ] rdm_mutate_expr in
- match l with
- | [ e1'; e2' ] ->
- mut, mk_e (Expr_arrow (e1', e2'))
- | _ ->
- assert false)
- | Expr_pre e ->
- let select_pre = Random.bool () in
- if select_pre then
- let mut, new_expr = rdm_mutate_pre expr in
- mut, mk_e new_expr
- else
- let mut, e' = rdm_mutate_expr e in
- mut, mk_e (Expr_pre e')
- | Expr_appl (op_id, args, r) ->
- let select_op = Random.bool () in
- if select_op then
- let new_op_id = rdm_mutate_op op_id in
- let new_e = mk_e (Expr_appl (new_op_id, args, r)) in
- let mut = check_mut expr new_e in
- mut, new_e
- else
- let mut, new_args = rdm_mutate_expr args in
- mut, mk_e (Expr_appl (op_id, new_args, r))
- (* Other constructs are kept. | Expr_fby of expr * expr | Expr_array of expr
- list | Expr_access of expr * Dimension.dim_expr | Expr_power of expr *
- Dimension.dim_expr | Expr_when of expr * ident * label | Expr_merge of
- ident * (label * expr) list | Expr_uclock of expr * int | Expr_dclock of
- expr * int | Expr_phclock of expr * rat *)
- | _ ->
- None, expr
-
-let rdm_mutate_eq eq =
- let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
- mutation, { eq with eq_rhs = new_rhs }
-
-let rnd_mutate_stmt stmt =
- match stmt with
- | Eq eq ->
- let mut, new_eq = rdm_mutate_eq eq in
- report ~level:1 (fun fmt ->
- fprintf fmt "mutation: %a becomes %a@ " Printers.pp_node_eq eq
- Printers.pp_node_eq new_eq);
- mut, Eq new_eq
- | Aut _ ->
- assert false
-
-let rdm_mutate_node nd =
- let mutation, new_node_stmts = select_in_list nd.node_stmts rnd_mutate_stmt in
- mutation, { nd with node_stmts = new_node_stmts }
-
-let rdm_mutate_top_decl td =
- match td.top_decl_desc with
- | Node nd ->
- let mutation, new_node = rdm_mutate_node nd in
- mutation, { td with top_decl_desc = Node new_node }
- | Const cst ->
- let mut, new_cst = rdm_mutate_const cst in
- mut, { td with top_decl_desc = Const new_cst }
- | _ ->
- None, td
-
-(* Create a single mutant with the provided random seed *)
-let rdm_mutate_prog prog = select_in_list prog rdm_mutate_top_decl
-
-let rdm_mutate nb prog =
- let rec iterate nb res =
- incr random_seed;
- if nb <= 0 then res
- else (
- Random.init !random_seed;
- let mutation, new_mutant = rdm_mutate_prog prog in
- match mutation with
- | None ->
- iterate nb res
- | Some mutation ->
- if List.mem_assoc mutation res then iterate nb res
- else (
- report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@ " nb);
- iterate (nb - 1) ((mutation, new_mutant) :: res)))
- in
- iterate nb []
+(* XXX: UNUSED *)
+(* let check_mut e1 e2 =
+ * let rec eq e1 e2 =
+ * match e1.expr_desc, e2.expr_desc with
+ * | Expr_const c1, Expr_const c2 ->
+ * c1 = c2
+ * | Expr_ident id1, Expr_ident id2 ->
+ * id1 = id2
+ * | Expr_tuple el1, Expr_tuple el2 ->
+ * List.length el1 = List.length el2 && List.for_all2 eq el1 el2
+ * | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) ->
+ * eq i1 i2 && eq t1 t2 && eq e1 e2
+ * | Expr_arrow (x1, y1), Expr_arrow (x2, y2) ->
+ * eq x1 x2 && eq y1 y2
+ * | Expr_pre e1, Expr_pre e2 ->
+ * eq e1 e2
+ * | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) ->
+ * id1 = id2 && eq e1 e2
+ * | _ ->
+ * false
+ * in
+ * if not (eq e1 e2) then Some (e1, e2) else None
+ *
+ * let mk_cst_expr c = mkexpr Location.dummy (Expr_const c)
+ *
+ * let rdm_mutate_int i =
+ * if Random.int 100 > threshold_inc_int then i + 1
+ * else if Random.int 100 > threshold_dec_int then i - 1
+ * else if Random.int 100 > threshold_random_int then Random.int 10
+ * else if Random.int 100 > threshold_switch_int then
+ * let idx = Random.int (List.length !int_consts) in
+ * List.nth !int_consts idx
+ * else i
+ *
+ * let rdm_mutate_real r =
+ * if Random.int 100 > threshold_random_float then
+ * (\* interval [0, bound] for random values *\)
+ * let bound = 10 in
+ * (\* max number of digits after comma *\)
+ * let digits = 5 in
+ * (\* number of digits after comma *\)
+ * let shift = Random.int (digits + 1) in
+ * let eshift = 10. ** float_of_int shift in
+ * let i = Random.int (1 + (bound * int_of_float eshift)) in
+ * let f = float_of_int i /. eshift in
+ * Real.create (string_of_int i) shift (string_of_float f)
+ * else r
+ *
+ * let rdm_mutate_op op =
+ * match op with
+ * | ("+" | "-" | "*" | "/") when Random.int 100 > threshold_arith_op ->
+ * let filtered = List.filter (fun x -> x <> op) [ "+"; "-"; "*"; "/" ] in
+ * List.nth filtered (Random.int 3)
+ * | ("&&" | "||" | "xor" | "impl") when Random.int 100 > threshold_bool_op ->
+ * let filtered =
+ * List.filter (fun x -> x <> op) [ "&&"; "||"; "xor"; "impl" ]
+ * in
+ * List.nth filtered (Random.int 3)
+ * | ("<" | "<=" | ">" | ">=" | "!=" | "=")
+ * when Random.int 100 > threshold_rel_op ->
+ * let filtered =
+ * List.filter (fun x -> x <> op) [ "<"; "<="; ">"; ">="; "!="; "=" ]
+ * in
+ * List.nth filtered (Random.int 5)
+ * | _ ->
+ * op
+ *
+ * let rdm_mutate_var expr =
+ * if Types.is_bool_type expr.expr_type then
+ * (\* if Random.int 100 > threshold_negate_bool_var then *\)
+ * let new_e = mkpredef_call expr.expr_loc "not" [ expr ] in
+ * Some (expr, new_e), new_e
+ * (\* else *\)
+ * (\* expr *\)
+ * else None, expr
+ *
+ * let rdm_mutate_pre orig_expr =
+ * let new_e = Expr_pre orig_expr in
+ * Some (orig_expr, { orig_expr with expr_desc = new_e }), new_e
+ *
+ * let rdm_mutate_const_value c =
+ * match c with
+ * | Const_int i ->
+ * Const_int (rdm_mutate_int i)
+ * | Const_real r ->
+ * Const_real (rdm_mutate_real r)
+ * | Const_array _
+ * | Const_string _
+ * | Const_modeid _
+ * | Const_struct _
+ * | Const_tag _ ->
+ * c
+ *
+ * let rdm_mutate_const c =
+ * let new_const = rdm_mutate_const_value c.const_value in
+ * let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
+ * mut, { c with const_value = new_const }
+ *
+ * let select_in_list list rdm_mutate_elem =
+ * let selected = Random.int (List.length list) in
+ * let mutation_opt, new_list, _ =
+ * List.fold_right
+ * (fun elem (mutation_opt, res, cpt) ->
+ * if cpt = selected then
+ * let mutation, new_elem = rdm_mutate_elem elem in
+ * Some mutation, new_elem :: res, cpt + 1
+ * else mutation_opt, elem :: res, cpt + 1)
+ * list (None, [], 0)
+ * in
+ * match mutation_opt with Some mut -> mut, new_list | _ -> assert false
+ *
+ * let rec rdm_mutate_expr expr =
+ * let mk_e d = { expr with expr_desc = d } in
+ * match expr.expr_desc with
+ * | Expr_ident _ ->
+ * rdm_mutate_var expr
+ * | Expr_const c ->
+ * let new_const = rdm_mutate_const_value c in
+ * let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
+ * mut, mk_e (Expr_const new_const)
+ * | Expr_tuple l ->
+ * let mut, l' = select_in_list l rdm_mutate_expr in
+ * mut, mk_e (Expr_tuple l')
+ * | Expr_ite (i, t, e) -> (
+ * let mut, l = select_in_list [ i; t; e ] rdm_mutate_expr in
+ * match l with
+ * | [ i'; t'; e' ] ->
+ * mut, mk_e (Expr_ite (i', t', e'))
+ * | _ ->
+ * assert false)
+ * | Expr_arrow (e1, e2) -> (
+ * let mut, l = select_in_list [ e1; e2 ] rdm_mutate_expr in
+ * match l with
+ * | [ e1'; e2' ] ->
+ * mut, mk_e (Expr_arrow (e1', e2'))
+ * | _ ->
+ * assert false)
+ * | Expr_pre e ->
+ * let select_pre = Random.bool () in
+ * if select_pre then
+ * let mut, new_expr = rdm_mutate_pre expr in
+ * mut, mk_e new_expr
+ * else
+ * let mut, e' = rdm_mutate_expr e in
+ * mut, mk_e (Expr_pre e')
+ * | Expr_appl (op_id, args, r) ->
+ * let select_op = Random.bool () in
+ * if select_op then
+ * let new_op_id = rdm_mutate_op op_id in
+ * let new_e = mk_e (Expr_appl (new_op_id, args, r)) in
+ * let mut = check_mut expr new_e in
+ * mut, new_e
+ * else
+ * let mut, new_args = rdm_mutate_expr args in
+ * mut, mk_e (Expr_appl (op_id, new_args, r))
+ * (\* Other constructs are kept. | Expr_fby of expr * expr | Expr_array of expr
+ * list | Expr_access of expr * Dimension.dim_expr | Expr_power of expr *
+ * Dimension.dim_expr | Expr_when of expr * ident * label | Expr_merge of
+ * ident * (label * expr) list | Expr_uclock of expr * int | Expr_dclock of
+ * expr * int | Expr_phclock of expr * rat *\)
+ * | _ ->
+ * None, expr
+ *
+ * let rdm_mutate_eq eq =
+ * let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
+ * mutation, { eq with eq_rhs = new_rhs }
+ *
+ * let rnd_mutate_stmt stmt =
+ * match stmt with
+ * | Eq eq ->
+ * let mut, new_eq = rdm_mutate_eq eq in
+ * report ~level:1 (fun fmt ->
+ * fprintf fmt "mutation: %a becomes %a@ " Printers.pp_node_eq eq
+ * Printers.pp_node_eq new_eq);
+ * mut, Eq new_eq
+ * | Aut _ ->
+ * assert false
+ *
+ * let rdm_mutate_node nd =
+ * let mutation, new_node_stmts = select_in_list nd.node_stmts rnd_mutate_stmt in
+ * mutation, { nd with node_stmts = new_node_stmts }
+ *
+ * let rdm_mutate_top_decl td =
+ * match td.top_decl_desc with
+ * | Node nd ->
+ * let mutation, new_node = rdm_mutate_node nd in
+ * mutation, { td with top_decl_desc = Node new_node }
+ * | Const cst ->
+ * let mut, new_cst = rdm_mutate_const cst in
+ * mut, { td with top_decl_desc = Const new_cst }
+ * | _ ->
+ * None, td
+ *
+ * (\* Create a single mutant with the provided random seed *\)
+ * let rdm_mutate_prog prog = select_in_list prog rdm_mutate_top_decl
+ *
+ * let rdm_mutate nb prog =
+ * let rec iterate nb res =
+ * incr random_seed;
+ * if nb <= 0 then res
+ * else (
+ * Random.init !random_seed;
+ * let mutation, new_mutant = rdm_mutate_prog prog in
+ * match mutation with
+ * | None ->
+ * iterate nb res
+ * | Some mutation ->
+ * if List.mem_assoc mutation res then iterate nb res
+ * else (
+ * report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@ " nb);
+ * iterate (nb - 1) ((mutation, new_mutant) :: res)))
+ * in
+ * iterate nb [] *)
(*****************************************************************)
(* Random mutation *)
@@ -456,24 +469,26 @@ let pp_directive_json fmt d =
Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m
let pp_loc_json fmt (n, eqlhs, l) =
- Format.(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))
-
-let fold_mutate_int i =
- if Random.int 100 > threshold_inc_int then i + 1
- else if Random.int 100 > threshold_dec_int then i - 1
- else if Random.int 100 > threshold_random_int then Random.int 10
- else if Random.int 100 > threshold_switch_int then
- try
- let idx = Random.int (List.length !int_consts) in
- List.nth !int_consts idx
- with _ -> i
- else i
-
-let fold_mutate_float f =
- if Random.int 100 > threshold_random_float then Random.float 10. else f
+ Format.(
+ 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))
+
+(* XXX: UNUSED *)
+(* let fold_mutate_int i =
+ * if Random.int 100 > threshold_inc_int then i + 1
+ * else if Random.int 100 > threshold_dec_int then i - 1
+ * else if Random.int 100 > threshold_random_int then Random.int 10
+ * else if Random.int 100 > threshold_switch_int then
+ * try
+ * let idx = Random.int (List.length !int_consts) in
+ * List.nth !int_consts idx
+ * with _ -> i
+ * else i *)
+
+(* XXX: UNUSED *)
+(* let fold_mutate_float f =
+ * if Random.int 100 > threshold_random_float then Random.float 10. else f *)
let fold_mutate_op op =
(* match op with *)
diff --git a/src/mutation.mli b/src/mutation.mli
index fb7ae649..09dcb289 100644
--- a/src/mutation.mli
+++ b/src/mutation.mli
@@ -10,10 +10,13 @@ type mutant_t =
| DecrIntCst of int
| SwitchIntCst of int * int
-val pp_directive_json: formatter -> mutant_t -> unit
+val pp_directive_json : formatter -> mutant_t -> unit
-val pp_directive: formatter -> mutant_t -> unit
+val pp_directive : formatter -> mutant_t -> unit
-val pp_loc_json: formatter -> ident * ident list * Location.t -> unit
+val pp_loc_json : formatter -> ident * ident list * Location.t -> unit
-val mutate: int -> program_t -> (mutant_t * (ident * ident list * Location.t) * program_t) list
+val mutate :
+ int ->
+ program_t ->
+ (mutant_t * (ident * ident list * Location.t) * program_t) list
diff --git a/src/optimize_machine.ml b/src/optimize_machine.ml
index 2e25139d..f2a09aa7 100644
--- a/src/optimize_machine.ml
+++ b/src/optimize_machine.ml
@@ -16,7 +16,6 @@ open Machine_code_types
open Corelang
open Causality
open Machine_code_common
-open Dimension
module Mpfr = Lustrec_mpfr
let pp_elim m fmt elim =
@@ -70,12 +69,13 @@ and eliminate_expr m elim expr =
| Cst _ | ResetFlag ->
expr
-let eliminate_dim elim dim =
- Dimension.expr_replace_expr
- (fun v ->
- try dimension_of_value (IMap.find v elim)
- with Not_found -> mkdim_ident dim.dim_loc v)
- dim
+(* XXX: UNUSED *)
+(* let eliminate_dim elim dim =
+ * Dimension.expr_replace_expr
+ * (fun v ->
+ * try dimension_of_value (IMap.find v elim)
+ * with Not_found -> mkdim_ident dim.dim_loc v)
+ * dim *)
(* 8th Jan 2016: issues when merging salsa with horn_encoding: The following
functions seem unsused. They have to be adapted to the new type for expr *)
@@ -98,8 +98,7 @@ let rec simplify_cst_expr m offset typ cst =
mk_val (Cst cst) typ
| Index i :: q, Const_array cl when Dimension.is_const i ->
let elt_typ = Types.array_element_type typ in
- simplify_cst_expr m q elt_typ
- (List.nth cl (Dimension.size_const i))
+ 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 ]
@@ -167,8 +166,9 @@ let rec simplify_instr_offset m instr =
and simplify_instrs_offset m instrs = List.map (simplify_instr_offset m) instrs
-let is_scalar_const c =
- match c with Const_real _ | Const_int _ | Const_tag _ -> true | _ -> false
+(* XXX: UNUSED *)
+(* let is_scalar_const c =
+ * match c with Const_real _ | Const_int _ | Const_tag _ -> true | _ -> false *)
(* An instruction v = expr may (and will) be unfolded iff: - either expr is
atomic (no complex expressions, only const, vars and array/struct accesses) -
@@ -567,21 +567,22 @@ and instrs_are_skip instrs = List.for_all instr_is_skip instrs
let instr_cons instr cont = if instr_is_skip instr then cont else instr :: cont
-let rec instr_remove_skip instr cont =
- match get_instr_desc instr with
- | MLocalAssign (i, { value_desc = Var v; _ }) when i = v ->
- cont
- | MStateAssign (i, { value_desc = Var v; _ }) when i = v ->
- cont
- | MBranch (g, hl) ->
- update_instr_desc instr
- (MBranch (g, List.map (fun (h, il) -> h, instrs_remove_skip il []) hl))
- :: cont
- | _ ->
- instr :: cont
-
-and instrs_remove_skip instrs cont =
- List.fold_right instr_remove_skip instrs cont
+(* XXX: UNUSED *)
+(* let rec instr_remove_skip instr cont =
+ * match get_instr_desc instr with
+ * | MLocalAssign (i, { value_desc = Var v; _ }) when i = v ->
+ * cont
+ * | MStateAssign (i, { value_desc = Var v; _ }) when i = v ->
+ * cont
+ * | MBranch (g, hl) ->
+ * update_instr_desc instr
+ * (MBranch (g, List.map (fun (h, il) -> h, instrs_remove_skip il []) hl))
+ * :: cont
+ * | _ ->
+ * instr :: cont
+ *
+ * and instrs_remove_skip instrs cont =
+ * List.fold_right instr_remove_skip instrs cont *)
let rec value_replace_var fvar value =
match value.value_desc with
diff --git a/src/optimize_machine.mli b/src/optimize_machine.mli
index 4f02cf59..be5dbc87 100644
--- a/src/optimize_machine.mli
+++ b/src/optimize_machine.mli
@@ -12,5 +12,9 @@ open Machine_code_types
machines.
The function returns both the (possibly updated) prog as well as the machines *)
-val optimize: Normalization.param_t -> program_t -> Scheduling_type.schedule_report IMap.t ->
- machine_t list -> program_t * machine_t list
+val optimize :
+ Normalization.param_t ->
+ program_t ->
+ Scheduling_type.schedule_report IMap.t ->
+ machine_t list ->
+ program_t * machine_t list
diff --git a/src/optimize_prog.ml b/src/optimize_prog.ml
index 834999e4..b682630a 100644
--- a/src/optimize_prog.ml
+++ b/src/optimize_prog.ml
@@ -79,68 +79,70 @@ let prog_unfold_consts prog =
decl)
prog
+(* XXX: UNUSED *)
(* Distribution of when inside sub-expressions, i.e. (a+b) when c --> a when c +
b when c May increase clock disjointness of variables, which is useful for
code optimization *)
-let apply_stack expr stack =
- List.fold_left
- (fun expr (v, t) -> mkexpr expr.expr_loc (Expr_when (expr, v, t)))
- expr stack
+(* let apply_stack expr stack =
+ * List.fold_left
+ * (fun expr (v, t) -> mkexpr expr.expr_loc (Expr_when (expr, v, t)))
+ * expr stack
+ *
+ * let expr_distribute_when expr =
+ * let rec distrib stack expr =
+ * match expr.expr_desc with
+ * | Expr_const _ | Expr_ident _ | Expr_arrow _ | Expr_fby _ | Expr_pre _ ->
+ * apply_stack expr stack
+ * | Expr_appl (id, _, _) when not (Stateless.check_node (node_from_name id))
+ * ->
+ * apply_stack expr stack
+ * | Expr_ite (c, t, e) ->
+ * let cid = ident_of_expr c in
+ * mkexpr expr.expr_loc
+ * (Expr_merge
+ * ( cid,
+ * [
+ * tag_true, distrib ((cid, tag_true) :: stack) t;
+ * tag_false, distrib ((cid, tag_false) :: stack) e;
+ * ] ))
+ * | Expr_array el ->
+ * { expr with expr_desc = Expr_array (List.map (distrib stack) el) }
+ * | Expr_access (e1, d) ->
+ * { expr with expr_desc = Expr_access (distrib stack e1, d) }
+ * | Expr_power (e1, d) ->
+ * { expr with expr_desc = Expr_power (distrib stack e1, d) }
+ * | Expr_tuple el ->
+ * { expr with expr_desc = Expr_tuple (List.map (distrib stack) el) }
+ * | Expr_when (e', i, l) ->
+ * distrib ((i, l) :: stack) e'
+ * | Expr_merge (i, hl) ->
+ * {
+ * expr with
+ * expr_desc =
+ * Expr_merge (i, List.map (fun (t, h) -> t, distrib stack h) hl);
+ * }
+ * | Expr_appl (id, e', i') ->
+ * { expr with expr_desc = Expr_appl (id, distrib stack e', i') }
+ * in
+ * distrib [] expr
+ *
+ * let eq_distribute_when eq = { eq with eq_rhs = expr_distribute_when eq.eq_rhs }
+ *
+ * let node_distribute_when node =
+ * let eqs, automata = get_node_eqs node in
+ * assert (automata = []);
+ * { node with node_stmts = List.map (fun eq -> Eq (eq_distribute_when eq)) eqs }
+ *
+ * let prog_distribute_when prog =
+ * List.map
+ * (fun decl ->
+ * match decl.top_decl_desc with
+ * | Node nd ->
+ * { decl with top_decl_desc = Node (node_distribute_when nd) }
+ * | _ ->
+ * decl)
+ * prog *)
-let expr_distribute_when expr =
- let rec distrib stack expr =
- match expr.expr_desc with
- | Expr_const _ | Expr_ident _ | Expr_arrow _ | Expr_fby _ | Expr_pre _ ->
- apply_stack expr stack
- | Expr_appl (id, _, _) when not (Stateless.check_node (node_from_name id))
- ->
- apply_stack expr stack
- | Expr_ite (c, t, e) ->
- let cid = ident_of_expr c in
- mkexpr expr.expr_loc
- (Expr_merge
- ( cid,
- [
- tag_true, distrib ((cid, tag_true) :: stack) t;
- tag_false, distrib ((cid, tag_false) :: stack) e;
- ] ))
- | Expr_array el ->
- { expr with expr_desc = Expr_array (List.map (distrib stack) el) }
- | Expr_access (e1, d) ->
- { expr with expr_desc = Expr_access (distrib stack e1, d) }
- | Expr_power (e1, d) ->
- { expr with expr_desc = Expr_power (distrib stack e1, d) }
- | Expr_tuple el ->
- { expr with expr_desc = Expr_tuple (List.map (distrib stack) el) }
- | Expr_when (e', i, l) ->
- distrib ((i, l) :: stack) e'
- | Expr_merge (i, hl) ->
- {
- expr with
- expr_desc =
- Expr_merge (i, List.map (fun (t, h) -> t, distrib stack h) hl);
- }
- | Expr_appl (id, e', i') ->
- { expr with expr_desc = Expr_appl (id, distrib stack e', i') }
- in
- distrib [] expr
-
-let eq_distribute_when eq = { eq with eq_rhs = expr_distribute_when eq.eq_rhs }
-
-let node_distribute_when node =
- let eqs, automata = get_node_eqs node in
- assert (automata = []);
- { node with node_stmts = List.map (fun eq -> Eq (eq_distribute_when eq)) eqs }
-
-let prog_distribute_when prog =
- List.map
- (fun decl ->
- match decl.top_decl_desc with
- | Node nd ->
- { decl with top_decl_desc = Node (node_distribute_when nd) }
- | _ ->
- decl)
- prog
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/optimize_prog.mli b/src/optimize_prog.mli
index 3b481a78..3bd5d3fd 100644
--- a/src/optimize_prog.mli
+++ b/src/optimize_prog.mli
@@ -1,3 +1,3 @@
open Lustre_types
-val prog_unfold_consts: program_t -> program_t
+val prog_unfold_consts : program_t -> program_t
diff --git a/src/options.ml b/src/options.ml
index 7b96237e..10eace28 100644
--- a/src/options.ml
+++ b/src/options.ml
@@ -27,31 +27,29 @@ let ansi = ref false
let check = ref false
-type option_spec =
- | SpecNo
- | SpecACSL
- | SpecC
+type option_spec = SpecNo | SpecACSL | SpecC
let spec = ref SpecNo
-type option_output =
- | OutC
- | OutAda
- | OutJava
- | OutEMF
- | OutHorn
- | OutLustre
+type option_output = OutC | OutAda | OutJava | OutEMF | OutHorn | OutLustre
let output = ref OutC
let pp_output fmt =
- Format.pp_print_string fmt (match !output with
- | OutC -> "C"
- | OutAda -> "Ada"
- | OutJava -> "Java"
- | OutEMF -> "EMF"
- | OutHorn -> "Horn"
- | OutLustre -> "Lustre")
+ Format.pp_print_string fmt
+ (match !output with
+ | OutC ->
+ "C"
+ | OutAda ->
+ "Ada"
+ | OutJava ->
+ "Java"
+ | OutEMF ->
+ "EMF"
+ | OutHorn ->
+ "Horn"
+ | OutLustre ->
+ "Lustre")
let dest_dir = ref "."
@@ -97,8 +95,6 @@ let real_type = ref "double"
let print_prec_double = ref 15
-let print_prec_float = ref 10
-
let sfunction = ref ""
let mauve = ref ""
diff --git a/src/options.mli b/src/options.mli
index 80d63d3b..9e50c772 100644
--- a/src/options.mli
+++ b/src/options.mli
@@ -1,83 +1,86 @@
-val kind2_print: bool ref
-val mpfr: bool ref
-val print_dec_types: bool ref
-val verbose_level: int ref
-val main_node: string ref
-val global_inline: bool ref
-val mpfr_prec: int ref
+val kind2_print : bool ref
-type option_spec =
- | SpecNo
- | SpecACSL
- | SpecC
+val mpfr : bool ref
-val spec: option_spec ref
+val print_dec_types : bool ref
-type option_output =
- | OutC
- | OutAda
- | OutJava
- | OutEMF
- | OutHorn
- | OutLustre
- (* | OutACSL *)
+val verbose_level : int ref
-val output: option_output ref
+val main_node : string ref
-val pp_output: Format.formatter -> unit
+val global_inline : bool ref
-val ansi: bool ref
+val mpfr_prec : int ref
-val int_type: string ref
-val real_type: string ref
+type option_spec = SpecNo | SpecACSL | SpecC
-val optimization: int ref
+val spec : option_spec ref
-val include_dirs: string list ref
+type option_output = OutC | OutAda | OutJava | OutEMF | OutHorn | OutLustre
+(* | OutACSL *)
-val dest_dir: string ref
+val output : option_output ref
-val print_types: bool ref
-val print_clocks: bool ref
-val print_nodes: bool ref
-val print_prec_double: int ref
+val pp_output : Format.formatter -> unit
-val solve_al: bool ref
-val al_nb_max: int ref
+val ansi : bool ref
-val delay_calculus: bool ref
+val int_type : string ref
-val static_mem: bool ref
+val real_type : string ref
-val check: bool ref
+val optimization : int ref
-val lusi: bool ref
+val include_dirs : string list ref
-val traces: bool ref
+val dest_dir : string ref
-val horn_cex: bool ref
-val horn_query: bool ref
+val print_types : bool ref
-val sfunction: string ref
+val print_clocks : bool ref
-val print_reuse: bool ref
+val print_nodes : bool ref
-val const_unfold: bool ref
+val print_prec_double : int ref
-val witnesses: bool ref
+val solve_al : bool ref
-val cpp: bool ref
+val al_nb_max : int ref
-val integer_div_euclidean: bool ref
+val delay_calculus : bool ref
-val mauve: string ref
+val static_mem : bool ref
-val nb_mutants: int ref
+val check : bool ref
-val gen_mcdc: bool ref
+val lusi : bool ref
-val no_mutation_suffix: bool ref
+val traces : bool ref
-val compile_header: bool ref
+val horn_cex : bool ref
-val track_exceptions: bool ref
+val horn_query : bool ref
+
+val sfunction : string ref
+
+val print_reuse : bool ref
+
+val const_unfold : bool ref
+
+val witnesses : bool ref
+
+val cpp : bool ref
+
+val integer_div_euclidean : bool ref
+
+val mauve : string ref
+
+val nb_mutants : int ref
+
+val gen_mcdc : bool ref
+
+val no_mutation_suffix : bool ref
+
+val compile_header : bool ref
+
+val track_exceptions : bool ref
diff --git a/src/options_management.ml b/src/options_management.ml
index 2ad047a9..6339b1ac 100644
--- a/src/options_management.ml
+++ b/src/options_management.ml
@@ -17,8 +17,8 @@ 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
diff --git a/src/options_management.mli b/src/options_management.mli
index 23101d0a..6aa7d50c 100644
--- a/src/options_management.mli
+++ b/src/options_management.mli
@@ -1,18 +1,21 @@
type options_spec = (string * Arg.spec * string) list
-val core_dependency: string -> string
-val plugin_opt: string * (unit -> unit) * (Format.formatter -> unit) *
- options_spec -> options_spec
+val core_dependency : string -> string
-val name_dependency: ('a * string) -> string -> string
-val get_witness_dir: string -> string
+val plugin_opt :
+ string * (unit -> unit) * (Format.formatter -> unit) * options_spec ->
+ options_spec
-val verifier_opt: string * (unit -> unit) * options_spec -> options_spec
+val name_dependency : 'a * string -> string -> string
-val lustrec_options: options_spec
+val get_witness_dir : string -> string
-val lustrev_options: options_spec
+val verifier_opt : string * (unit -> unit) * options_spec -> options_spec
-val lustret_options: options_spec
+val lustrec_options : options_spec
-val setup: unit -> unit
+val lustrev_options : options_spec
+
+val lustret_options : options_spec
+
+val setup : unit -> unit
diff --git a/src/parsers/parse.ml b/src/parsers/parse.ml
index eadffe6e..eed9fd32 100644
--- a/src/parsers/parse.ml
+++ b/src/parsers/parse.ml
@@ -96,8 +96,7 @@ let reparse (module Lexer : LEXER) ?orig_loc filename start src =
(* Expand away the $i keywords that might appear in the message. *)
(* let message = E.expand (get src checkpoint) message in *)
(* Show these three components. *)
- eprintf "@[<v>%aSyntax error %s.@,%s@]@." Location.pp loc indication
- message;
+ eprintf "@[<v>%aSyntax error %s.@,%s@]@." Location.pp loc indication message;
raise Error
in
(* Run the parser. *)
@@ -113,8 +112,7 @@ let parse (module Lexer : LEXER) ?orig_loc filename src lexbuf start_mono
let loc =
match orig_loc with Some loc' -> Location.shift loc' loc | _ -> loc
in
- eprintf "@[<v>%aSyntax error.@,%a@]@." Location.pp loc Lexer.pp_error
- err;
+ eprintf "@[<v>%aSyntax error.@,%a@]@." Location.pp loc Lexer.pp_error err;
raise Error
| Parser_lustre.Error ->
reparse (module Lexer) ?orig_loc filename start_incr src
diff --git a/src/parsers/parse.mli b/src/parsers/parse.mli
index 11479a52..e57e2ef2 100644
--- a/src/parsers/parse.mli
+++ b/src/parsers/parse.mli
@@ -12,11 +12,17 @@ module type LEXER = sig
val pp_error : Format.formatter -> error -> unit
end
-module Inc: module type of Parser_lustre_table.Incremental
+module Inc : module type of Parser_lustre_table.Incremental
-val parse: (module LEXER) -> ?orig_loc:Location.t -> Location.filename -> string ->
+val parse :
+ (module LEXER) ->
+ ?orig_loc:Location.t ->
+ Location.filename ->
+ string ->
Lexing.lexbuf ->
((Lexing.lexbuf -> Parser_lustre.token) -> Lexing.lexbuf -> 'a) ->
- (Lexing.position -> 'b Parser_lustre_table.MenhirInterpreter.checkpoint) -> 'a
+ (Lexing.position -> 'b Parser_lustre_table.MenhirInterpreter.checkpoint) ->
+ 'a
-val parse_filename: (module LEXER) -> Location.filename -> start_symbol -> Lustre_types.program_t
+val parse_filename :
+ (module LEXER) -> Location.filename -> start_symbol -> Lustre_types.program_t
diff --git a/src/pathConditions.mli b/src/pathConditions.mli
index 75e3ac52..5bcfdd3b 100644
--- a/src/pathConditions.mli
+++ b/src/pathConditions.mli
@@ -1 +1 @@
-val mcdc: Lustre_types.program_t -> Lustre_types.program_t
+val mcdc : Lustre_types.program_t -> Lustre_types.program_t
diff --git a/src/plugins/mpfr/lustrec_mpfr.ml b/src/plugins/mpfr/lustrec_mpfr.ml
index 09387dfb..849faa9a 100644
--- a/src/plugins/mpfr/lustrec_mpfr.ml
+++ b/src/plugins/mpfr/lustrec_mpfr.ml
@@ -26,7 +26,8 @@ let mpfr_rnd () = "MPFR_RNDN"
let mpfr_prec () = !Options.mpfr_prec
-let inject_id = "MPFRId"
+(* XXX: UNUSED *)
+(* let inject_id = "MPFRId" *)
let inject_copy_id = "mpfr_set"
@@ -41,17 +42,19 @@ let mpfr_t = "mpfr_t"
let unfoldable_value value =
not (Types.is_real_type value.value_type && is_const_value value)
-let inject_id_id expr =
- let e = mkpredef_call expr.expr_loc inject_id [ expr ] in
- { e with expr_type = Type_predef.type_real; expr_clock = expr.expr_clock }
+(* XXX: UNUSED *)
+(* let inject_id_id expr =
+ * let e = mkpredef_call expr.expr_loc inject_id [ expr ] in
+ * { 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
(mpfr_rnd ())
-let inject_assign expr =
- let e = mkpredef_call expr.expr_loc inject_copy_id [ expr ] in
- { e with expr_type = Type_predef.type_real; expr_clock = expr.expr_clock }
+(* XXX: UNUSED *)
+(* let inject_assign expr =
+ * let e = mkpredef_call expr.expr_loc inject_copy_id [ expr ] in
+ * { 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
diff --git a/src/plugins/mpfr/lustrec_mpfr.mli b/src/plugins/mpfr/lustrec_mpfr.mli
index 1b1ba893..dea715c1 100644
--- a/src/plugins/mpfr/lustrec_mpfr.mli
+++ b/src/plugins/mpfr/lustrec_mpfr.mli
@@ -3,19 +3,30 @@ open Format
open Lustre_types
open Machine_code_types
-val unfoldable_value: Machine_code_types.value_t -> bool
-val inject_prog: program_t -> program_t
+val unfoldable_value : Machine_code_types.value_t -> bool
-val mpfr_module: top_decl
+val inject_prog : program_t -> program_t
-val mpfr_t: string
+val mpfr_module : top_decl
-val mpfr_rnd: unit -> string
-val mpfr_prec: unit -> int
+val mpfr_t : string
-val is_homomorphic_fun: ident -> bool
+val mpfr_rnd : unit -> string
-val pp_inject_init: (formatter -> 'a -> unit) -> formatter -> 'a -> unit
-val pp_inject_clear: (formatter -> 'a -> unit) -> formatter -> 'a -> unit
-val pp_inject_assign: (formatter -> value_t -> unit) -> formatter -> value_t * value_t -> unit
-val pp_inject_real: (formatter -> 'a -> unit) -> (formatter -> 'b -> unit) -> formatter -> 'a * 'b -> unit
+val mpfr_prec : unit -> int
+
+val is_homomorphic_fun : ident -> bool
+
+val pp_inject_init : (formatter -> 'a -> unit) -> formatter -> 'a -> unit
+
+val pp_inject_clear : (formatter -> 'a -> unit) -> formatter -> 'a -> unit
+
+val pp_inject_assign :
+ (formatter -> value_t -> unit) -> formatter -> value_t * value_t -> unit
+
+val pp_inject_real :
+ (formatter -> 'a -> unit) ->
+ (formatter -> 'b -> unit) ->
+ formatter ->
+ 'a * 'b ->
+ unit
diff --git a/src/plugins/pluginList.mli b/src/plugins/pluginList.mli
index ed6f294e..5be008f2 100644
--- a/src/plugins/pluginList.mli
+++ b/src/plugins/pluginList.mli
@@ -1,2 +1,3 @@
-val registered: (module PluginType.S) list ref
-val plugins: unit -> (module PluginType.S) list
+val registered : (module PluginType.S) list ref
+
+val plugins : unit -> (module PluginType.S) list
diff --git a/src/plugins/pluginType.mli b/src/plugins/pluginType.mli
index 402f1b2d..f127f7b6 100644
--- a/src/plugins/pluginType.mli
+++ b/src/plugins/pluginType.mli
@@ -22,4 +22,4 @@ module type S = sig
val c_backend_main_loop_body_suffix : Format.formatter -> unit -> unit
end
-module Default: S
+module Default : S
diff --git a/src/plugins/plugins.mli b/src/plugins/plugins.mli
index 964e9ca9..17dad3f6 100644
--- a/src/plugins/plugins.mli
+++ b/src/plugins/plugins.mli
@@ -2,15 +2,17 @@ open Utils
open Lustre_types
open Machine_code_types
-val inline_annots: (ident -> ident) -> expr_annot list -> expr_annot list
+val inline_annots : (ident -> ident) -> expr_annot list -> expr_annot list
-val check_force_stateful: unit -> bool
+val check_force_stateful : unit -> bool
-val c_backend_main_loop_body_prefix: string -> string -> Format.formatter -> unit -> unit
-val c_backend_main_loop_body_suffix: Format.formatter -> unit -> unit
+val c_backend_main_loop_body_prefix :
+ string -> string -> Format.formatter -> unit -> unit
-val refine_machine_code: program_t -> machine_t list -> machine_t list
+val c_backend_main_loop_body_suffix : Format.formatter -> unit -> unit
-val init: unit -> unit
+val refine_machine_code : program_t -> machine_t list -> machine_t list
-val options: unit -> Options_management.options_spec
+val init : unit -> unit
+
+val options : unit -> Options_management.options_spec
diff --git a/src/plugins/scopes/scopes.ml b/src/plugins/scopes/scopes.ml
index 6a797705..a5fb18b1 100644
--- a/src/plugins/scopes/scopes.ml
+++ b/src/plugins/scopes/scopes.ml
@@ -59,10 +59,13 @@ let rec compute_scopes ?(first = true) prog root_node : scope_t list =
with Not_found -> []
let pp_scopes =
- Format.(pp_print_list (fun fmt ((_, v) as s) ->
- 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))
+ Format.(
+ pp_print_list (fun fmt ((_, v) as s) ->
+ 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))
(* let print_path fmt p = *)
(* Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt
@@ -178,8 +181,7 @@ let extract_scopes_defs scopes =
assert false
in
List.map
- (fun (sl, scope) ->
- String.concat "." sl, scope_path_name scope "main_mem.")
+ (fun (sl, scope) -> String.concat "." sl, scope_path_name scope "main_mem.")
scopes
let pp_scopes_files _basename _mname fmt scopes =
@@ -319,10 +321,13 @@ let process_scopes main_node prog machines =
List.filter
(fun sl ->
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@."
- (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ".") pp_print_string)
- sl);
+ (if not res then
+ Format.(
+ eprintf "Scope %a is cancelled due to variable removal@."
+ (pp_print_list
+ ~pp_sep:(fun fmt () -> pp_print_string fmt ".")
+ pp_print_string)
+ sl));
res)
selected_scopes
in
diff --git a/src/plugins/scopes/scopes.mli b/src/plugins/scopes/scopes.mli
index 9c9a3332..4fac288a 100644
--- a/src/plugins/scopes/scopes.mli
+++ b/src/plugins/scopes/scopes.mli
@@ -10,6 +10,6 @@ end
(* (variable, node name, node instance) *)
type scope_t = (var_decl * string * string option) list * var_decl
-val compute_scopes: ?first:bool -> program_t -> ident -> scope_t list
+val compute_scopes : ?first:bool -> program_t -> ident -> scope_t list
-val pp_scopes: Format.formatter -> scope_t list -> unit
+val pp_scopes : Format.formatter -> scope_t list -> unit
diff --git a/src/printers.ml b/src/printers.ml
index 9cb24356..1b206f5b 100644
--- a/src/printers.ml
+++ b/src/printers.ml
@@ -18,18 +18,19 @@ let kind2_language_cst = [ "initial" ]
let kind2_protect id =
if List.mem id kind2_language_cst then "_KIND2_PROTECT_" ^ id else id
+(* XXX: UNUSED *)
(* Prints [v] as [pp_fun] would do, but adds a backslash at each end of line,
following the C convention for multiple lines macro *)
-let pp_as_c_macro pp_fun fmt v =
- let formatter_out_funs = pp_get_formatter_out_functions fmt () in
- let macro_newline () =
- formatter_out_funs.out_string "\\" 0 1;
- formatter_out_funs.out_newline ()
- in
- pp_set_formatter_out_functions fmt
- { formatter_out_funs with out_newline = macro_newline };
- pp_fun fmt v;
- pp_set_formatter_out_functions fmt formatter_out_funs
+(* let pp_as_c_macro pp_fun fmt v =
+ * let formatter_out_funs = pp_get_formatter_out_functions fmt () in
+ * let macro_newline () =
+ * formatter_out_funs.out_string "\\" 0 1;
+ * formatter_out_funs.out_newline ()
+ * in
+ * pp_set_formatter_out_functions fmt
+ * { formatter_out_funs with out_newline = macro_newline };
+ * pp_fun fmt v;
+ * pp_set_formatter_out_functions fmt formatter_out_funs *)
let rec pp_var_struct_type_field fmt (label, tdesc) =
fprintf fmt "%a : %a;" pp_print_string label pp_var_type_dec_desc tdesc
@@ -52,9 +53,7 @@ and pp_var_type_dec_desc fmt tdesc =
| Tydec_enum id_list ->
fprintf fmt "enum {%a }" (pp_comma_list pp_print_string) id_list
| Tydec_struct f_list ->
- fprintf fmt "struct {%a }"
- (pp_print_list pp_var_struct_type_field)
- f_list
+ fprintf fmt "struct {%a }" (pp_print_list pp_var_struct_type_field) f_list
| Tydec_array (s, t) ->
fprintf fmt "%a^%a" pp_var_type_dec_desc t Dimension.pp s
@@ -102,8 +101,9 @@ and pp_const fmt c =
| Const_tag t ->
pp_print_string fmt t
| Const_array ca ->
- fprintf fmt "[%a]" (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ",")
- pp_const) ca
+ fprintf fmt "[%a]"
+ (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ",") pp_const)
+ ca
| Const_struct fl ->
fprintf fmt "{%a }" (pp_print_list pp_struct_const_field) fl
(* used only for annotations *)
@@ -119,8 +119,11 @@ let pp_annot_key fmt kwds =
| [ x ] ->
pp_print_string fmt x
| _ ->
- fprintf fmt "/%a/" (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "/")
- pp_print_string) kwds
+ fprintf fmt "/%a/"
+ (pp_print_list
+ ~pp_sep:(fun fmt () -> pp_print_string fmt "/")
+ pp_print_string)
+ kwds
let pp_kind2_when fmt (id, l) =
if l = "true" then fprintf fmt "%s" id
@@ -171,8 +174,8 @@ let rec pp_expr fmt expr =
Format.fprintf fmt "%t: %a" pp Types.print_ty expr.expr_type
else pp fmt)
-and pp_tuple fmt el = pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ",")
- pp_expr fmt el
+and pp_tuple fmt el =
+ pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ",") pp_expr fmt el
and pp_handler fmt (t, h) = fprintf fmt "(%s -> %a)" t pp_expr h
@@ -300,8 +303,11 @@ and pp_s_function fmt expr_ann =
| [ x ] ->
pp_print_string fmt x
| _ ->
- fprintf fmt "%a" (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "/")
- pp_print_string) kwds)
+ fprintf fmt "%a"
+ (pp_print_list
+ ~pp_sep:(fun fmt () -> pp_print_string fmt "/")
+ pp_print_string)
+ kwds)
pp_sf_value ee
in
pp_print_list pp_annot fmt expr_ann.annots
@@ -354,9 +360,7 @@ let pp_until fmt (_, expr, 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
+ 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
@@ -369,9 +373,7 @@ let rec pp_handler fmt handler =
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_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
@@ -381,8 +383,7 @@ and pp_node_stmts fmt stmts =
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
@@ -390,7 +391,8 @@ and pp_node_eqs fmt eqs = pp_print_list pp_node_eq fmt eqs
let pp_typedef fmt ty =
fprintf fmt "type %s = %a;" ty.tydef_id pp_var_type_dec_desc ty.tydef_desc
-let pp_typedec fmt ty = fprintf fmt "type %s;" ty.tydec_id
+(* XXX: UNUSED *)
+(* let pp_typedec fmt ty = fprintf fmt "type %s;" ty.tydec_id *)
(* let rec pp_var_type fmt ty = *)
(* fprintf fmt "%a" (match ty.tdesc with *)
@@ -433,9 +435,7 @@ let pp_spec fmt spec =
pp_expr fmt e))
fmt spec.consts;
- pp_print_list
- (fun fmt s -> pp_spec_stmt fmt s)
- fmt spec.stmts;
+ 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;
@@ -445,11 +445,9 @@ let pp_spec fmt spec =
pp_print_list
(fun fmt mode ->
fprintf fmt "mode %s (@[<v 0>%a@ %a@]);" mode.mode_id
- (pp_print_list (fun fmt r ->
- fprintf fmt "require %a;" pp_eexpr r))
+ (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))
+ (pp_print_list (fun fmt r -> fprintf fmt "ensure %a;" pp_eexpr r))
mode.ensure)
fmt spec.modes;
pp_print_list
@@ -540,8 +538,7 @@ let pp_node fmt nd =
()
| _ ->
fprintf fmt "@[<v 4>check@ %a@]@ "
- (pp_print_list (fun fmt d ->
- fprintf fmt "%a" Dimension.pp d))
+ (pp_print_list (fun fmt d -> fprintf fmt "%a" Dimension.pp d))
checks)
nd.node_checks;
(* Body *)
@@ -591,8 +588,9 @@ let pp_imported_node fmt ind =
let pp_const_decl fmt cdecl =
fprintf fmt "%s = %a;" cdecl.const_id pp_const cdecl.const_value
-let pp_const_decl_list fmt clist =
- pp_print_list pp_const_decl fmt clist
+(* XXX: UNUSED *)
+(* let pp_const_decl_list fmt clist =
+ * pp_print_list pp_const_decl fmt clist *)
let pp_decl fmt decl =
match decl.top_decl_desc with
@@ -676,12 +674,13 @@ let pp_lusi_header fmt basename prog =
List.iter (fprintf fmt "%a@ " pp_lusi) prog;
fprintf fmt "@]@."
-let pp_offset fmt offset =
- match offset with
- | Index i ->
- fprintf fmt "[%a]" Dimension.pp i
- | Field f ->
- fprintf fmt ".%s" f
+(* XXX: UNUSED *)
+(* let pp_offset fmt offset =
+ * match offset with
+ * | Index i ->
+ * fprintf fmt "[%a]" Dimension.pp i
+ * | Field f ->
+ * fprintf fmt ".%s" f *)
let pp_node_list fmt prog =
Format.fprintf fmt "@[<h 2>%a@]"
diff --git a/src/printers.mli b/src/printers.mli
index d852a03b..fc0ae33f 100644
--- a/src/printers.mli
+++ b/src/printers.mli
@@ -1,24 +1,44 @@
open Format
open Lustre_types
-val pp_expr: formatter -> expr -> unit
-val pp_eexpr: formatter -> eexpr -> unit
-val pp_node: formatter -> node_desc -> unit
-val pp_const: formatter -> constant -> unit
-val pp_var: formatter -> var_decl -> unit
-val pp_var_name: formatter -> var_decl -> unit
-val pp_node_eq: formatter -> eq -> unit
-val pp_node_eqs: formatter -> eq list -> unit
-val pp_node_stmts: formatter -> statement list -> unit
-val pp_spec: formatter -> contract_desc -> unit
-val pp_expr_annot: formatter -> expr_annot -> unit
-val pp_s_function: formatter -> expr_annot -> unit
-val pp_short_decl: formatter -> top_decl -> unit
-val pp_const_decl: formatter -> const_desc -> unit
-val pp_var_type_dec_desc: formatter -> type_dec_desc -> unit
-val pp_typedef: formatter -> typedef_desc -> unit
-val pp_prog: formatter -> program_t -> unit
-val pp_prog_short: formatter -> program_t -> unit
-val pp_quantifiers: formatter -> quantifier_type * var_decl list -> unit
-val pp_node_list: formatter -> top_decl list -> unit
-val pp_lusi_header: formatter -> string -> program_t -> unit
+val pp_expr : formatter -> expr -> unit
+
+val pp_eexpr : formatter -> eexpr -> unit
+
+val pp_node : formatter -> node_desc -> unit
+
+val pp_const : formatter -> constant -> unit
+
+val pp_var : formatter -> var_decl -> unit
+
+val pp_var_name : formatter -> var_decl -> unit
+
+val pp_node_eq : formatter -> eq -> unit
+
+val pp_node_eqs : formatter -> eq list -> unit
+
+val pp_node_stmts : formatter -> statement list -> unit
+
+val pp_spec : formatter -> contract_desc -> unit
+
+val pp_expr_annot : formatter -> expr_annot -> unit
+
+val pp_s_function : formatter -> expr_annot -> unit
+
+val pp_short_decl : formatter -> top_decl -> unit
+
+val pp_const_decl : formatter -> const_desc -> unit
+
+val pp_var_type_dec_desc : formatter -> type_dec_desc -> unit
+
+val pp_typedef : formatter -> typedef_desc -> unit
+
+val pp_prog : formatter -> program_t -> unit
+
+val pp_prog_short : formatter -> program_t -> unit
+
+val pp_quantifiers : formatter -> quantifier_type * var_decl list -> unit
+
+val pp_node_list : formatter -> top_decl list -> unit
+
+val pp_lusi_header : formatter -> string -> program_t -> unit
diff --git a/src/scheduling.ml b/src/scheduling.ml
index 7fd6ed10..726f9201 100644
--- a/src/scheduling.ml
+++ b/src/scheduling.ml
@@ -84,17 +84,18 @@ let topological_sort eq_equiv g =
IdentDepGraph.clear g;
!sorted
+(* XXX: UNUSED *)
(* Filters out normalization variables and renames instance variables to keep
things readable, in a case of a dependency error *)
-let filter_original n vl =
- List.fold_right
- (fun v res ->
- if ExprDep.is_instance_var v then
- Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res
- else
- let vdecl = get_node_var v n in
- if vdecl.var_orig then v :: res else res)
- vl []
+(* let filter_original n vl =
+ * List.fold_right
+ * (fun v res ->
+ * if ExprDep.is_instance_var v then
+ * Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res
+ * else
+ * let vdecl = get_node_var v n in
+ * if vdecl.var_orig then v :: res else res)
+ * vl [] *)
let eq_equiv eq_equiv_hash v1 v2 =
try Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2
@@ -179,9 +180,7 @@ let pp_eq_schedule fmt vl =
| [ v ] ->
Format.pp_print_string fmt v
| _ ->
- Format.fprintf fmt "(%a)"
- (Format.pp_comma_list Format.pp_print_string)
- vl
+ Format.fprintf fmt "(%a)" (Format.pp_comma_list Format.pp_print_string) vl
let pp_schedule fmt node_schs =
IMap.iter
@@ -222,8 +221,8 @@ let pp_warning_unused fmt node_schs =
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 vu.var_loc)
+ " Warning: variable '%s' seems unused@, %a@,@," u Location.pp
+ vu.var_loc)
unused)
node_schs
diff --git a/src/scheduling.mli b/src/scheduling.mli
index 998bd942..e048264d 100644
--- a/src/scheduling.mli
+++ b/src/scheduling.mli
@@ -3,14 +3,23 @@ open Format
open Lustre_types
open Scheduling_type
-val schedule_node: node_desc -> schedule_report
-val schedule_prog: program_t -> program_t * schedule_report IMap.t
-val remove_prog_inlined_locals: 'a IMap.t IMap.t -> schedule_report IMap.t -> schedule_report IMap.t
-val compute_prog_reuse_table: schedule_report IMap.t -> (ident, var_decl) Hashtbl.t IMap.t
+val schedule_node : node_desc -> schedule_report
-val sort_equations_from_schedule: eq list -> ident list list -> eq list * ident list
+val schedule_prog : program_t -> program_t * schedule_report IMap.t
-val pp_warning_unused: formatter -> schedule_report IMap.t -> unit
-val pp_schedule: formatter -> schedule_report IMap.t -> unit
-val pp_fanin_table: formatter -> schedule_report IMap.t -> unit
-val pp_dep_graph: formatter -> schedule_report IMap.t -> unit
+val remove_prog_inlined_locals :
+ 'a IMap.t IMap.t -> schedule_report IMap.t -> schedule_report IMap.t
+
+val compute_prog_reuse_table :
+ schedule_report IMap.t -> (ident, var_decl) Hashtbl.t IMap.t
+
+val sort_equations_from_schedule :
+ eq list -> ident list list -> eq list * ident list
+
+val pp_warning_unused : formatter -> schedule_report IMap.t -> unit
+
+val pp_schedule : formatter -> schedule_report IMap.t -> unit
+
+val pp_fanin_table : formatter -> schedule_report IMap.t -> unit
+
+val pp_dep_graph : formatter -> schedule_report IMap.t -> unit
diff --git a/src/sortProg.ml b/src/sortProg.ml
index 29f8ad94..d36d91f0 100644
--- a/src/sortProg.ml
+++ b/src/sortProg.ml
@@ -50,7 +50,8 @@ let sort prog =
Log.report ~level:3 (fun fmt ->
Format.fprintf fmt "@ @[<v 2>.. ordered list of declarations:@ %a@]@ "
- (Format.pp_print_list Printers.pp_short_decl) sorted);
+ (Format.pp_print_list Printers.pp_short_decl)
+ sorted);
not_nodes @ sorted
let sort_nodes_locals prog =
@@ -58,10 +59,15 @@ let sort_nodes_locals prog =
(fun top ->
match top.top_decl_desc with
| Node nd ->
- { top with
- top_decl_desc = Node
- { nd with
- node_locals = Causality.VarClockDep.sort nd.node_locals }}
+ {
+ top with
+ top_decl_desc =
+ Node
+ {
+ nd with
+ node_locals = Causality.VarClockDep.sort nd.node_locals;
+ };
+ }
| _ ->
top)
prog
diff --git a/src/sortProg.mli b/src/sortProg.mli
index 0e614642..6b10cd42 100644
--- a/src/sortProg.mli
+++ b/src/sortProg.mli
@@ -1,4 +1,5 @@
open Lustre_types
-val sort_nodes_locals: program_t -> program_t
-val sort: program_t -> program_t
+val sort_nodes_locals : program_t -> program_t
+
+val sort : program_t -> program_t
diff --git a/src/spec.mli b/src/spec.mli
index ed915864..ff8eab59 100644
--- a/src/spec.mli
+++ b/src/spec.mli
@@ -1,3 +1,3 @@
open Lustre_types
-val enforce_spec_prog: program_t -> program_t
+val enforce_spec_prog : program_t -> program_t
diff --git a/src/spec_common.mli b/src/spec_common.mli
index 5d285ca5..df43a864 100644
--- a/src/spec_common.mli
+++ b/src/spec_common.mli
@@ -2,18 +2,26 @@ open Utils
open Lustre_types
open Spec_types
-val mk_conditional_tr: 'a -> 'a formula_t -> 'a formula_t -> 'a formula_t
+val mk_conditional_tr : 'a -> 'a formula_t -> 'a formula_t -> 'a formula_t
-val mk_branch_tr: var_decl -> (ident * 'a formula_t) list -> 'a formula_t
+val mk_branch_tr : var_decl -> (ident * 'a formula_t) list -> 'a formula_t
-val mk_assign_tr: var_decl -> 'a -> 'a formula_t
+val mk_assign_tr : var_decl -> 'a -> 'a formula_t
-val mk_memory_pack: ?i:int -> ?inst:ident -> ident -> 'a formula_t
+val mk_memory_pack : ?i:int -> ?inst:ident -> ident -> 'a formula_t
-val mk_transition: ?mems:ISet.t -> ?insts:ident IMap.t -> ?r:'a -> ?i:int -> ?inst:ident -> ident -> 'a list -> 'a formula_t
+val mk_transition :
+ ?mems:ISet.t ->
+ ?insts:ident IMap.t ->
+ ?r:'a ->
+ ?i:int ->
+ ?inst:ident ->
+ ident ->
+ 'a list ->
+ 'a formula_t
-val mk_state_variable_pack: var_decl -> 'a formula_t
+val mk_state_variable_pack : var_decl -> 'a formula_t
-val mk_state_assign_tr: var_decl -> 'a -> 'a formula_t
+val mk_state_assign_tr : var_decl -> 'a -> 'a formula_t
-val red: 'a formula_t -> 'a formula_t
+val red : 'a formula_t -> 'a formula_t
diff --git a/src/spec_types.ml b/src/spec_types.ml
index 4980309b..e39974cf 100644
--- a/src/spec_types.ml
+++ b/src/spec_types.ml
@@ -14,8 +14,7 @@ type ('a, _) expression_t =
| Memory : register_t -> ('a, left_v) expression_t
(** TODO: why moving this elsewhere makes the exhaustiveness check fail? *)
-let type_of_l_value : type a. (a, left_v) expression_t -> Types.t =
- function
+let type_of_l_value : type a. (a, left_v) expression_t -> Types.t = function
| Var v ->
v.var_type
| Memory ResetFlag ->
diff --git a/src/spec_types.mli b/src/spec_types.mli
index 8301141d..c557a720 100644
--- a/src/spec_types.mli
+++ b/src/spec_types.mli
@@ -13,7 +13,7 @@ type ('a, _) expression_t =
| Var : var_decl -> ('a, left_v) expression_t
| Memory : register_t -> ('a, left_v) expression_t
-val type_of_l_value: ('a, left_v) expression_t -> Types.t
+val type_of_l_value : ('a, left_v) expression_t -> Types.t
type 'a predicate_t =
| Transition :
diff --git a/src/splitting.mli b/src/splitting.mli
index 96c139b4..10986aa2 100644
--- a/src/splitting.mli
+++ b/src/splitting.mli
@@ -1,5 +1,5 @@
open Lustre_types
-val tuple_split_eq: eq -> eq list
+val tuple_split_eq : eq -> eq list
-val tuple_split_eq_list: eq list -> eq list
+val tuple_split_eq_list : eq list -> eq list
diff --git a/src/tools/importer/vhdl_deriving_yojson.ml b/src/tools/importer/vhdl_deriving_yojson.ml
index 56f919b7..d7b21d0b 100644
--- a/src/tools/importer/vhdl_deriving_yojson.ml
+++ b/src/tools/importer/vhdl_deriving_yojson.ml
@@ -1,14 +1,15 @@
-let base_types =
- [
- "integer";
- "character";
- "bit";
- "real";
- "natural";
- "positive";
- "std_logic";
- "std_logic_vector";
- ]
+(* XXX: UNUSED *)
+(* let base_types =
+ * [
+ * "integer";
+ * "character";
+ * "bit";
+ * "real";
+ * "natural";
+ * "positive";
+ * "std_logic";
+ * "std_logic_vector";
+ * ] *)
type vhdl_type_t =
| Base of string
@@ -23,14 +24,16 @@ type vhdl_type_t =
(* Constants *)
(************************************************************************************)
+(* XXX: UNUSED *)
(* Std_logic values : 'U': uninitialized. This signal hasn't been set yet. 'X':
unknown. Impossible to determine this value/result. '0': logic 0 '1': logic 1
'Z': High Impedance 'W': Weak signal, can't tell if it should be 0 or 1. 'L':
Weak signal that should probably go to 0 'H': Weak signal that should
probably go to 1 '-': Don't care. *)
-let std_logic_cst = [ "U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
+(* let std_logic_cst = [ "U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ] *)
-let literal_base = [ "B"; "O"; "X"; "UB"; "UO"; "UX"; "SB"; "SO"; "SX"; "D" ]
+(* XXX: UNUSED *)
+(* let literal_base = [ "B"; "O"; "X"; "UB"; "UO"; "UX"; "SB"; "SO"; "SX"; "D" ] *)
(* Prefix of CstLiteral *)
(* TODO: do we need more constructors ? *)
@@ -83,21 +86,26 @@ type 'basetype vhdl_type_attributes_t =
| TAttStringArg of { id : string; arg : string }
[@@deriving yojson { strict = false }]
-let typ_att_noarg = [ "base"; "left"; "right"; "high"; "low" ]
+(* XXX: UNUSED *)
+(* let typ_att_noarg = [ "base"; "left"; "right"; "high"; "low" ] *)
-let typ_att_intarg = [ "pos"; "val"; "succ"; "pred"; "leftof"; "rightof" ]
+(* XXX: UNUSED *)
+(* let typ_att_intarg = [ "pos"; "val"; "succ"; "pred"; "leftof"; "rightof" ] *)
-let typ_att_valarg = [ "image" ]
+(* XXX: UNUSED *)
+(* let typ_att_valarg = [ "image" ] *)
-let typ_att_stringarg = [ "value" ]
+(* XXX: UNUSED *)
+(* let typ_att_stringarg = [ "value" ] *)
type vhdl_array_attributes_t =
| AAttInt of { id : string; arg : int }
| AAttAscending
[@@deriving yojson { strict = false }]
-let array_att_intarg =
- [ "left"; "right"; "high"; "low"; "range"; "reverse_range"; "length" ]
+(* XXX: UNUSED *)
+(* let array_att_intarg =
+ * [ "left"; "right"; "high"; "low"; "range"; "reverse_range"; "length" ] *)
type vhdl_signal_attributes_t = SigAtt of string
[@@deriving yojson { strict = false }]
@@ -147,16 +155,20 @@ and vhdl_assoc_element_t = {
}
[@@deriving yojson { strict = false }]
-let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "rem"; "abs"; "**"; "&" ]
+(* XXX: UNUSED *)
+(* let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "rem"; "abs"; "**"; "&" ] *)
-let bool_funs = [ "and"; "or"; "nand"; "nor"; "xor"; "not" ]
+(* XXX: UNUSED *)
+(* let bool_funs = [ "and"; "or"; "nand"; "nor"; "xor"; "not" ] *)
-let rel_funs =
- [
- "<"; ">"; "<="; ">="; "/="; "="; "?="; "?/="; "?<"; "?<="; "?>"; "?>="; "??";
- ]
+(* XXX: UNUSED *)
+(* let rel_funs =
+ * [
+ * "<"; ">"; "<="; ">="; "/="; "="; "?="; "?/="; "?<"; "?<="; "?>"; "?>="; "??";
+ * ] *)
-let shift_funs = [ "sll"; "srl"; "sla"; "sra"; "rol"; "ror" ]
+(* XXX: UNUSED *)
+(* let shift_funs = [ "sll"; "srl"; "sla"; "sra"; "rol"; "ror" ] *)
type vhdl_sequential_stmt_t =
| VarAssign of { lhs : vhdl_name_t; rhs : vhdl_expr_t }
diff --git a/src/tools/importer/vhdl_json_lib.ml b/src/tools/importer/vhdl_json_lib.ml
index 336a4ba5..f4c7c741 100644
--- a/src/tools/importer/vhdl_json_lib.ml
+++ b/src/tools/importer/vhdl_json_lib.ml
@@ -1,4 +1,5 @@
-open Yojson.Safe.Util
+(* XXX: UNUSED *)
+(* open Yojson.Safe.Util *)
let rec assoc_map_except_str l f str =
match l with
@@ -26,41 +27,47 @@ let rec prune_str str json =
(*******************)
-let rec name_pair_list_to_string l =
- match l with
- | (t, `String x) :: tl ->
- if String.equal t "name" then x :: name_pair_list_to_string tl
- else name_pair_list_to_string tl
- | _ ->
- []
+(* XXX: UNUSED *)
+(* let rec name_pair_list_to_string l =
+ * match l with
+ * | (t, `String x) :: tl ->
+ * if String.equal t "name" then x :: name_pair_list_to_string tl
+ * else name_pair_list_to_string tl
+ * | _ ->
+ * [] *)
-let assoc_filter_string l =
- match l with `Assoc x -> name_pair_list_to_string x | _ -> []
+(* XXX: UNUSED *)
+(* let assoc_filter_string l =
+ * match l with `Assoc x -> name_pair_list_to_string x | _ -> [] *)
(********************)
-let rec pairlist_remove str l f =
- match l with
- | (t, j) :: tl ->
- if String.equal t str then f j :: pairlist_remove str tl f
- else `Assoc [ t, f j ] :: pairlist_remove str tl f
- | [] ->
- []
+(* XXX: UNUSED *)
+(* let rec pairlist_remove str l f =
+ * match l with
+ * | (t, j) :: tl ->
+ * if String.equal t str then f j :: pairlist_remove str tl f
+ * else `Assoc [ t, f j ] :: pairlist_remove str tl f
+ * | [] ->
+ * [] *)
(******************)
-let rec assoc_elem_fst pair_list =
- match pair_list with (t, _) :: tl -> t :: assoc_elem_fst tl | [] -> []
-
-let rec assoc_elem_snd pair_list =
- match pair_list with (_, j) :: tl -> j :: assoc_elem_snd tl | [] -> []
-
-let rec assoc_elem_filter pair_list str =
- match pair_list with
- | (t, j) :: tl ->
- if String.equal t str then (t, j) :: assoc_elem_filter tl str
- else assoc_elem_filter tl str
- | [] ->
- []
+(* XXX: UNUSED *)
+(* let rec assoc_elem_fst pair_list =
+ * match pair_list with (t, _) :: tl -> t :: assoc_elem_fst tl | [] -> [] *)
+
+(* XXX: UNUSED *)
+(* let rec assoc_elem_snd pair_list =
+ * match pair_list with (_, j) :: tl -> j :: assoc_elem_snd tl | [] -> [] *)
+
+(* XXX: UNUSED *)
+(* let rec assoc_elem_filter pair_list str =
+ * match pair_list with
+ * | (t, j) :: tl ->
+ * if String.equal t str then (t, j) :: assoc_elem_filter tl str
+ * else assoc_elem_filter tl str
+ * | [] ->
+ * [] *)
let rec assoc_elem_filternot pair_list str =
match pair_list with
@@ -78,13 +85,14 @@ let rec assoc_elem_filter_snd pair_list str =
| [] ->
[]
-let assoc_elem_filternot_snd pair_list str =
- match pair_list with
- | (t, j) :: tl ->
- if not (String.equal t str) then j :: assoc_elem_filter_snd tl str
- else assoc_elem_filter_snd tl str
- | [] ->
- []
+(* XXX: UNUSED *)
+(* let assoc_elem_filternot_snd pair_list str =
+ * match pair_list with
+ * | (t, j) :: tl ->
+ * if not (String.equal t str) then j :: assoc_elem_filter_snd tl str
+ * else assoc_elem_filter_snd tl str
+ * | [] ->
+ * [] *)
let rec pairlist_snd_as_list pair_list str =
match pair_list with
@@ -94,25 +102,30 @@ let rec pairlist_snd_as_list pair_list str =
| [] ->
[]
-let all_members str json =
- match json with `Assoc l -> assoc_elem_filter_snd l str | _ -> []
+(* XXX: UNUSED *)
+(* let all_members str json =
+ * match json with `Assoc l -> assoc_elem_filter_snd l str | _ -> [] *)
-let retain_other_members str json =
- match json with `Assoc l -> `Assoc (assoc_elem_filter l str) | _ -> `Null
+(* XXX: UNUSED *)
+(* let retain_other_members str json =
+ * match json with `Assoc l -> `Assoc (assoc_elem_filter l str) | _ -> `Null *)
+(* XXX: UNUSED *)
(* DESIGN_UNIT as lists *)
-let vhdl_json_designunits_content_as_list json =
- let designunits_contents =
- json |> member "DESIGN_FILE" |> all_members "DESIGN_UNIT"
- in
- `List designunits_contents
+(* let vhdl_json_designunits_content_as_list json =
+ * let designunits_contents =
+ * json |> member "DESIGN_FILE" |> all_members "DESIGN_UNIT"
+ * in
+ * `List designunits_contents *)
-let vhdl_json_designfile_content_excluding json =
- json |> member "DESIGN_FILE" |> retain_other_members "DESIGN_UNIT"
+(* XXX: UNUSED *)
+(* let vhdl_json_designfile_content_excluding json =
+ * json |> member "DESIGN_FILE" |> retain_other_members "DESIGN_UNIT" *)
-let vhdl_json_list_designunits json =
- let designunits_list = vhdl_json_designunits_content_as_list json in
- `Assoc [ "DESIGN_FILE", `Assoc [ "DESIGN_UNIT", designunits_list ] ]
+(* XXX: UNUSED *)
+(* let vhdl_json_list_designunits json =
+ * let designunits_list = vhdl_json_designunits_content_as_list json in
+ * `Assoc [ "DESIGN_FILE", `Assoc [ "DESIGN_UNIT", designunits_list ] ] *)
let rec pairlist_contains_str str l =
match l with
@@ -189,25 +202,26 @@ let rec prune_null_assoc json =
| x ->
x
+(* XXX: UNUSED *)
(* Value printers *)
-let rec print_depth json depth indent =
- if depth > 0 then
- match json with
- | `Assoc ((t, j) :: tl) ->
- (indent ^ t)
- ::
- List.append
- (print_depth j (depth - 1) (indent ^ " "))
- (print_depth (`Assoc tl) depth indent)
- | `List (hd :: tl) ->
- List.append
- (print_depth hd depth indent)
- (print_depth (`List tl) depth indent)
- | `String s ->
- [ indent ^ s ]
- | _ ->
- []
- else []
+(* let rec print_depth json depth indent =
+ * if depth > 0 then
+ * match json with
+ * | `Assoc ((t, j) :: tl) ->
+ * (indent ^ t)
+ * ::
+ * List.append
+ * (print_depth j (depth - 1) (indent ^ " "))
+ * (print_depth (`Assoc tl) depth indent)
+ * | `List (hd :: tl) ->
+ * List.append
+ * (print_depth hd depth indent)
+ * (print_depth (`List tl) depth indent)
+ * | `String s ->
+ * [ indent ^ s ]
+ * | _ ->
+ * []
+ * else [] *)
let rec flatten_ivd json =
match json with
diff --git a/src/tools/importer/vhdl_json_lib.mli b/src/tools/importer/vhdl_json_lib.mli
index f5f59f9a..243d0f05 100644
--- a/src/tools/importer/vhdl_json_lib.mli
+++ b/src/tools/importer/vhdl_json_lib.mli
@@ -1,8 +1,13 @@
open Yojson.Safe
-val prune_str: string -> t -> t
-val prune_null_assoc: t -> t
-val to_list_content_str: string -> t -> t
-val flatten_ivd: t -> t
-val flatten_numeric_literal: t -> t
-val to_list_str: string -> t -> t
+val prune_str : string -> t -> t
+
+val prune_null_assoc : t -> t
+
+val to_list_content_str : string -> t -> t
+
+val flatten_ivd : t -> t
+
+val flatten_numeric_literal : t -> t
+
+val to_list_str : string -> t -> t
diff --git a/src/tools/stateflow/common/activeStates.ml b/src/tools/stateflow/common/activeStates.ml
index 5a27430b..a08ff19d 100644
--- a/src/tools/stateflow/common/activeStates.ml
+++ b/src/tools/stateflow/common/activeStates.ml
@@ -13,8 +13,9 @@ module Vars = struct
let compare = compare
end)
- let pp_set fmt rho =
- Format.(fprintf fmt "@[<v 0>%a@ @]" (pp_print_list pp_path) (elements rho))
+ (* XXX: UNUSED *)
+ (* let pp_set fmt rho =
+ * Format.(fprintf fmt "@[<v 0>%a@ @]" (pp_print_list pp_path) (elements rho)) *)
end
module Env = struct
@@ -32,10 +33,12 @@ module Env = struct
Format.printf "Looking for %a@." pp_path a;
raise Not_found
- let keys a = fold (fun key _ -> Vars.add key) a Vars.empty
+ (* XXX: UNUSED *)
+ (* let keys a = fold (fun key _ -> Vars.add key) a Vars.empty *)
- let pp_env fmt rho =
- Format.(fprintf fmt "@[<v 0>%a@ @]"
- (pp_print_list (fun fmt (p, b) -> fprintf fmt "%a -> %b" pp_path p b))
- (bindings rho))
+ (* XXX: UNUSED *)
+ (* let pp_env fmt rho =
+ * Format.(fprintf fmt "@[<v 0>%a@ @]"
+ * (pp_print_list (fun fmt (p, b) -> fprintf fmt "%a -> %b" pp_path p b))
+ * (bindings rho)) *)
end
diff --git a/src/tools/stateflow/common/activeStates.mli b/src/tools/stateflow/common/activeStates.mli
index e5b95131..cda1aa1e 100644
--- a/src/tools/stateflow/common/activeStates.mli
+++ b/src/tools/stateflow/common/activeStates.mli
@@ -1,7 +1,7 @@
-module Vars: Set.S with type elt = Basetypes.path_t
+module Vars : Set.S with type elt = Basetypes.path_t
-module Env: sig
+module Env : sig
include Map.S with type key = Basetypes.path_t
- val from_set: Vars.t -> 'a -> 'a t
+ val from_set : Vars.t -> 'a -> 'a t
end
diff --git a/src/tools/stateflow/common/basetypes.ml b/src/tools/stateflow/common/basetypes.ml
index c7c85005..2a431bbd 100644
--- a/src/tools/stateflow/common/basetypes.ml
+++ b/src/tools/stateflow/common/basetypes.ml
@@ -34,14 +34,17 @@ let pp_state_name = Format.pp_print_string
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
-
-let pp_event fmt e =
- match e with
- | None ->
- Format.fprintf fmt "none"
- | Some s ->
- Format.fprintf fmt "%s" s
+ Utils.Format.pp_print_list
+ ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ".")
+ pp_state_name fmt p
+
+(* XXX: UNUSED *)
+(* let pp_event fmt e =
+ * match e with
+ * | None ->
+ * Format.fprintf fmt "none"
+ * | Some s ->
+ * Format.fprintf fmt "%s" s *)
let pp_base_act fmt a = Printers.pp_node_stmts fmt a.defs
diff --git a/src/tools/stateflow/common/basetypes.mli b/src/tools/stateflow/common/basetypes.mli
index eecf18a8..fb54ab3b 100644
--- a/src/tools/stateflow/common/basetypes.mli
+++ b/src/tools/stateflow/common/basetypes.mli
@@ -1,4 +1,4 @@
-val sf_level: int
+val sf_level : int
type state_name_t = string
@@ -34,11 +34,15 @@ type _ call_t =
| Dcall : path_t call_t
| Xcall : (path_t * frontier_t) call_t
-val pp_state_name: Format.formatter -> state_name_t -> unit
-val pp_junction_name: Format.formatter -> junction_name_t -> unit
-val pp_path: Format.formatter -> path_t -> unit
-val pp_frontier: Format.formatter -> frontier_t -> unit
-val pp_call: Format.formatter -> 'a call_t -> unit
+val pp_state_name : Format.formatter -> state_name_t -> unit
+
+val pp_junction_name : Format.formatter -> junction_name_t -> unit
+
+val pp_path : Format.formatter -> path_t -> unit
+
+val pp_frontier : Format.formatter -> frontier_t -> unit
+
+val pp_call : Format.formatter -> 'a call_t -> unit
(* Conditions are either (1) simple strings, (2) the active status of a state or
(3) occurence of an event. They can be combined (conjunction, negation) *)
@@ -68,7 +72,7 @@ type condition_t =
| Neg of condition_t
| True
-module Condition: ConditionType with type t = condition_t
+module Condition : ConditionType with type t = condition_t
module type ActionType = sig
type t
@@ -93,8 +97,8 @@ type action_t =
| Call : 'c call_t * 'c -> action_t
| Nil : action_t
-module Action: ActionType with type t = action_t
+module Action : ActionType with type t = action_t
-module GlobalVarDef: sig
+module GlobalVarDef : sig
type t = { variable : Lustre_types.var_decl; init_val : Lustre_types.expr }
end
diff --git a/src/tools/stateflow/common/datatype.ml b/src/tools/stateflow/common/datatype.ml
index 8d730162..2726d62b 100644
--- a/src/tools/stateflow/common/datatype.ml
+++ b/src/tools/stateflow/common/datatype.ml
@@ -44,11 +44,14 @@ type prog_t =
* prog_t src_components_t list
* (Lustre_types.var_decl * Lustre_types.expr) list
-type scope_t = Constant | Input | Local | Output | Parameter
+(* XXX: UNUSED *)
+(* type scope_t = Constant | Input | Local | Output | Parameter *)
-type datatype_var_init_t = Bool of bool | Real of float | Int of int
+(* XXX: UNUSED *)
+(* type datatype_var_init_t = Bool of bool | Real of float | Int of int *)
-type user_variable_t = user_variable_name_t * scope_t * datatype_var_init_t
+(* XXX: UNUSED *)
+(* type user_variable_t = user_variable_name_t * scope_t * datatype_var_init_t *)
type trace_t = event_t list
@@ -73,12 +76,14 @@ module SF = struct
let event s = Some s
- let action s = Action.aquote s
+ (* XXX: UNUSED *)
+ (* let action s = Action.aquote s *)
let condition s = Condition.cquote s
- let no_state_action =
- { entry_act = no_action; during_act = no_action; exit_act = no_action }
+ (* XXX: UNUSED *)
+ (* let no_state_action =
+ * { entry_act = no_action; during_act = no_action; exit_act = no_action } *)
let state_action a b c = { entry_act = a; during_act = b; exit_act = c }
@@ -94,7 +99,8 @@ module SF = struct
res)
ActiveStates.Vars.empty defs
- let init_env model = ActiveStates.Env.from_set (states model) false
+ (* XXX: UNUSED *)
+ (* let init_env model = ActiveStates.Env.from_set (states model) false *)
let global_vars (Program (_, _, env)) = env
@@ -120,64 +126,74 @@ module SF = struct
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@]@ ]@]"
- (pp_print_list ~pp_sep:pp_print_semicolon pp_trans)
- l)
+ Format.(
+ fprintf fmt "@[<hov 0>[@[<hov 0>%a@]@ ]@]"
+ (pp_print_list ~pp_sep:pp_print_semicolon pp_trans)
+ l)
let pp_comp fmt c =
match c with
| Or (_T, _S) ->
- Format.(fprintf fmt "Or(%a, {%a})" pp_transitions _T
- (pp_print_list ~pp_sep:pp_print_semicolon pp_state_name)
- _S)
+ Format.(
+ 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})"
- (pp_print_list ~pp_sep:pp_print_semicolon pp_state_name)
- _S)
-
- let pp_state_actions fmt sa =
- Format.fprintf fmt "@[<hov 0>(%a,@ %a,@ %a)@]" Action.pp_act sa.entry_act
- Action.pp_act sa.during_act Action.pp_act sa.exit_act
-
- let pp_state fmt s =
- Format.fprintf fmt "@[<v 0>(@[<v 0>%a,@ %a,@ %a,@ %a@]@ @])"
- pp_state_actions s.state_actions pp_transitions s.outer_trans
- pp_transitions s.inner_trans pp_comp s.internal_composition
-
- let pp_src pp_sffunction fmt src =
- Format.(fprintf fmt "@[<v>%a@ @]"
- (pp_print_list ~pp_sep:pp_print_cutcut (fun fmt src ->
- match src with
- | State (p, def) ->
- Format.fprintf fmt "%a: %a" pp_path p pp_state def
- | Junction (s, tl) ->
- Format.fprintf fmt "%a: %a" pp_state_name s pp_transitions tl
- | SFFunction p ->
- pp_sffunction fmt p))
- src)
-
- let rec pp_sffunction fmt (Program (name, component_list, _)) =
- Format.fprintf fmt "SFFunction name: %s@ %a@ " name (pp_src pp_sffunction)
- component_list
-
- let pp_vars fmt src =
- Format.(fprintf fmt "@[<v>%a@ @]" (pp_print_list Printers.pp_var) src)
-
- let pp_prog fmt (Program (name, component_list, vars)) =
- Format.fprintf fmt "Main node name: %s@ %a@ %a@" name (pp_src pp_sffunction)
- component_list pp_vars (List.map fst vars)
-
- let pp_scope fmt src =
- Format.fprintf fmt
- (match src with
- | Constant ->
- "Constant"
- | Input ->
- "Input"
- | Local ->
- "Local"
- | Output ->
- "Output"
- | Parameter ->
- "Parameter")
+ Format.(
+ fprintf fmt "And({%a})"
+ (pp_print_list ~pp_sep:pp_print_semicolon pp_state_name)
+ _S)
+
+ (* XXX: UNUSED *)
+ (* let pp_state_actions fmt sa =
+ * Format.fprintf fmt "@[<hov 0>(%a,@ %a,@ %a)@]" Action.pp_act sa.entry_act
+ * Action.pp_act sa.during_act Action.pp_act sa.exit_act *)
+
+ (* XXX: UNUSED *)
+ (* let pp_state fmt s =
+ * Format.fprintf fmt "@[<v 0>(@[<v 0>%a,@ %a,@ %a,@ %a@]@ @])"
+ * pp_state_actions s.state_actions pp_transitions s.outer_trans
+ * pp_transitions s.inner_trans pp_comp s.internal_composition *)
+
+ (* XXX: UNUSED *)
+ (* let pp_src pp_sffunction fmt src =
+ * Format.(fprintf fmt "@[<v>%a@ @]"
+ * (pp_print_list ~pp_sep:pp_print_cutcut (fun fmt src ->
+ * match src with
+ * | State (p, def) ->
+ * Format.fprintf fmt "%a: %a" pp_path p pp_state def
+ * | Junction (s, tl) ->
+ * Format.fprintf fmt "%a: %a" pp_state_name s pp_transitions tl
+ * | SFFunction p ->
+ * pp_sffunction fmt p))
+ * src) *)
+
+ (* XXX: UNUSED *)
+ (* let rec pp_sffunction fmt (Program (name, component_list, _)) =
+ * Format.fprintf fmt "SFFunction name: %s@ %a@ " name (pp_src pp_sffunction)
+ * component_list *)
+
+ (* XXX: UNUSED *)
+ (* let pp_vars fmt src =
+ * Format.(fprintf fmt "@[<v>%a@ @]" (pp_print_list Printers.pp_var) src) *)
+
+ (* XXX: UNUSED *)
+ (* let pp_prog fmt (Program (name, component_list, vars)) =
+ * Format.fprintf fmt "Main node name: %s@ %a@ %a@" name (pp_src pp_sffunction)
+ * component_list pp_vars (List.map fst vars) *)
+
+ (* XXX: UNUSED *)
+ (* let pp_scope fmt src =
+ * Format.fprintf fmt
+ * (match src with
+ * | Constant ->
+ * "Constant"
+ * | Input ->
+ * "Input"
+ * | Local ->
+ * "Local"
+ * | Output ->
+ * "Output"
+ * | Parameter ->
+ * "Parameter") *)
end
diff --git a/src/tools/stateflow/common/datatype.mli b/src/tools/stateflow/common/datatype.mli
index e1183053..e8b78c77 100644
--- a/src/tools/stateflow/common/datatype.mli
+++ b/src/tools/stateflow/common/datatype.mli
@@ -54,17 +54,28 @@ end
(* Module (S)tate(F)low provides basic constructors for action, condition,
events, as well as printer functions *)
-module SF: sig
- val no_action: action_t
- val no_condition: condition_t
- val no_event: event_t
- val condition: base_condition_t -> condition_t
- val event: event_base_t -> event_t
- val state_action: action_t -> action_t -> action_t -> state_actions_t
- val states: prog_t -> ActiveStates.Vars.t
- val global_vars: prog_t -> (Lustre_types.var_decl * Lustre_types.expr) list
- val pp_dest: Format.formatter -> destination_t -> unit
- val pp_trans: Format.formatter -> trans_t -> unit
- val pp_transitions: Format.formatter -> trans_t list -> unit
- val pp_comp: Format.formatter -> composition_t -> unit
+module SF : sig
+ val no_action : action_t
+
+ val no_condition : condition_t
+
+ val no_event : event_t
+
+ val condition : base_condition_t -> condition_t
+
+ val event : event_base_t -> event_t
+
+ val state_action : action_t -> action_t -> action_t -> state_actions_t
+
+ val states : prog_t -> ActiveStates.Vars.t
+
+ val global_vars : prog_t -> (Lustre_types.var_decl * Lustre_types.expr) list
+
+ val pp_dest : Format.formatter -> destination_t -> unit
+
+ val pp_trans : Format.formatter -> trans_t -> unit
+
+ val pp_transitions : Format.formatter -> trans_t list -> unit
+
+ val pp_comp : Format.formatter -> composition_t -> unit
end
diff --git a/src/tools/stateflow/models/model_stopwatch.ml b/src/tools/stateflow/models/model_stopwatch.ml
index 437953af..4f1fbd18 100644
--- a/src/tools/stateflow/models/model_stopwatch.ml
+++ b/src/tools/stateflow/models/model_stopwatch.ml
@@ -4,7 +4,8 @@ open Basetypes
(* open Transformer2 *)
open SF
-let verbose = false
+(* TODO *)
+(* let verbose = false *)
let actionv _ = no_action
(*TODO if verbose then action x else no_action*)
diff --git a/src/tools/stateflow/semantics/cPS.ml b/src/tools/stateflow/semantics/cPS.ml
index 4115b9ae..ca3ad3b0 100644
--- a/src/tools/stateflow/semantics/cPS.ml
+++ b/src/tools/stateflow/semantics/cPS.ml
@@ -10,7 +10,7 @@ functor
->
struct
module Prog = struct
- let init, defs, state_vars, globals =
+ let init, defs, _, _ =
let (Program (init, defs, globals)) = M.model in
let state_vars = SF.states M.model in
init, defs, state_vars, globals
@@ -42,9 +42,10 @@ functor
let module EvalProg = Interp.Evaluation (Thetaify) (Prog) in
(module EvalProg : Interp.EvaluationType)
- let compute modular =
- let module Eval = (val eval modular) in
- Eval.eval_prog
+ (* XXX: UNUSED *)
+ (* let compute modular =
+ * let module Eval = (val eval modular) in
+ * Eval.eval_prog *)
let code_gen modular =
let module Eval = (val eval modular) in
diff --git a/src/tools/stateflow/semantics/cPS.mli b/src/tools/stateflow/semantics/cPS.mli
index dd4e7e5f..9ccb3d0b 100644
--- a/src/tools/stateflow/semantics/cPS.mli
+++ b/src/tools/stateflow/semantics/cPS.mli
@@ -1,3 +1,3 @@
module Semantics (T : CPS_transformer.TransformerType) (M : Datatype.MODEL_T) : sig
- val code_gen: bool * bool * bool -> Lustre_types.program_t
+ val code_gen : bool * bool * bool -> Lustre_types.program_t
end
diff --git a/src/tools/stateflow/semantics/cPS_interpreter.ml b/src/tools/stateflow/semantics/cPS_interpreter.ml
index 493aeb59..30ea9a5c 100644
--- a/src/tools/stateflow/semantics/cPS_interpreter.ml
+++ b/src/tools/stateflow/semantics/cPS_interpreter.ml
@@ -50,22 +50,6 @@ module Interpreter (Transformer : TransformerType) = struct
end
module type AbsDenotationType = sig
- val eval_dest :
- kenv_t ->
- destination_t ->
- Transformer.t wrapper_t ->
- Transformer.t success_t ->
- Transformer.t fail_t ->
- Transformer.t
-
- val eval_tau :
- kenv_t ->
- trans_t ->
- Transformer.t wrapper_t ->
- Transformer.t success_t ->
- Transformer.t fail_t ->
- Transformer.t
-
val eval_T :
kenv_t ->
transitions_t ->
@@ -74,35 +58,27 @@ module Interpreter (Transformer : TransformerType) = struct
Transformer.t fail_t ->
Transformer.t
- val eval_C :
- kenv_t ->
- (path_t, 'b, Transformer.t) tag_t ->
- path_t ->
- composition_t ->
- Transformer.t
-
- val eval_open_path :
- kenv_t -> mode_t -> path_t -> path_t -> Transformer.t wrapper_t
-
val eval_S :
kenv_t -> (path_t, 'b, Transformer.t) tag_t -> path_t -> state_def_t -> 'b
end
module AbstractKenv (Denot : functor (Kenv : KenvType) -> DenotationType) :
AbsDenotationType = struct
- let eval_dest kenv =
- let module Kenv = struct
- let kenv = kenv
- end in
- let module D = Denot (Kenv) in
- D.eval_dest
-
- let eval_tau kenv =
- let module Kenv = struct
- let kenv = kenv
- end in
- let module D = Denot (Kenv) in
- D.eval_tau
+ (* XXX: UNUSED *)
+ (* let eval_dest kenv =
+ * let module Kenv = struct
+ * let kenv = kenv
+ * end in
+ * let module D = Denot (Kenv) in
+ * D.eval_dest *)
+
+ (* XXX: UNUSED *)
+ (* let eval_tau kenv =
+ * let module Kenv = struct
+ * let kenv = kenv
+ * end in
+ * let module D = Denot (Kenv) in
+ * D.eval_tau *)
let eval_T kenv =
let module Kenv = struct
@@ -111,19 +87,21 @@ module Interpreter (Transformer : TransformerType) = struct
let module D = Denot (Kenv) in
D.eval_T
- let eval_C kenv =
- let module Kenv = struct
- let kenv = kenv
- end in
- let module D = Denot (Kenv) in
- D.eval_C
-
- let eval_open_path kenv =
- let module Kenv = struct
- let kenv = kenv
- end in
- let module D = Denot (Kenv) in
- D.eval_open_path
+ (* XXX: UNUSED *)
+ (* let eval_C kenv =
+ * let module Kenv = struct
+ * let kenv = kenv
+ * end in
+ * let module D = Denot (Kenv) in
+ * D.eval_C *)
+
+ (* XXX: UNUSED *)
+ (* let eval_open_path kenv =
+ * let module Kenv = struct
+ * let kenv = kenv
+ * end in
+ * let module D = Denot (Kenv) in
+ * D.eval_open_path *)
let eval_S kenv =
let module Kenv = struct
diff --git a/src/tools/stateflow/semantics/cPS_interpreter.mli b/src/tools/stateflow/semantics/cPS_interpreter.mli
index c642299c..dedde20b 100644
--- a/src/tools/stateflow/semantics/cPS_interpreter.mli
+++ b/src/tools/stateflow/semantics/cPS_interpreter.mli
@@ -3,8 +3,7 @@ open Datatype
open CPS_transformer
open Theta
-module Interpreter (Transformer : TransformerType): sig
-
+module Interpreter (Transformer : TransformerType) : sig
(* module KT = KenvTheta (Transformer) *)
module type ProgType = sig
@@ -23,6 +22,5 @@ module Interpreter (Transformer : TransformerType): sig
module Evaluation
(Thetaify : KenvTheta(Transformer).ThetaifyType)
- (Prog : ProgType) :
- EvaluationType
+ (Prog : ProgType) : EvaluationType
end
diff --git a/src/tools/stateflow/semantics/cPS_lustre_generator.ml b/src/tools/stateflow/semantics/cPS_lustre_generator.ml
index b7a0bfdb..a424453a 100644
--- a/src/tools/stateflow/semantics/cPS_lustre_generator.ml
+++ b/src/tools/stateflow/semantics/cPS_lustre_generator.ml
@@ -2,8 +2,6 @@ open Utils
open Basetypes
open CPS_transformer
-let ff = Format.fprintf
-
module LustrePrinter (Vars : sig
val state_vars : ActiveStates.Vars.t
@@ -35,8 +33,11 @@ end) : TransformerType = struct
fun () -> cpt := 0 )
let pp_path prefix fmt path =
- Format.(fprintf fmt "%s%t" prefix (fun fmt ->
- pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt "_") pp_print_string fmt path))
+ Format.(
+ fprintf fmt "%s%t" prefix (fun fmt ->
+ pp_print_list
+ ~pp_sep:(fun fmt () -> pp_print_string fmt "_")
+ pp_print_string fmt path))
(* let pp_typed_path sin fmt path =
* Format.fprintf fmt "%a : bool" (pp_path sin) path *)
diff --git a/src/tools/stateflow/semantics/cPS_transformer.mli b/src/tools/stateflow/semantics/cPS_transformer.mli
index ce7c8ada..fe2d2470 100644
--- a/src/tools/stateflow/semantics/cPS_transformer.mli
+++ b/src/tools/stateflow/semantics/cPS_transformer.mli
@@ -26,8 +26,9 @@ module type ThetaType = sig
val theta : ('a, 'b, t) theta_t
end
-val pp_mode: Format.formatter -> mode_t -> unit
-val pp_tag: Format.formatter -> ('a, 'b, 't) tag_t -> unit
+val pp_mode : Format.formatter -> mode_t -> unit
+
+val pp_tag : Format.formatter -> ('a, 'b, 't) tag_t -> unit
module type TransformerType = sig
type act_t = Action.t
@@ -62,9 +63,12 @@ module type ComparableTransformerType = sig
val ( == ) : t -> t -> bool
end
-module TransformerStub: sig
+module TransformerStub : sig
type act_t = Action.t
+
type cond_t = Condition.t
+
include ConditionType with type t := cond_t
+
include ActionType with type t := act_t
end
diff --git a/src/tools/stateflow/semantics/theta.ml b/src/tools/stateflow/semantics/theta.ml
index 0e69c4f7..b6ea8ec2 100644
--- a/src/tools/stateflow/semantics/theta.ml
+++ b/src/tools/stateflow/semantics/theta.ml
@@ -25,15 +25,16 @@ module KenvTheta (T : TransformerType) = struct
list;
}
- let init_env src =
- List.fold_left
- (fun accu d ->
- match d with
- | Datatype.State (p, _) ->
- ActiveStates.Env.add p false accu
- | _ ->
- accu)
- ActiveStates.Env.empty src
+ (* XXX: UNUSED *)
+ (* let init_env src =
+ * List.fold_left
+ * (fun accu d ->
+ * match d with
+ * | Datatype.State (p, _) ->
+ * ActiveStates.Env.add p false accu
+ * | _ ->
+ * accu)
+ * ActiveStates.Env.empty src *)
module type KenvType = sig
val kenv : kenv_t
diff --git a/src/type_predef.ml b/src/type_predef.ml
index 9cb281ba..f9fc72a2 100644
--- a/src/type_predef.ml
+++ b/src/type_predef.ml
@@ -53,9 +53,10 @@ module Make (T : Types.S) = struct
let type_bin_bool_op =
type_arrow (type_tuple [ type_bool; type_bool ]) type_bool
- let type_ite_op =
- let univ = new_univar () in
- type_arrow (type_tuple [ type_bool; univ; univ ]) univ
+ (* XXX: UNUSED *)
+ (* let type_ite_op =
+ * let univ = new_univar () in
+ * type_arrow (type_tuple [ type_bool; univ; univ ]) univ *)
let type_bin_poly_op =
let univ = new_univar () in
@@ -65,24 +66,28 @@ module Make (T : Types.S) = struct
let univ = new_univar () in
new_ty (Tarrow (new_ty (Ttuple [ univ; univ ]), type_bool))
- let type_univ_bool_univ =
- let univ = new_univar () in
- type_arrow (type_tuple [ univ; type_bool ]) univ
-
- let type_bool_univ3 =
- let univ = new_univar () in
- type_arrow (type_tuple [ type_bool; univ; univ ]) univ
-
- let type_access =
- let d = Dimension.mkdim Location.dummy Dimension.Dunivar in
- let d' = Dimension.mkdim Location.dummy Dimension.Dunivar in
- let univ = new_univar () in
- type_arrow (type_tuple [ type_array d univ; type_static d' type_int ]) univ
-
- let type_power =
- let d = Dimension.mkdim Location.dummy Dimension.Dunivar in
- let univ = new_univar () in
- type_arrow (type_tuple [ univ; type_static d type_int ]) (type_array d univ)
+ (* XXX: UNUSED *)
+ (* let type_univ_bool_univ =
+ * let univ = new_univar () in
+ * type_arrow (type_tuple [ univ; type_bool ]) univ *)
+
+ (* XXX: UNUSED *)
+ (* let type_bool_univ3 =
+ * let univ = new_univar () in
+ * type_arrow (type_tuple [ type_bool; univ; univ ]) univ *)
+
+ (* XXX: UNUSED *)
+ (* let type_access =
+ * let d = Dimension.mkdim Location.dummy Dimension.Dunivar in
+ * let d' = Dimension.mkdim Location.dummy Dimension.Dunivar in
+ * let univ = new_univar () in
+ * type_arrow (type_tuple [ type_array d univ; type_static d' type_int ]) univ *)
+
+ (* XXX: UNUSED *)
+ (* let type_power =
+ * let d = Dimension.mkdim Location.dummy Dimension.Dunivar in
+ * let univ = new_univar () in
+ * type_arrow (type_tuple [ univ; type_static d type_int ]) (type_array d univ) *)
end
(* module BaseBuilder = *)
diff --git a/src/type_predef.mli b/src/type_predef.mli
index 23f8c8aa..658689b1 100644
--- a/src/type_predef.mli
+++ b/src/type_predef.mli
@@ -1,34 +1,60 @@
open Utils
(* open Types *)
-module Make(T: Types.S) : sig
+module Make (T : Types.S) : sig
(* see https://stackoverflow.com/a/37307124 *)
- include module type of struct include T end
- val type_int: t
- val type_real: t
- val type_bool: t
- val type_string: t
- val type_clock: t -> t
- val type_const: ident -> t
- val type_enum: ident list -> t
- val type_struct: (ident * t) list -> t
- val type_arrow: t -> t -> t
- val type_array: Dimension.t -> t -> t
- val type_static: Dimension.t -> t -> t
+ include module type of struct
+ include T
+ end
+
+ val type_int : t
+
+ val type_real : t
+
+ val type_bool : t
+
+ val type_string : t
+
+ val type_clock : t -> t
+
+ val type_const : ident -> t
+
+ val type_enum : ident list -> t
+
+ val type_struct : (ident * t) list -> t
+
+ val type_arrow : t -> t -> t
+
+ val type_array : Dimension.t -> t -> t
+
+ val type_static : Dimension.t -> t -> t
end
(* include Types.S *)
-val type_int: Types.t
-val type_bool: Types.t
-val type_real: Types.t
-val type_const: ident -> Types.t
-val type_static: Dimension.t -> Types.t -> Types.t
-val type_bin_poly_op: Types.t
-val type_unary_poly_op: Types.t
-val type_bin_int_op: Types.t
-val type_bin_bool_op: Types.t
-val type_bin_comp_op: Types.t
-val type_unary_bool_op: Types.t
-val type_tuple: Types.t list -> Types.t
-val type_arrow: Types.t -> Types.t -> Types.t
-val type_array: Dimension.t -> Types.t -> Types.t
+val type_int : Types.t
+
+val type_bool : Types.t
+
+val type_real : Types.t
+
+val type_const : ident -> Types.t
+
+val type_static : Dimension.t -> Types.t -> Types.t
+
+val type_bin_poly_op : Types.t
+
+val type_unary_poly_op : Types.t
+
+val type_bin_int_op : Types.t
+
+val type_bin_bool_op : Types.t
+
+val type_bin_comp_op : Types.t
+
+val type_unary_bool_op : Types.t
+
+val type_tuple : Types.t list -> Types.t
+
+val type_arrow : Types.t -> Types.t -> Types.t
+
+val type_array : Dimension.t -> Types.t -> Types.t
diff --git a/src/types.ml b/src/types.ml
index 558b68e6..312fbd3b 100644
--- a/src/types.ml
+++ b/src/types.ml
@@ -51,7 +51,7 @@ module type S = sig
type basic_type = BasicT.t
- type t = { mutable tdesc: type_desc; tid: int }
+ type t = { mutable tdesc : type_desc; tid : int }
and type_desc =
| Tconst of ident
@@ -71,7 +71,7 @@ module type S = sig
| Tvar
(* Monomorphic type variable *)
| Tunivar
- (* Polymorphic type variable *)
+ (* Polymorphic type variable *)
type error =
| Unbound_value of ident
@@ -166,7 +166,7 @@ module type S = sig
val array_type_multi_dimension : t -> Dimension.t list
end
-module Basic: BASIC_TYPES = struct
+module Basic : BASIC_TYPES = struct
type t = Tstring | Tint | Treal | Tbool | Trat
(* Actually unused for now. Only place where it can appear is in a clock
declaration *)
@@ -219,7 +219,7 @@ module Make (BasicT : BASIC_TYPES) = struct
type basic_type = BasicT.t
- type t = { mutable tdesc: type_desc; tid: int }
+ type t = { mutable tdesc : type_desc; tid : int }
and type_desc =
| Tconst of ident
@@ -239,7 +239,7 @@ module Make (BasicT : BASIC_TYPES) = struct
| Tvar
(* Monomorphic type variable *)
| Tunivar
- (* Polymorphic type variable *)
+ (* Polymorphic type variable *)
type error =
| Unbound_value of ident
@@ -289,11 +289,11 @@ module Make (BasicT : BASIC_TYPES) = struct
| Ttuple tylist ->
fprintf fmt "(%a)"
(pp_print_list
- ~pp_sep:(fun fmt () -> pp_print_string fmt " * ") print_ty) tylist
+ ~pp_sep:(fun fmt () -> pp_print_string fmt " * ")
+ print_ty)
+ tylist
| Tenum taglist ->
- fprintf fmt "enum {%a }"
- (pp_comma_list pp_print_string)
- 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
@@ -328,12 +328,13 @@ module Make (BasicT : BASIC_TYPES) = struct
| Tarrow (ty1, ty2) ->
fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2
| Ttuple tylist ->
- fprintf fmt "(%a)" (pp_print_list
- ~pp_sep:(fun fmt () -> pp_print_string fmt "") print_node_ty) tylist
+ fprintf fmt "(%a)"
+ (pp_print_list
+ ~pp_sep:(fun fmt () -> pp_print_string fmt "")
+ print_node_ty)
+ tylist
| Tenum taglist ->
- fprintf fmt "enum {%a }"
- (pp_comma_list pp_print_string)
- 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)
@@ -381,7 +382,7 @@ module Make (BasicT : BASIC_TYPES) = struct
let new_id = ref (-1)
- let rec bottom: t = { tdesc = Tlink bottom; tid = -666 }
+ let rec bottom : t = { tdesc = Tlink bottom; tid = -666 }
let new_ty desc =
incr new_id;
@@ -396,33 +397,36 @@ module Make (BasicT : BASIC_TYPES) = struct
let get_static_value ty =
match (repr ty).tdesc with Tstatic (d, _) -> Some d | _ -> None
- let get_field_type ty label =
- match (repr ty).tdesc with
- | Tstruct fl -> (
- try Some (List.assoc label fl) with Not_found -> None)
- | _ ->
- None
+ (* XXX: UNUSED *)
+ (* let get_field_type ty label =
+ * match (repr ty).tdesc with
+ * | Tstruct fl -> (
+ * try Some (List.assoc label fl) with Not_found -> None)
+ * | _ ->
+ * None *)
let is_static_type ty =
match (repr ty).tdesc with Tstatic _ -> true | _ -> false
- let rec is_scalar_type ty =
- match (repr ty).tdesc with
- | Tstatic (_, ty) ->
- is_scalar_type ty
- | Tbasic t ->
- BasicT.is_scalar_type t
- | _ ->
- false
-
- let rec is_numeric_type ty =
- match (repr ty).tdesc with
- | Tstatic (_, ty) ->
- is_numeric_type ty
- | Tbasic t ->
- BasicT.is_numeric_type t
- | _ ->
- false
+ (* XXX: UNUSED *)
+ (* let rec is_scalar_type ty =
+ * match (repr ty).tdesc with
+ * | Tstatic (_, ty) ->
+ * is_scalar_type ty
+ * | Tbasic t ->
+ * BasicT.is_scalar_type t
+ * | _ ->
+ * false *)
+
+ (* XXX: UNUSED *)
+ (* let rec is_numeric_type ty =
+ * match (repr ty).tdesc with
+ * | Tstatic (_, ty) ->
+ * is_numeric_type ty
+ * | Tbasic t ->
+ * BasicT.is_numeric_type t
+ * | _ ->
+ * false *)
let rec is_real_type ty =
match (repr ty).tdesc with
@@ -521,8 +525,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@." print_ty ty;
assert false
let rec array_type_multi_dimension ty =
@@ -585,29 +588,31 @@ module Make (BasicT : BASIC_TYPES) = struct
| _ ->
[ ty ]
+ (* XXX: UNUSED *)
(** [is_polymorphic ty] returns true if [ty] is polymorphic. *)
- let rec is_polymorphic ty =
- match ty.tdesc with
- | Tenum _ | Tvar | Tbasic _ | Tconst _ ->
- false
- | Tclock ty ->
- is_polymorphic ty
- | Tarrow (ty1, ty2) ->
- is_polymorphic ty1 || is_polymorphic ty2
- | Ttuple tl ->
- List.exists (fun t -> is_polymorphic t) tl
- | Tstruct fl ->
- List.exists (fun (_, t) -> is_polymorphic t) fl
- | Tlink t' ->
- is_polymorphic t'
- | Tarray (d, ty) | Tstatic (d, ty) ->
- Dimension.is_polymorphic d || is_polymorphic ty
- | Tunivar ->
- true
-
- let mktyptuple nb typ =
- let array = Array.make nb typ in
- Ttuple (Array.to_list array)
+ (* let rec is_polymorphic ty =
+ * match ty.tdesc with
+ * | Tenum _ | Tvar | Tbasic _ | Tconst _ ->
+ * false
+ * | Tclock ty ->
+ * is_polymorphic ty
+ * | Tarrow (ty1, ty2) ->
+ * is_polymorphic ty1 || is_polymorphic ty2
+ * | Ttuple tl ->
+ * List.exists (fun t -> is_polymorphic t) tl
+ * | Tstruct fl ->
+ * List.exists (fun (_, t) -> is_polymorphic t) fl
+ * | Tlink t' ->
+ * is_polymorphic t'
+ * | Tarray (d, ty) | Tstatic (d, ty) ->
+ * Dimension.is_polymorphic d || is_polymorphic ty
+ * | Tunivar ->
+ * true *)
+
+ (* XXX: UNUSED *)
+ (* let mktyptuple nb typ =
+ * let array = Array.make nb typ in
+ * Ttuple (Array.to_list array) *)
let type_desc t = t.tdesc
@@ -620,7 +625,6 @@ module Make (BasicT : BASIC_TYPES) = struct
let type_string = mk_basic BasicT.type_string_builder
end
-
include Make (Basic)
(* Local Variables: *)
diff --git a/src/types.mli b/src/types.mli
index 8653a9dc..6a2cf25e 100644
--- a/src/types.mli
+++ b/src/types.mli
@@ -37,7 +37,7 @@ module type S = sig
type basic_type = BasicT.t
- type t = { mutable tdesc: type_desc; tid: int }
+ type t = { mutable tdesc : type_desc; tid : int }
and type_desc =
| Tconst of ident
@@ -57,7 +57,7 @@ module type S = sig
| Tvar
(* Monomorphic type variable *)
| Tunivar
- (* Polymorphic type variable *)
+ (* Polymorphic type variable *)
type error =
| Unbound_value of ident
@@ -152,9 +152,11 @@ module type S = sig
val array_type_multi_dimension : t -> Dimension.t list
end
-module Make(BasicT: BASIC_TYPES) : sig
+module Make (BasicT : BASIC_TYPES) : sig
include S
- val print_ty_param: (Format.formatter -> basic_type -> unit) -> Format.formatter -> t -> unit
+
+ val print_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 762e67e3..3a7feca2 100644
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -14,9 +14,6 @@
(** Main typing module. Classic inference algorithm with destructive
unification. *)
-let debug _fmt _args = ()
-
-(* Format.eprintf "%a" *)
(* Though it shares similarities with the clock calculus module, no code is
shared. Simple environments, very limited identifier scoping, no identifier
redefinition allowed. *)
@@ -42,13 +39,13 @@ end
module Make
(T : Types.S)
- (Expr_type_hub : EXPR_TYPE_HUB with type type_expr = T.t)
-=
+ (Expr_type_hub : EXPR_TYPE_HUB with type type_expr = T.t) =
struct
module TP = Type_predef.Make (T)
include TP
- let pp_typing_env fmt env = Env.pp print_ty fmt env
+ (* XXX: UNUSED *)
+ (* let pp_typing_env fmt env = Env.pp print_ty fmt env *)
(****************************************************************)
(* Generic functions: occurs, instantiate and generalize *)
@@ -312,8 +309,7 @@ struct
| Tstatic (e1, t1'), Tstatic (e2, t2')
| Tarray (e1, t1'), Tarray (e2, t2') ->
let eval_const =
- if semi then fun c ->
- Some (Dimension.mkdim_ident Location.dummy c)
+ if semi then fun c -> Some (Dimension.mkdim_ident Location.dummy c)
else fun _ -> None
in
unif t1' t2';
@@ -967,7 +963,8 @@ struct
cdecl.const_type <- Expr_type_hub.export ty;
new_env
- let type_top_consts env clist = List.fold_left type_top_const env clist
+ (* XXX: UNUSED *)
+ (* let type_top_consts env clist = List.fold_left type_top_const env clist *)
let rec type_top_decl env decl =
match decl.top_decl_desc with
@@ -986,16 +983,17 @@ struct
| Include _ | Open _ ->
env
- let get_type_of_call decl =
- match decl.top_decl_desc with
- | Node nd ->
- let in_typ, out_typ = split_arrow (Expr_type_hub.import nd.node_type) in
- type_list_of_type in_typ, type_list_of_type out_typ
- | ImportedNode nd ->
- let in_typ, out_typ = split_arrow (Expr_type_hub.import nd.nodei_type) in
- type_list_of_type in_typ, type_list_of_type out_typ
- | _ ->
- assert false
+ (* XXX: UNUSED *)
+ (* let get_type_of_call decl =
+ * match decl.top_decl_desc with
+ * | Node nd ->
+ * let in_typ, out_typ = split_arrow (Expr_type_hub.import nd.node_type) in
+ * type_list_of_type in_typ, type_list_of_type out_typ
+ * | ImportedNode nd ->
+ * let in_typ, out_typ = split_arrow (Expr_type_hub.import nd.nodei_type) in
+ * type_list_of_type in_typ, type_list_of_type out_typ
+ * | _ ->
+ * assert false *)
let type_prog env decls =
try List.fold_left type_top_decl env decls
@@ -1021,8 +1019,9 @@ struct
let uneval_node_generics vdecls = List.iter uneval_vdecl_generics vdecls
- let uneval_spec_generics spec =
- List.iter uneval_vdecl_generics (spec.consts @ spec.locals)
+ (* XXX: UNUSED *)
+ (* let uneval_spec_generics spec =
+ * List.iter uneval_vdecl_generics (spec.consts @ spec.locals) *)
let uneval_top_generics decl =
match decl.top_decl_desc with
@@ -1108,14 +1107,15 @@ struct
let check_typedef_compat header = List.iter check_typedef_top header
end
-module Expr_type_hub: EXPR_TYPE_HUB with type type_expr = Types.t = struct
+module Expr_type_hub : EXPR_TYPE_HUB with type type_expr = Types.t = struct
type type_expr = Types.t
let import x = x
+
let export x = x
end
-include Make(Types)(Expr_type_hub)
+include Make (Types) (Expr_type_hub)
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/typing.mli b/src/typing.mli
index f9201a10..d5422dd2 100644
--- a/src/typing.mli
+++ b/src/typing.mli
@@ -1,8 +1,8 @@
open Lustre_types
-val type_const: ?is_annot:bool -> Location.t -> constant -> Types.t
-val type_node: Types.t Env.t -> node_desc -> Location.t -> Types.t Env.t
+val type_const : ?is_annot:bool -> Location.t -> constant -> Types.t
+val type_node : Types.t Env.t -> node_desc -> Location.t -> Types.t Env.t
module type EXPR_TYPE_HUB = sig
type type_expr
@@ -12,23 +12,28 @@ module type EXPR_TYPE_HUB = sig
val export : type_expr -> Types.t
end
-module Make(T: Types.S) (Expr_type_hub: EXPR_TYPE_HUB with type type_expr = T.t) : sig
- val type_expr: ?is_annot:bool -> T.t Env.t * 'a -> bool -> bool -> expr -> T.t
- val generalize: T.t -> unit
+module Make
+ (T : Types.S)
+ (Expr_type_hub : EXPR_TYPE_HUB with type type_expr = T.t) : sig
+ val type_expr :
+ ?is_annot:bool -> T.t Env.t * 'a -> bool -> bool -> expr -> T.t
+
+ val generalize : T.t -> unit
end
-val try_unify: ?sub:bool -> ?semi:bool -> Types.t -> Types.t -> Location.t -> unit
+val try_unify :
+ ?sub:bool -> ?semi:bool -> Types.t -> Types.t -> Location.t -> unit
-val type_var_decl_list: 'a -> Types.t Env.t -> var_decl list -> Types.t Env.t
+val type_var_decl_list : 'a -> Types.t Env.t -> var_decl list -> Types.t Env.t
-val type_prog: Types.t Env.t -> program_t -> Types.t Env.t
+val type_prog : Types.t Env.t -> program_t -> Types.t Env.t
-val check_typedef_compat: top_decl list -> unit
+val check_typedef_compat : top_decl list -> unit
-val check_env_compat: top_decl list -> Types.t Env.t -> Types.t Env.t -> unit
+val check_env_compat : top_decl list -> Types.t Env.t -> Types.t Env.t -> unit
-val uneval_prog_generics: program_t -> unit
+val uneval_prog_generics : program_t -> unit
(* Equality on ground types only *)
(* Should be used between local variables which must have a ground type *)
-val eq_ground: Types.t -> Types.t -> bool
+val eq_ground : Types.t -> Types.t -> bool
diff --git a/src/utils/dimension.ml b/src/utils/dimension.ml
index 2a65b415..dcf07c49 100644
--- a/src/utils/dimension.ml
+++ b/src/utils/dimension.ml
@@ -11,11 +11,7 @@
open Format
-type t = {
- mutable dim_desc : dim_desc;
- dim_loc : Location.t;
- dim_id : int;
-}
+type t = { mutable dim_desc : dim_desc; dim_loc : Location.t; dim_id : int }
and dim_desc =
| Dbool of bool
@@ -71,8 +67,7 @@ let rec pp fmt dim =
| Dbool b ->
fprintf fmt "%B" b
| Dite (i, t, e) ->
- fprintf fmt "if %a then %a else %a" pp i pp t
- pp e
+ fprintf fmt "if %a then %a else %a" pp i pp t pp e
| Dappl (f, [ arg ]) ->
fprintf fmt "(%s%a)" f pp arg
| Dappl (f, [ arg1; arg2 ]) ->
@@ -156,37 +151,42 @@ let rec is_polymorphic dim =
sub-expressions, where unsupported operations (eg. '/') are treated as
variables. *)
-let rec factors dim =
- match dim.dim_desc with
- | Dappl (f, args) when f = "*" ->
- List.flatten (List.map factors args)
- | _ ->
- [ dim ]
-
-let rec factors_constant fs =
- match fs with
- | [] ->
- 1
- | f :: q -> (
- match f.dim_desc with
- | Dint i ->
- i * factors_constant q
- | _ ->
- factors_constant q)
-
-let norm_factors fs =
- let k = factors_constant fs in
- let nk = List.filter (fun d -> not (is_const d)) fs in
- k, List.sort compare nk
-
-let rec terms dim =
- match dim.dim_desc with
- | Dappl (f, args) when f = "+" ->
- List.flatten (List.map terms args)
- | _ ->
- [ dim ]
-
-let normalize dim = dim
+(* XXX: UNUSED *)
+(* let rec factors dim =
+ * match dim.dim_desc with
+ * | Dappl (f, args) when f = "*" ->
+ * List.flatten (List.map factors args)
+ * | _ ->
+ * [ dim ] *)
+
+(* XXX: UNUSED *)
+(* let rec factors_constant fs =
+ * match fs with
+ * | [] ->
+ * 1
+ * | f :: q -> (
+ * match f.dim_desc with
+ * | Dint i ->
+ * i * factors_constant q
+ * | _ ->
+ * factors_constant q) *)
+
+(* XXX: UNUSED *)
+(* let norm_factors fs =
+ * let k = factors_constant fs in
+ * let nk = List.filter (fun d -> not (is_const d)) fs in
+ * k, List.sort compare nk *)
+
+(* XXX: UNUSED *)
+(* let rec terms dim =
+ * match dim.dim_desc with
+ * | Dappl (f, args) when f = "+" ->
+ * List.flatten (List.map terms args)
+ * | _ ->
+ * [ dim ] *)
+
+(* XXX: UNUSED *)
+(* let normalize dim = dim *)
(* let rec unnormalize loc l = let l = List.sort (fun (k, l) (k', l') -> compare
l l') (List.map (fun (k, l) -> (k, List.sort compare l)) l) in match l with |
diff --git a/src/utils/dimension.mli b/src/utils/dimension.mli
index 45c9fda4..3b66b13d 100644
--- a/src/utils/dimension.mli
+++ b/src/utils/dimension.mli
@@ -1,10 +1,6 @@
open Utils
-type t = {
- mutable dim_desc : dim_desc;
- dim_loc : Location.t;
- dim_id : int;
-}
+type t = { mutable dim_desc : dim_desc; dim_loc : Location.t; dim_id : int }
and dim_desc =
| Dbool of bool
@@ -17,35 +13,51 @@ and dim_desc =
| Dunivar
exception Unify of t * t
+
exception InvalidDimension
-val mkdim: Location.t -> dim_desc -> t
-val mkdim_ident: Location.t -> ident -> t
-val mkdim_int: Location.t -> int -> t
-val mkdim_bool: Location.t -> bool -> t
-val mkdim_var: unit -> t
-val mkdim_appl: Location.t -> ident -> t list -> t
-val mkdim_ite: Location.t -> t -> t -> t -> t
+val mkdim : Location.t -> dim_desc -> t
+
+val mkdim_ident : Location.t -> ident -> t
+
+val mkdim_int : Location.t -> int -> t
+
+val mkdim_bool : Location.t -> bool -> t
+
+val mkdim_var : unit -> t
+
+val mkdim_appl : Location.t -> ident -> t list -> t
+
+val mkdim_ite : Location.t -> t -> t -> t -> t
+
+val pp : Format.formatter -> t -> unit
+
+val is_const : t -> bool
+
+val is_polymorphic : t -> bool
+
+val generalize : t -> unit
+
+val instantiate : (int * t) list ref -> t -> t
+
+val copy : (int * t) list ref -> t -> t
+
+val equal : t -> t -> bool
+
+val eval : (dim_desc list -> dim_desc) Env.t -> (ident -> t option) -> t -> unit
+
+val unify : ?semi:bool -> t -> t -> unit
-val pp: Format.formatter -> t -> unit
+val uneval : ident -> t -> unit
-val is_const: t -> bool
-val is_polymorphic: t -> bool
-val generalize: t -> unit
-val instantiate: (int * t) list ref -> t -> t
-val copy: (int * t) list ref -> t -> t
-val equal: t -> t -> bool
-val eval: (dim_desc list -> dim_desc) Env.t -> (ident -> t option) -> t -> unit
-val unify: ?semi:bool -> t -> t -> unit
-val uneval: ident -> t -> unit
+val expr_replace_expr : (ident -> t) -> t -> t
-val expr_replace_expr: (ident -> t) -> t -> t
+val rename : (ident -> ident) -> (ident -> ident) -> t -> t
-val rename: (ident -> ident) -> (ident -> ident) -> t -> t
+val size_const : t -> int
-val size_const: t -> int
+val check_bound : Location.t -> t -> t
-val check_bound: Location.t -> t -> t
-val check_access: Location.t -> t -> t -> t
+val check_access : Location.t -> t -> t -> t
-val multi_product: Location.t -> t list -> t
+val multi_product : Location.t -> t list -> t
diff --git a/src/utils/env.mli b/src/utils/env.mli
index 5da15267..9f100310 100644
--- a/src/utils/env.mli
+++ b/src/utils/env.mli
@@ -2,11 +2,18 @@ open Utils
type 'a t
-val initial: 'a t
-val add_value: 'a t -> ident -> 'a -> 'a t
-val lookup_value: 'a t -> ident -> 'a
-val exists_value: 'a t -> ident -> bool
-val iter: 'a t -> (ident -> 'a -> unit) -> unit
-val pp: (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
-val overwrite: 'a t -> 'a t -> 'a t
-val fold: (ident -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+val initial : 'a t
+
+val add_value : 'a t -> ident -> 'a -> 'a t
+
+val lookup_value : 'a t -> ident -> 'a
+
+val exists_value : 'a t -> ident -> bool
+
+val iter : 'a t -> (ident -> 'a -> unit) -> unit
+
+val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+
+val overwrite : 'a t -> 'a t -> 'a t
+
+val fold : (ident -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
diff --git a/src/utils/location.ml b/src/utils/location.ml
index f1c0ae35..2e34c557 100644
--- a/src/utils/location.ml
+++ b/src/utils/location.ml
@@ -18,21 +18,18 @@ type filename = string
let dummy = dummy_pos, dummy_pos
-let set_input, get_input, get_module =
+let set_input, get_module =
let input_name : filename ref = ref "__UNINITIALIZED__" in
let module_name : filename ref = ref "__UNINITIALIZED__" in
( (fun name ->
input_name := name;
module_name := Filename.chop_extension name),
- (fun () -> !input_name),
fun () -> !module_name )
let curr lexbuf = lexbuf.lex_start_p, lexbuf.lex_curr_p
let filename_of (s, _) = s.pos_fname
-let filename_of_lexbuf lexbuf = lexbuf.lex_start_p.pos_fname
-
let shift_pos pos1 pos2 =
(* Format.eprintf "Shift pos %s by pos %s@." pos1.Lexing.pos_fname pos2.Lexing.pos_fname;
* assert (pos1.Lexing.pos_fname = pos2.Lexing.pos_fname); *)
diff --git a/src/utils/location.mli b/src/utils/location.mli
index 266d7204..256a82c9 100644
--- a/src/utils/location.mli
+++ b/src/utils/location.mli
@@ -1,12 +1,21 @@
type t = Lexing.position * Lexing.position
+
type filename = string
-val dummy: t
-val pp: Format.formatter -> t -> unit
-val pp_c: Format.formatter -> t -> unit
-val get_module: unit -> filename
-val curr: Lexing.lexbuf -> t
-val shift: t -> t -> t
-val set_input: filename -> unit
-val filename_of: t -> filename
-val line_of: t -> int
+val dummy : t
+
+val pp : Format.formatter -> t -> unit
+
+val pp_c : Format.formatter -> t -> unit
+
+val get_module : unit -> filename
+
+val curr : Lexing.lexbuf -> t
+
+val shift : t -> t -> t
+
+val set_input : filename -> unit
+
+val filename_of : t -> filename
+
+val line_of : t -> int
diff --git a/src/utils/utils.ml b/src/utils/utils.ml
index d87a776b..e4cdd10d 100644
--- a/src/utils/utils.ml
+++ b/src/utils/utils.ml
@@ -11,13 +11,15 @@
open Graph
-type rat = int * int
+(* XXX: UNUSED *)
+(* type rat = int * int *)
type ident = string
type tag = int
-type longident = (string * tag) list
+(* XXX: UNUSED *)
+(* type longident = (string * tag) list *)
exception TransposeError of int * int
@@ -84,18 +86,20 @@ let option_map f o = match o with None -> None | Some e -> Some (f e)
let add_cons x l = if List.mem x l then l else x :: l
-let rec remove_duplicates l =
- match l with [] -> [] | t :: q -> add_cons t (remove_duplicates q)
-
-let position pred l =
- let rec pos p l =
- match l with
- | [] ->
- assert false
- | t :: q ->
- if pred t then p else pos (p + 1) q
- in
- pos 0 l
+(* XXX: UNUSED *)
+(* let rec remove_duplicates l =
+ * match l with [] -> [] | t :: q -> add_cons t (remove_duplicates q) *)
+
+(* XXX: UNUSED *)
+(* let position pred l =
+ * let rec pos p l =
+ * match l with
+ * | [] ->
+ * assert false
+ * | t :: q ->
+ * if pred t then p else pos (p + 1) q
+ * in
+ * pos 0 l *)
(* TODO: Lélio: why n+1? cf former def below *)
(* if n < 0 then [] else x :: duplicate x (n - 1) *)
@@ -128,37 +132,43 @@ let transpose_list ll =
q;
transpose ll
-let rec filter_upto p n l =
- if n = 0 then []
- else
- match l with
- | [] ->
- []
- | t :: q ->
- if p t then t :: filter_upto p (n - 1) q else filter_upto p n q
-
+(* XXX: UNUSED *)
+(* let rec filter_upto p n l =
+ * if n = 0 then []
+ * else
+ * match l with
+ * | [] ->
+ * []
+ * | t :: q ->
+ * if p t then t :: filter_upto p (n - 1) q else filter_upto p n q *)
+
+(* XXX: UNUSED *)
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
-let rec gcd a b = if b = 0 then a else gcd b (a mod b)
+(* let rec gcd a b = if b = 0 then a else gcd b (a mod b) *)
+(* XXX: UNUSED *)
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
-let lcm a b = if a = 0 && b = 0 then 0 else a * b / gcd a b
+(* let lcm a b = if a = 0 && b = 0 then 0 else a * b / gcd a b *)
+(* XXX: UNUSED *)
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and [(a',b')] *)
-let sum_rat (a, b) (a', b') =
- if a = 0 && b = 0 then a', b'
- else if a' = 0 && b' = 0 then a, b
- else
- let lcm_bb' = lcm b b' in
- (a * lcm_bb' / b) + (a' * lcm_bb' / b'), lcm_bb'
-
-let simplify_rat (a, b) =
- let gcd = gcd a b in
- if gcd = 0 then a, b else a / gcd, b / gcd
-
-let max_rat (a, b) (a', b') =
- let ratio_ab = float_of_int a /. float_of_int b in
- let ratio_ab' = float_of_int a' /. float_of_int b' in
- if ratio_ab > ratio_ab' then a, b else a', b'
+(* let sum_rat (a, b) (a', b') =
+ * if a = 0 && b = 0 then a', b'
+ * else if a' = 0 && b' = 0 then a, b
+ * else
+ * let lcm_bb' = lcm b b' in
+ * (a * lcm_bb' / b) + (a' * lcm_bb' / b'), lcm_bb' *)
+
+(* XXX: UNUSED *)
+(* let simplify_rat (a, b) =
+ * let gcd = gcd a b in
+ * if gcd = 0 then a, b else a / gcd, b / gcd *)
+
+(* XXX: UNUSED *)
+(* let max_rat (a, b) (a', b') =
+ * let ratio_ab = float_of_int a /. float_of_int b in
+ * let ratio_ab' = float_of_int a' /. float_of_int b' in
+ * if ratio_ab > ratio_ab' then a, b else a', b' *)
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The result
contains no duplicates. *)
@@ -173,23 +183,25 @@ let list_union l1 l2 =
let l1' = aux l1 [] in
aux l2 l1'
+(* XXX: UNUSED *)
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the
intersection is not empty, it replaces the former binding *)
-let hashtbl_add h1 h2 =
- Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2
-
-let hashtbl_iterlast h f1 f2 =
- let l = Hashtbl.length h in
- ignore
- (Hashtbl.fold
- (fun k v cpt ->
- if cpt = l then (
- f2 k v;
- cpt + 1)
- else (
- f1 k v;
- cpt + 1))
- h 1)
+(* let hashtbl_add h1 h2 =
+ * Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2 *)
+
+(* XXX: UNUSED *)
+(* let hashtbl_iterlast h f1 f2 =
+ * let l = Hashtbl.length h in
+ * ignore
+ * (Hashtbl.fold
+ * (fun k v cpt ->
+ * if cpt = l then (
+ * f2 k v;
+ * cpt + 1)
+ * else (
+ * f1 k v;
+ * cpt + 1))
+ * h 1) *)
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type variables
are identified by integers. *)
@@ -276,21 +288,14 @@ let name_of_delay id =
inames := (id, name) :: !inames;
name
-open Format
-
-let print_rat fmt (a, b) =
- if b = 1 then Format.fprintf fmt "%i" a
- else if b < 0 then Format.fprintf fmt "%i/%i" (-a) (-b)
- else Format.fprintf fmt "%i/%i" a b
+(* XXX: UNUSED *)
+(* let print_rat fmt (a, b) =
+ * if b = 1 then Format.fprintf fmt "%i" a
+ * else if b < 0 then Format.fprintf fmt "%i/%i" (-a) (-b)
+ * else Format.fprintf fmt "%i/%i" a b *)
(* Generic pretty printing *)
-let pp_final_char_if_non_empty c l fmt =
- match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c
-
-let pp_newline_if_non_empty l fmt =
- match l with [] -> () | _ -> Format.fprintf fmt "@,"
-
module Format = struct
include Format
open Format
@@ -319,10 +324,6 @@ module Format = struct
let pp_print_cbrace fmt () = pp_print_string fmt "}"
- let pp_print_opar' fmt () = pp_print_string fmt "( "
-
- let pp_print_cpar' fmt () = pp_print_string fmt " )"
-
let pp_print_obrace' fmt () = pp_print_string fmt "{ "
let pp_print_cbrace' fmt () = pp_print_string fmt " }"
@@ -360,15 +361,10 @@ module Format = struct
?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_nil ?pp_sep (fun fmt x ->
pp_v fmt !i x;
incr i)
- let pp_print_list2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
- ?pp_eol ?pp_nil ?pp_sep pp_v fmt (l1, l2) =
- pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
- ?pp_nil ?pp_sep pp_v fmt (List.combine l1 l2)
-
let pp_print_list_i2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
?pp_eol ?pp_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
@@ -389,56 +385,6 @@ module Format = struct
pp_print_list ~pp_op:pp_print_obrace' ~pp_cl:pp_print_cbrace' ~pp_sep
end
-let fprintf_list ?(eol : ('a, formatter, unit) format = "") ~sep f fmt l =
- Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "%(%)" sep) f fmt l);
- if l <> [] then Format.fprintf fmt "%(%)" eol
-
-let pp_list l pp_fun beg_str end_str sep_str =
- if beg_str = "\n" then print_newline () else print_string beg_str;
- let rec pp_l l =
- match l with
- | [] ->
- ()
- | [ hd ] ->
- pp_fun hd
- | hd :: tl ->
- pp_fun hd;
- if sep_str = "\n" then print_newline () else print_string sep_str;
- pp_l tl
- in
- pp_l l;
- if end_str = "\n" then print_newline () else print_string end_str
-
-let pp_array a pp_fun beg_str end_str sep_str =
- if beg_str = "\n" then print_newline () else print_string beg_str;
- let n = Array.length a in
- if n > 0 then (
- Array.iter
- (fun x ->
- pp_fun x;
- print_string sep_str)
- (Array.sub a 0 (n - 1));
- pp_fun a.(n - 1));
- if end_str = "\n" then print_newline () else print_string end_str
-
-let pp_hashtbl t pp_fun beg_str end_str sep_str =
- if beg_str = "\n" then print_newline () else print_string beg_str;
- let pp_fun1 k v =
- pp_fun k v;
- if sep_str = "\n" then print_newline () else print_string sep_str
- in
- hashtbl_iterlast t pp_fun1 pp_fun;
- if end_str = "\n" then print_newline () else print_string end_str
-
-let pp_longident lid =
- let pp_fun (nid, tag) =
- print_string nid;
- print_string "(";
- print_int tag;
- print_string ")"
- in
- pp_list lid pp_fun "" "." "."
-
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
@@ -446,11 +392,12 @@ let pp_date fmt tm =
(* Used for uid in variables *)
-let get_new_id =
- let var_id_cpt = ref 0 in
- fun () ->
- incr var_id_cpt;
- !var_id_cpt
+(* XXX: UNUSED *)
+(* let get_new_id =
+ * let var_id_cpt = ref 0 in
+ * fun () ->
+ * incr var_id_cpt;
+ * !var_id_cpt *)
let new_tag =
let last_tag = ref (-1) in
@@ -458,44 +405,46 @@ let new_tag =
incr last_tag;
!last_tag
-module List = struct
- include List
-
- let iteri2 f l1 l2 =
- if List.length l1 <> List.length l2 then
- raise (Invalid_argument "iteri2: lists have different lengths")
- else
- let rec run idx l1 l2 =
- match l1, l2 with
- | [], [] ->
- ()
- | hd1 :: tl1, hd2 :: tl2 ->
- f idx hd1 hd2;
- run (idx + 1) tl1 tl2
- | _ ->
- assert false
- in
- run 0 l1 l2
-
- let rec extract l fst last =
- if last < fst then assert false
- else
- match l, fst with
- | hd :: tl, 0 ->
- if last = 0 then [] else hd :: extract tl 0 (last - 1)
- | _ :: tl, _ ->
- extract tl (fst - 1) (last - 1)
- | [], 0 ->
- if last = 0 then [] else assert false (* List too short *)
- | _ ->
- assert false
-end
-
-let get_date () =
- let tm = Unix.localtime (Unix.time ()) in
- let fmt = Format.str_formatter in
- pp_date fmt tm;
- Format.flush_str_formatter ()
+(* XXX: UNUSED *)
+(* module List = struct
+ * include List
+ *
+ * let iteri2 f l1 l2 =
+ * if List.length l1 <> List.length l2 then
+ * raise (Invalid_argument "iteri2: lists have different lengths")
+ * else
+ * let rec run idx l1 l2 =
+ * match l1, l2 with
+ * | [], [] ->
+ * ()
+ * | hd1 :: tl1, hd2 :: tl2 ->
+ * f idx hd1 hd2;
+ * run (idx + 1) tl1 tl2
+ * | _ ->
+ * assert false
+ * in
+ * run 0 l1 l2
+ *
+ * let rec extract l fst last =
+ * if last < fst then assert false
+ * else
+ * match l, fst with
+ * | hd :: tl, 0 ->
+ * if last = 0 then [] else hd :: extract tl 0 (last - 1)
+ * | _ :: tl, _ ->
+ * extract tl (fst - 1) (last - 1)
+ * | [], 0 ->
+ * if last = 0 then [] else assert false (\* List too short *\)
+ * | _ ->
+ * assert false
+ * end *)
+
+(* XXX: UNUSED *)
+(* let get_date () =
+ * let tm = Unix.localtime (Unix.time ()) in
+ * let fmt = Format.str_formatter in
+ * pp_date fmt tm;
+ * Format.flush_str_formatter () *)
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/utils/utils.mli b/src/utils/utils.mli
index b7a8c729..9ad455b0 100644
--- a/src/utils/utils.mli
+++ b/src/utils/utils.mli
@@ -1,31 +1,52 @@
type ident = string
+
type tag = int
-module IMap: sig
+module IMap : sig
include Map.S with type key = ident
- val pp: ?comment:string -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
- val diff: 'a t -> 'a t -> 'a t
- val of_list: (key * 'a) list -> 'a t
+
+ val pp :
+ ?comment:string ->
+ (Format.formatter -> 'a -> unit) ->
+ Format.formatter ->
+ 'a t ->
+ unit
+
+ val diff : 'a t -> 'a t -> 'a t
+
+ val of_list : (key * 'a) list -> 'a t
end
-module ISet: sig
+module ISet : sig
include Set.S with type elt = ident
- val pp: Format.formatter -> t -> unit
+
+ val pp : Format.formatter -> t -> unit
end
-module Format: sig
+module Format : sig
include module type of Format
- val with_out_file: string -> (formatter -> unit) -> unit
- val pp_print_comma: formatter -> unit -> unit
- val pp_print_comma': formatter -> unit -> unit
- val pp_print_semicolon: formatter -> unit -> unit
- val pp_print_semicolon': formatter -> unit -> unit
- val pp_print_cpar: formatter -> unit -> unit
- val pp_open_vbox0: formatter -> unit -> unit
- val pp_print_cutcut: formatter -> unit -> unit
- val pp_print_nothing: formatter -> 'a -> unit
- val pp_print_endcut: string -> formatter -> unit -> unit
- val pp_print_list:
+
+ val with_out_file : string -> (formatter -> unit) -> unit
+
+ val pp_print_comma : formatter -> unit -> unit
+
+ val pp_print_comma' : formatter -> unit -> unit
+
+ val pp_print_semicolon : formatter -> unit -> unit
+
+ val pp_print_semicolon' : formatter -> unit -> unit
+
+ val pp_print_cpar : formatter -> unit -> unit
+
+ val pp_open_vbox0 : formatter -> unit -> unit
+
+ val pp_print_cutcut : formatter -> unit -> unit
+
+ val pp_print_nothing : formatter -> 'a -> unit
+
+ val pp_print_endcut : string -> formatter -> unit -> unit
+
+ val pp_print_list :
?pp_prologue:(formatter -> unit -> unit) ->
?pp_epilogue:(formatter -> unit -> unit) ->
?pp_op:(formatter -> unit -> unit) ->
@@ -34,8 +55,12 @@ module Format: sig
?pp_eol:(formatter -> unit -> unit) ->
?pp_nil:(formatter -> unit -> unit) ->
?pp_sep:(formatter -> unit -> unit) ->
- (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
- val pp_print_list_i:
+ (formatter -> 'a -> unit) ->
+ formatter ->
+ 'a list ->
+ unit
+
+ val pp_print_list_i :
?pp_prologue:(formatter -> unit -> unit) ->
?pp_epilogue:(formatter -> unit -> unit) ->
?pp_op:(formatter -> unit -> unit) ->
@@ -44,8 +69,12 @@ module Format: sig
?pp_eol:(formatter -> unit -> unit) ->
?pp_nil:(formatter -> unit -> unit) ->
?pp_sep:(formatter -> unit -> unit) ->
- (formatter -> int -> 'a -> unit) -> formatter -> 'a list -> unit
- val pp_print_list_i2:
+ (formatter -> int -> 'a -> unit) ->
+ formatter ->
+ 'a list ->
+ unit
+
+ val pp_print_list_i2 :
?pp_prologue:(formatter -> unit -> unit) ->
?pp_epilogue:(formatter -> unit -> unit) ->
?pp_op:(formatter -> unit -> unit) ->
@@ -54,8 +83,12 @@ module Format: sig
?pp_eol:(formatter -> unit -> unit) ->
?pp_nil:(formatter -> unit -> unit) ->
?pp_sep:(formatter -> unit -> unit) ->
- (formatter -> int -> 'a -> 'b -> unit) -> formatter -> 'a list * 'b list -> unit
- val pp_comma_list:
+ (formatter -> int -> 'a -> 'b -> unit) ->
+ formatter ->
+ 'a list * 'b list ->
+ unit
+
+ val pp_comma_list :
?pp_prologue:(formatter -> unit -> unit) ->
?pp_epilogue:(formatter -> unit -> unit) ->
?pp_op:(formatter -> unit -> unit) ->
@@ -63,50 +96,72 @@ module Format: sig
?pp_open_box:(formatter -> unit -> unit) ->
?pp_eol:(formatter -> unit -> unit) ->
?pp_nil:(formatter -> unit -> unit) ->
- (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
- val pp_print_parenthesized:
+ (formatter -> 'a -> unit) ->
+ formatter ->
+ 'a list ->
+ unit
+
+ val pp_print_parenthesized :
?pp_sep:(formatter -> unit -> unit) ->
?pp_prologue:(formatter -> unit -> unit) ->
?pp_epilogue:(formatter -> unit -> unit) ->
?pp_open_box:(formatter -> unit -> unit) ->
?pp_eol:(formatter -> unit -> unit) ->
?pp_nil:(formatter -> unit -> unit) ->
- (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
- val pp_print_bracketed:
+ (formatter -> 'a -> unit) ->
+ formatter ->
+ 'a list ->
+ unit
+
+ val pp_print_bracketed :
?pp_sep:(formatter -> unit -> unit) ->
?pp_prologue:(formatter -> unit -> unit) ->
?pp_epilogue:(formatter -> unit -> unit) ->
?pp_open_box:(formatter -> unit -> unit) ->
?pp_eol:(formatter -> unit -> unit) ->
?pp_nil:(formatter -> unit -> unit) ->
- (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
- val pp_print_braced:
+ (formatter -> 'a -> unit) ->
+ formatter ->
+ 'a list ->
+ unit
+
+ val pp_print_braced :
?pp_sep:(formatter -> unit -> unit) ->
?pp_prologue:(formatter -> unit -> unit) ->
?pp_epilogue:(formatter -> unit -> unit) ->
?pp_open_box:(formatter -> unit -> unit) ->
?pp_eol:(formatter -> unit -> unit) ->
?pp_nil:(formatter -> unit -> unit) ->
- (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
- val pp_print_braced':
+ (formatter -> 'a -> unit) ->
+ formatter ->
+ 'a list ->
+ unit
+
+ val pp_print_braced' :
?pp_sep:(formatter -> unit -> unit) ->
?pp_prologue:(formatter -> unit -> unit) ->
?pp_epilogue:(formatter -> unit -> unit) ->
?pp_open_box:(formatter -> unit -> unit) ->
?pp_eol:(formatter -> unit -> unit) ->
?pp_nil:(formatter -> unit -> unit) ->
- (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
+ (formatter -> 'a -> unit) ->
+ formatter ->
+ 'a list ->
+ unit
end
-module IdentDepGraph: Graph.Sig.I with type V.t = ident
-module TopologicalDepGraph: sig
+module IdentDepGraph : Graph.Sig.I with type V.t = ident
+
+module TopologicalDepGraph : sig
val fold : (ident -> 'a -> 'a) -> IdentDepGraph.t -> 'a -> 'a
+
val iter : (ident -> unit) -> IdentDepGraph.t -> unit
end
-module Bfs: sig
+
+module Bfs : sig
(* val iter : (ident -> unit) -> IdentDepGraph.t -> unit *)
val iter_component : (ident -> unit) -> IdentDepGraph.t -> ident -> unit
-
+
(* val fold : (G.V.t -> 'a -> 'a) -> 'a -> G.t -> 'a
* val fold_component : (G.V.t -> 'a -> 'a) -> 'a -> G.t -> G.V.t -> 'a
*
@@ -116,38 +171,38 @@ module Bfs: sig
* val get : iterator -> G.V.t *)
end
-val name_of_dimension: tag -> ident
+val name_of_dimension : tag -> ident
-val name_of_carrier: tag -> ident
+val name_of_carrier : tag -> ident
-val name_of_type: tag -> ident
+val name_of_type : tag -> ident
-val name_of_delay: tag -> ident
+val name_of_delay : tag -> ident
-val reset_names: unit -> unit
+val reset_names : unit -> unit
-val pp_date: Format.formatter -> Unix.tm -> unit
+val pp_date : Format.formatter -> Unix.tm -> unit
exception TransposeError of int * int
-val transpose_list: 'a list list -> 'a list list
+val transpose_list : 'a list list -> 'a list list
-val new_tag: unit -> tag
+val new_tag : unit -> tag
exception DeSome
-val desome: 'a option -> 'a
+val desome : 'a option -> 'a
-val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
+val create_hashtable : int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
-val option_map: ('a -> 'b) -> 'a option -> 'b option
+val option_map : ('a -> 'b) -> 'a option -> 'b option
-val repeat: int -> ('a -> 'a) -> 'a -> 'a
+val repeat : int -> ('a -> 'a) -> 'a -> 'a
-val add_cons: 'a -> 'a list -> 'a list
+val add_cons : 'a -> 'a list -> 'a list
-val enumerate: int -> int list
+val enumerate : int -> int list
-val duplicate: 'a -> int -> 'a list
+val duplicate : 'a -> int -> 'a list
-val list_union: 'a list -> 'a list -> 'a list
+val list_union : 'a list -> 'a list -> 'a list
diff --git a/src/verifierList.mli b/src/verifierList.mli
index 483bc7b1..430dce60 100644
--- a/src/verifierList.mli
+++ b/src/verifierList.mli
@@ -1 +1 @@
-val verifiers: unit -> (module VerifierType.S) list
+val verifiers : unit -> (module VerifierType.S) list
diff --git a/src/verifierType.ml b/src/verifierType.ml
deleted file mode 100644
index 836a9c31..00000000
--- a/src/verifierType.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-module type S = sig
- val name : string
-
- val activate : unit -> unit
-
- val is_active : unit -> bool
-
- val options : Options_management.options_spec
-
- val get_normalization_params : unit -> Normalization.param_t
-
- val run :
- basename:string ->
- Lustre_types.program_t ->
- Machine_code_types.machine_t list ->
- unit
-end
-
-module Default = struct
- let get_normalization_params () =
- {
- Normalization.unfold_arrow_active = true;
- force_alias_ite = false;
- force_alias_internal_fun = false;
- }
-end
diff --git a/src/verifiers.mli b/src/verifiers.mli
index 915ae8c1..856b77f8 100644
--- a/src/verifiers.mli
+++ b/src/verifiers.mli
@@ -1,2 +1,3 @@
-val get_active: unit -> (module VerifierType.S)
-val options: unit -> Options_management.options_spec
+val get_active : unit -> (module VerifierType.S)
+
+val options : unit -> Options_management.options_spec
diff --git a/src/version.mli b/src/version.mli
index d721a4b3..503772d0 100644
--- a/src/version.mli
+++ b/src/version.mli
@@ -1,4 +1,7 @@
-val number: string
-val codename: string
-val include_path: string
-val testgen_path: string
+val number : string
+
+val codename : string
+
+val include_path : string
+
+val testgen_path : string
--
GitLab