From f1896ffacb8c3d80adab96e49425b6f39f4ebdcf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?L=C3=A9lio=20Brun?= <lelio.brun@isae-supaero.fr>
Date: Wed, 13 Apr 2022 13:02:13 +0200
Subject: [PATCH] COSMETICS (dune build @fmt --auto-promote)
---
.ocamlformat | 2 +-
dune | 10 +-
offline_tests/dune | 3 +-
offline_tests/test.ml | 465 ++++++++++--------
src/annotations.ml | 2 -
src/annotations.mli | 3 -
src/arrow.ml | 1 -
src/arrow.mli | 3 -
src/arrow_taint.ml | 61 ++-
src/automata.ml | 15 +-
src/automata.mli | 1 -
src/backends/Ada/ada_backend_adb.ml | 2 +-
src/backends/Ada/ada_backend_ads.ml | 10 +-
src/backends/Ada/ada_backend_common.mli | 19 -
src/backends/Ada/ada_printer.ml | 3 -
src/backends/Ada/ada_printer.mli | 17 -
src/backends/Ada/misc_lustre_function.ml | 3 +-
src/backends/Ada/misc_lustre_function.mli | 1 -
src/backends/C/c_backend.ml | 3 +-
src/backends/C/c_backend_common.ml | 31 +-
src/backends/C/c_backend_common.mli | 42 --
src/backends/C/c_backend_header.ml | 4 -
src/backends/C/c_backend_header.mli | 3 -
src/backends/C/c_backend_main.ml | 5 -
src/backends/C/c_backend_main.mli | 2 -
src/backends/C/c_backend_makefile.ml | 75 ++-
src/backends/C/c_backend_makefile.mli | 4 -
src/backends/C/c_backend_mauve.ml | 2 -
src/backends/C/c_backend_mauve.mli | 3 -
src/backends/C/c_backend_spec.ml | 298 +++++------
src/backends/C/c_backend_spec.mli | 3 -
src/backends/C/c_backend_src.ml | 31 +-
src/backends/C/c_backend_src.mli | 10 +-
src/backends/EMF/EMF_common.ml | 1 -
src/backends/EMF/EMF_common.mli | 13 -
src/backends/Horn/horn_backend.mli | 5 +-
src/backends/Horn/horn_backend_common.ml | 24 +-
src/backends/Horn/horn_backend_common.mli | 35 +-
src/backends/Horn/horn_backend_printers.ml | 2 -
src/backends/Horn/horn_backend_printers.mli | 3 -
src/backends/Java/java_backend.ml | 1 -
src/backends/VHDL/vhdl_ast.ml | 5 -
src/backends/backends.mli | 3 -
src/basic_library.ml | 5 -
src/basic_library.mli | 12 -
src/causality.ml | 8 +-
src/causality.mli | 23 +-
src/checks/algebraicLoop.ml | 1 -
src/checks/liveness.mli | 4 +-
src/checks/stateless.mli | 4 -
src/clock_calculus.ml | 7 +-
src/clock_calculus.mli | 4 -
src/clock_predef.mli | 3 -
src/clocks.ml | 20 +-
src/clocks.mli | 26 -
src/compiler_common.ml | 3 +-
src/compiler_common.mli | 7 -
src/corelang.ml | 31 +-
src/corelang.mli | 89 ----
src/delay.ml | 1 -
src/delay.mli | 2 -
src/delay_predef.mli | 3 -
src/error.mli | 3 -
src/features/machine_types/machine_types.ml | 21 +-
src/features/machine_types/machine_types.mli | 8 -
src/global.mli | 3 -
src/inliner.ml | 2 +-
src/inliner.mli | 2 -
src/lusic.mli | 1 -
src/lustre_live.ml | 2 -
src/lustre_live.mli | 2 -
src/lustre_types.ml | 4 -
src/lustre_types.mli | 5 -
src/lustre_utils.ml | 2 +-
src/lustre_utils.mli | 3 +-
src/machine_code.ml | 161 +++---
src/machine_code_common.ml | 61 ++-
src/machine_code_common.mli | 26 -
src/machine_code_dep.ml | 56 ++-
src/machine_code_types.mli | 46 +-
src/main_lustre_compiler.ml | 1 -
src/main_lustre_testgen.ml | 1 -
src/main_lustre_verifier.ml | 1 -
src/mutation.ml | 7 -
src/mutation.mli | 2 -
src/optimize_machine.ml | 304 +++++++-----
src/options.ml | 32 --
src/options.mli | 40 --
src/options_management.ml | 1 -
src/options_management.mli | 6 -
src/pathConditions.ml | 3 +-
src/plugins/mpfr/lustrec_mpfr.ml | 12 +-
src/plugins/mpfr/lustrec_mpfr.mli | 8 -
src/plugins/pluginList.ml | 1 -
src/plugins/pluginList.mli | 1 -
src/plugins/pluginType.ml | 13 -
src/plugins/pluginType.mli | 5 -
src/plugins/plugins.mli | 4 -
src/plugins/salsa/salsaDatatypes.ml | 4 -
src/plugins/scopes/scopes.ml | 14 +-
src/plugins/scopes/scopes.mli | 1 -
src/printers.ml | 3 -
src/printers.mli | 23 +-
src/real.ml | 16 -
src/real.mli | 16 -
src/scheduling.ml | 7 +-
src/scheduling.mli | 4 -
src/sortProg.mli | 1 -
src/spec_common.ml | 7 +-
src/spec_common.mli | 7 -
src/splitting.mli | 1 -
src/tools/importer/vhdl_json_lib.ml | 1 -
src/tools/importer/vhdl_json_lib.mli | 5 -
src/tools/seal/seal_export.ml | 13 +-
src/tools/seal/seal_export.mli | 36 +-
src/tools/seal/seal_extract.ml | 11 +-
src/tools/seal/seal_extract.mli | 19 +-
src/tools/seal/seal_slice.ml | 24 +-
src/tools/seal/seal_slice.mli | 8 +-
src/tools/seal/seal_utils.ml | 7 -
src/tools/seal/seal_utils.mli | 72 ++-
src/tools/seal/seal_verifier.ml | 2 -
src/tools/stateflow/common/basetypes.ml | 27 -
src/tools/stateflow/common/basetypes.mli | 20 -
src/tools/stateflow/common/datatype.ml | 126 +++--
src/tools/stateflow/common/datatype.mli | 21 +-
.../stateflow/json-parser/json_parser.ml | 201 ++++----
.../json-parser/test_json_parser_variables.ml | 2 -
src/tools/stateflow/models/model_simple.mli | 2 -
src/tools/stateflow/models/model_stopwatch.ml | 40 +-
.../stateflow/models/model_stopwatch.mli | 2 -
src/tools/stateflow/semantics/cPS.ml | 1 -
.../semantics/cPS_ccode_generator.ml | 2 -
.../stateflow/semantics/cPS_evaluator.ml | 9 +-
.../stateflow/semantics/cPS_interpreter.ml | 2 -
.../stateflow/semantics/cPS_interpreter.mli | 2 -
.../semantics/cPS_lustre_generator.ml | 4 -
.../semantics/cPS_lustre_generator.mli | 1 -
.../stateflow/semantics/cPS_transformer.ml | 24 -
.../stateflow/semantics/cPS_transformer.mli | 14 -
src/tools/stateflow/semantics/memo.ml | 2 -
src/tools/stateflow/semantics/memo.mli | 1 -
src/tools/stateflow/semantics/theta.ml | 2 -
src/tools/stateflow/sf_sem.ml | 72 ++-
src/tools/tiny/tiny_tube.ml | 311 ++++++------
src/tools/tiny/tiny_utils.ml | 458 +++++++++--------
src/tools/tiny/tiny_utils.mli | 11 +-
src/tools/tiny/tiny_verifier.ml | 193 ++++----
src/tools/zustre/zustre_analyze.ml | 1 -
src/tools/zustre/zustre_analyze.mli | 2 +-
src/tools/zustre/zustre_cex.ml | 5 +-
src/tools/zustre/zustre_cex.mli | 10 +-
src/tools/zustre/zustre_common.ml | 61 +--
src/tools/zustre/zustre_common.mli | 93 ++--
src/tools/zustre/zustre_data.ml | 19 +-
src/tools/zustre/zustre_data.mli | 14 +-
src/tools/zustre/zustre_test.ml | 3 -
src/type_predef.ml | 12 -
src/type_predef.mli | 23 -
src/types.ml | 67 ---
src/types.mli | 50 --
src/typing.ml | 5 +-
src/typing.mli | 6 -
src/utils/dimension.ml | 19 +-
src/utils/dimension.mli | 24 -
src/utils/env.ml | 5 -
src/utils/env.mli | 7 -
src/utils/location.ml | 6 +-
src/utils/location.mli | 14 +-
src/utils/utils.ml | 25 -
src/utils/utils.mli | 37 +-
src/verifierList.ml | 1 -
src/verifierList.mli | 2 +-
src/verifierType.ml | 38 +-
src/verifierType.mli | 11 +-
src/verifiers.ml | 1 -
src/verifiers.mli | 1 -
src/version.ml | 3 -
src/version.mli | 3 -
strategy.ml | 205 ++++----
unused/mmap.ml | 25 -
181 files changed, 2075 insertions(+), 2907 deletions(-)
diff --git a/.ocamlformat b/.ocamlformat
index dbb4a387..c4a2f22e 100644
--- a/.ocamlformat
+++ b/.ocamlformat
@@ -1,4 +1,4 @@
-version=0.19.0
+version=0.20.1
parens-tuple=multi-line-only
wrap-comments=true
cases-exp-indent=2
diff --git a/dune b/dune
index 69515632..2ecaccdd 100644
--- a/dune
+++ b/dune
@@ -54,12 +54,4 @@
"-DLUSTRE_INCLUDE_DIR=%{project_root}/include"
"-DLUSTRE_COMPILER=%{bin:lustrec}"
.)
- (run
- ctest
- -D
- Experimental
- -R
- "COMPIL_LUS|MAKE|BIN|DIFF"
- -E
- LUSTRET)
-))))
+ (run ctest -D Experimental -R "COMPIL_LUS|MAKE|BIN|DIFF" -E LUSTRET)))))
diff --git a/offline_tests/dune b/offline_tests/dune
index b7d17be4..8af53d09 100644
--- a/offline_tests/dune
+++ b/offline_tests/dune
@@ -3,7 +3,8 @@
(libraries re unix yojson)
(deps
(:strategy %{project_root}/strategy.ml)
- (:lus (glob_files *.lus))
+ (:lus
+ (glob_files *.lus))
(:ign ignored))
(action
(progn
diff --git a/offline_tests/test.ml b/offline_tests/test.ml
index c2d55db5..700baa8a 100644
--- a/offline_tests/test.ml
+++ b/offline_tests/test.ml
@@ -2,58 +2,63 @@ open Format
open Unix
module S = struct
- include Set.Make(String)
+ include Set.Make (String)
+
let pp fmt = iter (fprintf fmt "%s@;")
end
module ST = struct
- include Set.Make(
- struct
- type t = string * int * int * float
- let compare (x1, _, _, _) (x2, _, _, _) = compare x1 x2
- end)
- let pp fmt = iter (fun (x, loc, n, t) -> fprintf fmt "%s %d %d %f@;" x loc n t)
+ include Set.Make (struct
+ type t = string * int * int * float
+
+ let compare (x1, _, _, _) (x2, _, _, _) = compare x1 x2
+ end)
+
+ let pp fmt =
+ iter (fun (x, loc, n, t) -> fprintf fmt "%s %d %d %f@;" x loc n t)
end
module STF = struct
- include Set.Make(
- struct
- type t = string * (int * int) option
- let compare (x1, _) (x2, _) = compare x1 x2
- end)
- let pp fmt = iter (fun (x, o) -> fprintf fmt "%s %a@;" x
- (pp_print_option (fun fmt (r, g) -> fprintf fmt "%d %d" r g)) o)
+ include Set.Make (struct
+ type t = string * (int * int) option
+
+ let compare (x1, _) (x2, _) = compare x1 x2
+ end)
+
+ let pp fmt =
+ iter (fun (x, o) ->
+ fprintf
+ fmt
+ "%s %a@;"
+ x
+ (pp_print_option (fun fmt (r, g) -> fprintf fmt "%d %d" r g))
+ o)
end
-module M = Map.Make(Int)
+module M = Map.Make (Int)
type report = {
- compiled: S.t;
- verified: ST.t M.t;
- failed: STF.t;
- ninits: S.t
-}
-let empty_report = {
- compiled = S.empty;
- verified = M.empty;
- failed = STF.empty;
- ninits = S.empty
+ compiled : S.t;
+ verified : ST.t M.t;
+ failed : STF.t;
+ ninits : S.t;
}
-let dir = "../../../offline_tests_build"
+let empty_report =
+ {
+ compiled = S.empty;
+ verified = M.empty;
+ failed = STF.empty;
+ ninits = S.empty;
+ }
+let dir = "../../../offline_tests_build"
let _ = try Unix.mkdir dir 0o755 with _ -> ()
-
let report_f = Filename.concat dir "report"
-
let section h = "# " ^ h
-
let end_section = "##"
-
let compiled_section = section "COMPILED"
-
let ninit_section = section "BAD_INIT"
-
let initial_timeout = 15
let next_timeout r =
@@ -63,33 +68,33 @@ let timeout_section i = section (sprintf "TIMEOUT %d" i)
let timeout_of_section h =
match Re.Str.(split (regexp_string " ")) h with
- | ["#"; "TIMEOUT"; i] -> Some (int_of_string i)
- | _ -> None
+ | [ "#"; "TIMEOUT"; i ] ->
+ Some (int_of_string i)
+ | _ ->
+ None
let failed_section = section "FAILED"
-
-let is_compiled report f =
- S.mem f report.compiled
-
-let add_compiled report f =
- { report with compiled = S.add f report.compiled }
-
-let is_ninit report f =
- S.mem f report.ninits
-
-let add_ninit report f =
- { report with ninits = S.add f report.ninits }
+let is_compiled report f = S.mem f report.compiled
+let add_compiled report f = { report with compiled = S.add f report.compiled }
+let is_ninit report f = S.mem f report.ninits
+let add_ninit report f = { report with ninits = S.add f report.ninits }
let is_verified report f =
M.exists (fun _ -> ST.exists (fun (x, _, _, _) -> x = f)) report.verified
let add_verified report i f loc n t =
- { report with verified = M.update i (fun s ->
- let s = match s with None -> ST.empty | Some s -> s in
- Some (ST.add (f, loc, n, t) s)) report.verified }
-
-let is_failed report f =
- STF.exists (fun (x, _) -> x = f) report.failed
+ {
+ report with
+ verified =
+ M.update
+ i
+ (fun s ->
+ let s = match s with None -> ST.empty | Some s -> s in
+ Some (ST.add (f, loc, n, t) s))
+ report.verified;
+ }
+
+let is_failed report f = STF.exists (fun (x, _) -> x = f) report.failed
let add_failed report ?goals f =
{ report with failed = STF.add (f, goals) report.failed }
@@ -98,44 +103,67 @@ let parse_report () =
try
let ic = open_in report_f in
let rec read_compiled r =
- try match input_line ic with
- | "" -> read_compiled r
- | f -> if f = end_section then r else read_compiled (add_compiled r f)
+ try
+ match input_line ic with
+ | "" ->
+ read_compiled r
+ | f ->
+ if f = end_section then r else read_compiled (add_compiled r f)
with End_of_file -> r
in
let rec read_verified i r =
- try match input_line ic with
- | "" -> read_verified i r
- | f ->
+ try
+ match input_line ic with
+ | "" ->
+ read_verified i r
+ | f -> (
if f = end_section then r
- else match String.split_on_char ' ' f with
- | [f; loc; n; t] ->
- read_verified i
- (add_verified r i f
- (int_of_string loc) (int_of_string n) (float_of_string t))
- | _ -> assert false
+ else
+ match String.split_on_char ' ' f with
+ | [ f; loc; n; t ] ->
+ read_verified
+ i
+ (add_verified
+ r
+ i
+ f
+ (int_of_string loc)
+ (int_of_string n)
+ (float_of_string t))
+ | _ ->
+ assert false)
with End_of_file -> r
in
let rec read_ninits r =
- try match input_line ic with
- | "" -> read_ninits r
- | f -> if f = end_section then r else read_ninits (add_ninit r f)
+ try
+ match input_line ic with
+ | "" ->
+ read_ninits r
+ | f ->
+ if f = end_section then r else read_ninits (add_ninit r f)
with End_of_file -> r
in
let rec read_failed r =
- try match input_line ic with
- | "" -> read_failed r
- | f -> if f = end_section then r
- else match String.split_on_char ' ' f with
- | [f; res; goa] ->
- read_failed (add_failed r ~goals:(int_of_string res, int_of_string goa) f)
+ try
+ match input_line ic with
+ | "" ->
+ read_failed r
+ | f -> (
+ if f = end_section then r
+ else
+ match String.split_on_char ' ' f with
+ | [ f; res; goa ] ->
+ read_failed
+ (add_failed r ~goals:(int_of_string res, int_of_string goa) f)
| f :: _ ->
read_failed (add_failed r f)
- | _ -> assert false
+ | _ ->
+ assert false)
with End_of_file -> r
in
let rec read r =
- try match input_line ic with
+ try
+ match input_line ic with
| "" ->
read r
| f when f = compiled_section ->
@@ -145,9 +173,12 @@ let parse_report () =
| f when f = ninit_section ->
read (read_ninits r)
| f ->
- let r = match timeout_of_section f with
- | Some i -> read_verified i r
- | None -> r
+ let r =
+ match timeout_of_section f with
+ | Some i ->
+ read_verified i r
+ | None ->
+ r
in
read r
with End_of_file -> r
@@ -158,22 +189,13 @@ let parse_report () =
with _ -> empty_report
let pp_compiled fmt report =
- fprintf fmt "%s@;%a%s@;"
- compiled_section
- S.pp report.compiled
- end_section
+ fprintf fmt "%s@;%a%s@;" compiled_section S.pp report.compiled end_section
let pp_failed fmt report =
- fprintf fmt "%s@;%a%s@;"
- failed_section
- STF.pp report.failed
- end_section
+ fprintf fmt "%s@;%a%s@;" failed_section STF.pp report.failed end_section
let pp_ninits fmt report =
- fprintf fmt "%s@;%a%s@;"
- ninit_section
- S.pp report.ninits
- end_section
+ fprintf fmt "%s@;%a%s@;" ninit_section S.pp report.ninits end_section
let pp_verified fmt report =
pp_print_list
@@ -183,11 +205,17 @@ let pp_verified fmt report =
(List.sort (fun (i, _) (j, _) -> compare i j) (M.bindings report.verified))
let pp_report fmt report =
- fprintf fmt "@[<v>%a@;%a@;%a@;%a@]@."
- pp_compiled report
- pp_ninits report
- pp_failed report
- pp_verified report
+ fprintf
+ fmt
+ "@[<v>%a@;%a@;%a@;%a@]@."
+ pp_compiled
+ report
+ pp_ninits
+ report
+ pp_failed
+ report
+ pp_verified
+ report
let write_report report =
let oc = open_out report_f in
@@ -198,21 +226,23 @@ let write_report report =
let config_format_tags =
set_tags true;
let mark_open_stag = function
- | String_tag "bold" -> "\x1b[1m"
- | String_tag "red" -> "\x1b[31m"
- | String_tag "magenta" -> "\x1b[35m"
- | String_tag "green" -> "\x1b[32m"
- | _ -> ""
+ | String_tag "bold" ->
+ "\x1b[1m"
+ | String_tag "red" ->
+ "\x1b[31m"
+ | String_tag "magenta" ->
+ "\x1b[35m"
+ | String_tag "green" ->
+ "\x1b[32m"
+ | _ ->
+ ""
in
let mark_close_stag _ = "\x1b[0m" in
let stag_fns = get_formatter_stag_functions () in
set_formatter_stag_functions { stag_fns with mark_open_stag; mark_close_stag }
-let pp_header fmt =
- fprintf fmt "@{<bold>%s:@}"
-
+let pp_header fmt = fprintf fmt "@{<bold>%s:@}"
let max_l = ref 0
-
let err_f = "/tmp/err"
let read_whole_file f =
@@ -223,7 +253,9 @@ let read_whole_file f =
let has_warning log =
let open Re.Str in
- let reg = "Warning: Generating stateful spec for uninitialized state variable" in
+ let reg =
+ "Warning: Generating stateful spec for uninitialized state variable"
+ in
try
search_forward (regexp reg) log 0 |> ignore;
true
@@ -237,11 +269,18 @@ let print_results ok ko w n =
let compile report lustrec fs =
printf "@.%a@." pp_header "Compilation tests";
- max_l := List.fold_left (fun m f -> let n = String.length f in max n m) 0 fs;
+ max_l :=
+ List.fold_left
+ (fun m f ->
+ let n = String.length f in
+ max n m)
+ 0
+ fs;
let n = List.length fs in
let n_f = float_of_int n in
let report, ok, ko, ninits, _ =
- List.fold_left (fun (report, ok, ko, ninits, i) f ->
+ List.fold_left
+ (fun (report, ok, ko, ninits, i) f ->
let i' = i + 1 in
let p = float_of_int i' *. 100. /. n_f in
let success r : _ * _ * _ * _ * _ format * _ =
@@ -257,80 +296,80 @@ let compile report lustrec fs =
if is_compiled report f then success report
else if is_ninit report f then ninit report
else
- let cmd = Filename.quote_command ~stderr:err_f lustrec
- ["-acsl-spec"; "-d"; dir; f]
+ let cmd =
+ Filename.quote_command
+ ~stderr:err_f
+ lustrec
+ [ "-acsl-spec"; "-d"; dir; f ]
in
let ic = open_process_in cmd in
- let b = match close_process_in ic with
- | WEXITED r -> r = 0
- | _ -> false
+ let b =
+ match close_process_in ic with WEXITED r -> r = 0 | _ -> false
in
let log = read_whole_file err_f in
if b then
- if has_warning log
- then ninit (add_ninit report f)
+ if has_warning log then ninit (add_ninit report f)
else success (add_compiled report f)
- else
- fail report log
+ else fail report log
in
print_result p f fmt_str check;
write_report report;
report, ok, ko, ninits, i')
- (report, 0, 0, 0, 0) fs
+ (report, 0, 0, 0, 0)
+ fs
in
print_results ok ko ninits n;
report
let frama_c = "frama-c"
-let wp_provers =
- [
- "alt-ergo";
- "z3";
- "cvc4"
- ] |> String.concat ","
-let wp_models =
- [
- "ref";
- "real"
- ] |> String.concat ","
+let wp_provers = [ "alt-ergo"; "z3"; "cvc4" ] |> String.concat ","
+let wp_models = [ "ref"; "real" ] |> String.concat ","
let wp_timeout = 60 |> string_of_int
let wp_par = 48 |> string_of_int
let wp_cache = "none"
+
(* let wp_cache_dir = Filename.concat dir "cache" *)
let wp_args =
[
"-wp";
- "-wp-prover"; wp_provers;
- "-wp-model"; wp_models;
+ "-wp-prover";
+ wp_provers;
+ "-wp-model";
+ wp_models;
"-wp-no-warn-memory-model";
- "-wp-timeout"; wp_timeout;
- "-wp-par"; wp_par;
+ "-wp-timeout";
+ wp_timeout;
+ "-wp-par";
+ wp_par;
(* "-wp-cache-dir"; wp_cache_dir *)
- "-wp-cache"; wp_cache;
+ "-wp-cache";
+ wp_cache;
]
+
let wp_module = "strategy.ml"
+
let wp_strategy =
- String.concat ","
- [
- "LustreC:Transitions";
- "LustreC:ResetCleared";
- "LustreC:MemoryPacks"
- ]
+ String.concat
+ ","
+ [ "LustreC:Transitions"; "LustreC:ResetCleared"; "LustreC:MemoryPacks" ]
+
let wp_auto_depth = 100 |> string_of_int
let wp_auto_width = 100 |> string_of_int
+
let wp_strategy_args =
- wp_args @
- [
- "-load-module"; wp_module;
- "-wp-auto"; wp_strategy;
- "-wp-auto-depth"; wp_auto_depth;
- "-wp-auto-width"; wp_auto_width;
- ]
-let frama_c_args f =
wp_args
- @ f
- :: "-then"
- :: wp_strategy_args
+ @ [
+ "-load-module";
+ wp_module;
+ "-wp-auto";
+ wp_strategy;
+ "-wp-auto-depth";
+ wp_auto_depth;
+ "-wp-auto-width";
+ wp_auto_width;
+ ]
+
+let frama_c_args f = wp_args @ (f :: "-then" :: wp_strategy_args)
let frama_c_cmd f = frama_c :: frama_c_args f
let goals log =
@@ -342,9 +381,12 @@ let goals log =
let i = j + String.length (matched_string log) in
let resolved = matched_group 1 log |> int_of_string in
let goals = matched_group 2 log |> int_of_string in
- let acc = match acc with
- | Some (r, _) -> Some (r + resolved, r + goals)
- | None -> Some (resolved, goals)
+ let acc =
+ match acc with
+ | Some (r, _) ->
+ Some (r + resolved, r + goals)
+ | None ->
+ Some (resolved, goals)
in
aux acc i
with Not_found -> acc
@@ -354,47 +396,57 @@ let goals log =
let get_loc f =
let open Yojson.Safe in
let open Util in
- let cmd = Filename.quote_command ~stdout:err_f "tokei" ["-o"; "json"; f] in
+ let cmd = Filename.quote_command ~stdout:err_f "tokei" [ "-o"; "json"; f ] in
let ic = open_process_in cmd in
match close_process_in ic with
- | WEXITED 0 ->
- begin try
- from_file err_f |> member "C" |> member "code" |> to_int
- with _ -> -1
- end
- | _ -> -1
+ | WEXITED 0 -> (
+ try from_file err_f |> member "C" |> member "code" |> to_int with _ -> -1)
+ | _ ->
+ -1
let frama_c_session = "./frama-c"
let rec rmrf path =
try
- if Sys.is_directory path then begin
- Sys.readdir path |>
- Array.iter (fun name -> rmrf (Filename.concat path name));
- Unix.rmdir path
- end else Sys.remove path
+ if Sys.is_directory path then (
+ Sys.readdir path
+ |> Array.iter (fun name -> rmrf (Filename.concat path name));
+ Unix.rmdir path)
+ else Sys.remove path
with _ -> ()
-
let rec verify report timeout fs =
- if fs <> [] then begin
- printf "@.%a@."
- pp_header (sprintf "Verification tests - %is timeout" timeout);
+ if fs <> [] then (
+ printf
+ "@.%a@."
+ pp_header
+ (sprintf "Verification tests - %is timeout" timeout);
let n = List.length fs in
let n_f = float_of_int n in
let report, ok, ko, tm, _, fs =
- List.fold_left (fun (report, ok, ko, tm, i, fs) f ->
+ List.fold_left
+ (fun (report, ok, ko, tm, i, fs) f ->
let f' = Filename.remove_extension f ^ ".c" in
let f'' = Filename.concat dir f' in
let i' = i + 1 in
let p = float_of_int i' *. 100. /. n_f in
- let success ?(already=false) r : _ * _ * _ * _ * _ format * _ * _ =
- r, ok + 1, ko, tm, "@{<green>%s@}",
- ("OK" ^ if already then " (A)" else ""), fs
+ let success ?(already = false) r : _ * _ * _ * _ * _ format * _ * _ =
+ ( r,
+ ok + 1,
+ ko,
+ tm,
+ "@{<green>%s@}",
+ ("OK" ^ if already then " (A)" else ""),
+ fs )
in
- let fail ?(already=false) r : _ * _ * _ * _ * _ format * _ * _ =
- r, ok, ko + 1, tm, "@{<red>%s@}",
- ("KO" ^ if already then " (A)" else "\n" ^ read_whole_file err_f), fs
+ let fail ?(already = false) r : _ * _ * _ * _ * _ format * _ * _ =
+ ( r,
+ ok,
+ ko + 1,
+ tm,
+ "@{<red>%s@}",
+ ("KO" ^ if already then " (A)" else "\n" ^ read_whole_file err_f),
+ fs )
in
let tm r f : _ * _ * _ * _ * _ format * _ * _ =
r, ok, ko, tm + 1, "@{<magenta>%s@}", "TO", f :: fs
@@ -402,44 +454,48 @@ let rec verify report timeout fs =
let report, ok, ko, tm, fmt_str, check, fs =
if is_verified report f' then success ~already:true report
else if is_failed report f' then fail ~already:true report
- else begin
+ else (
rmrf frama_c_session;
- let cmd = Filename.quote_command ~stdout:err_f "timeout"
+ let cmd =
+ Filename.quote_command
+ ~stdout:err_f
+ "timeout"
(string_of_int timeout :: frama_c_cmd f'')
in
let t = Unix.gettimeofday () in
let ic = open_process_in cmd in
match close_process_in ic with
- | WEXITED 0 ->
+ | WEXITED 0 -> (
let t = Unix.gettimeofday () -. t in
let log = read_whole_file err_f in
- begin match goals log with
- | Some (n, m) ->
- if n = m then
- success (add_verified report timeout f' (get_loc f'') n t)
- else
- fail (add_failed report ~goals:(n, m) f')
- | None -> fail (add_failed report f')
- end
+ match goals log with
+ | Some (n, m) ->
+ if n = m then
+ success (add_verified report timeout f' (get_loc f'') n t)
+ else fail (add_failed report ~goals:(n, m) f')
+ | None ->
+ fail (add_failed report f'))
| WEXITED 124 ->
tm report f
| _ ->
- fail (add_failed report f')
- end
+ fail (add_failed report f'))
in
print_result p f' fmt_str check;
write_report report;
report, ok, ko, tm, i', fs)
- (report, 0, 0, 0, 0, []) fs
+ (report, 0, 0, 0, 0, [])
+ fs
in
print_results ok ko tm n;
- verify report (timeout * 2) fs
- end
+ verify report (timeout * 2) fs)
let print_ignored fs =
- printf "@.@[<v 2>%a@;%a@]@."
- pp_header "Ignored tests"
- (pp_print_list pp_print_string) fs
+ printf
+ "@.@[<v 2>%a@;%a@]@."
+ pp_header
+ "Ignored tests"
+ (pp_print_list pp_print_string)
+ fs
let () =
let lustrec = Sys.argv.(1) in
@@ -447,24 +503,23 @@ let () =
let ignored_f = Sys.argv.(3) in
let ignored_fs =
let ic = open_in ignored_f in
- let rec read fs =
- try
- read (input_line ic :: fs)
- with End_of_file -> fs
- in
+ let rec read fs = try read (input_line ic :: fs) with End_of_file -> fs in
let fs = read [] in
close_in ic;
fs
in
let report = parse_report () in
let report = compile report lustrec lus_fs in
- let ignored_fs = ignored_fs
- @ List.map Filename.chop_extension (S.elements report.ninits)
+ let ignored_fs =
+ ignored_fs @ List.map Filename.chop_extension (S.elements report.ninits)
in
print_ignored (List.map (fun f -> f ^ ".c") ignored_fs);
let lus_fs =
- List.(sort_uniq compare
- (filter (fun f ->
- not (mem (Filename.chop_extension f) ignored_fs)) lus_fs))
+ List.(
+ sort_uniq
+ compare
+ (filter
+ (fun f -> not (mem (Filename.chop_extension f) ignored_fs))
+ lus_fs))
in
verify report (next_timeout report) lus_fs
diff --git a/src/annotations.ml b/src/annotations.ml
index a82bf185..2b178f7a 100644
--- a/src/annotations.ml
+++ b/src/annotations.ml
@@ -13,12 +13,10 @@ open Utils
(* Associate to each annotation key the pair (node, expr tag) *)
let expr_annotations : (string list, ident * tag) Hashtbl.t = Hashtbl.create 13
-
let node_annotations : (string list, ident) Hashtbl.t = Hashtbl.create 13
let add_expr_ann node_id expr_tag key =
Hashtbl.add expr_annotations key (node_id, expr_tag)
let add_node_ann node_id key = Hashtbl.add node_annotations key node_id
-
let get_expr_annotations key = Hashtbl.find_all expr_annotations key
diff --git a/src/annotations.mli b/src/annotations.mli
index 83426bbf..90375429 100644
--- a/src/annotations.mli
+++ b/src/annotations.mli
@@ -1,9 +1,6 @@
open Utils
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
diff --git a/src/arrow.ml b/src/arrow.ml
index a5b57e96..ef0a1f3c 100644
--- a/src/arrow.ml
+++ b/src/arrow.ml
@@ -1,7 +1,6 @@
open Lustre_types
let arrow_id = "_arrow"
-
let arrow_typ = Types.new_ty Types.Tunivar
let arrow_desc =
diff --git a/src/arrow.mli b/src/arrow.mli
index 87062c35..f944948c 100644
--- a/src/arrow.mli
+++ b/src/arrow.mli
@@ -1,7 +1,4 @@
val arrow_id : string
-
val arrow_top_decl : unit -> Lustre_types.top_decl
-
val arrow_desc : Lustre_types.node_desc
-
val td_is_arrow : Lustre_types.top_decl -> bool
diff --git a/src/arrow_taint.ml b/src/arrow_taint.ml
index 79b10ce7..46df4d26 100644
--- a/src/arrow_taint.ml
+++ b/src/arrow_taint.ml
@@ -3,46 +3,57 @@ open Corelang
let find_taint_arrow eqs locals (x, _) =
let ck_x = x.var_clock in
- x,
- List.find_map (fun eq -> match eq.eq_lhs, eq.eq_rhs.expr_desc with
- | [y], Expr_arrow _ ->
- let o_ck_y = List.find_map (fun (v, _) ->
- if v.var_id = y then Some v.var_clock else None) locals
- in
- begin match o_ck_y with
+ ( x,
+ List.find_map
+ (fun eq ->
+ match eq.eq_lhs, eq.eq_rhs.expr_desc with
+ | [ y ], Expr_arrow _ -> (
+ let o_ck_y =
+ List.find_map
+ (fun (v, _) -> if v.var_id = y then Some v.var_clock else None)
+ locals
+ in
+ match o_ck_y with
| Some ck_y ->
(* if (x.var_id = "__if_multi_test_9") then *)
- (* Format.printf "%s :: %a (%d) - %s :: %a (%d)\n" x.var_id Clocks.pp ck_x ck_x.cid y Clocks.pp ck_y ck_y.cid; *)
+ (* Format.printf "%s :: %a (%d) - %s :: %a (%d)\n" x.var_id
+ Clocks.pp ck_x ck_x.cid y Clocks.pp ck_y ck_y.cid; *)
if Clocks.equal ck_y ck_x then Some y else None
- | _ -> None
- end
- | _ -> None) eqs
+ | _ ->
+ None)
+ | _ ->
+ None)
+ eqs )
let arrow_taint_node node =
let eqs, auts = get_node_eqs node in
if auts != [] then assert false;
(* Automata should be expanded by now. *)
- let node_locals = List.map (find_taint_arrow eqs node.node_locals) node.node_locals in
+ let node_locals =
+ List.map (find_taint_arrow eqs node.node_locals) node.node_locals
+ in
{ node with node_locals }
let arrow_taint_inode nd =
match nd.nodei_spec with
- | None | Some (NodeSpec _) -> nd
- | Some (Contract _) -> assert false
+ | None | Some (NodeSpec _) ->
+ nd
+ | Some (Contract _) ->
+ assert false
let arrow_taint_decl decl =
match decl.top_decl_desc with
| Node nd ->
- let decl' = { decl with top_decl_desc = Node (arrow_taint_node nd) } in
- update_node nd.node_id decl';
- decl'
+ let decl' = { decl with top_decl_desc = Node (arrow_taint_node nd) } in
+ update_node nd.node_id decl';
+ decl'
| ImportedNode nd ->
- let decl' =
- { decl with top_decl_desc = ImportedNode (arrow_taint_inode nd) }
- in
- update_node nd.nodei_id decl';
- decl'
- | Include _ | Open _ | Const _ | TypeDef _ -> decl
+ let decl' =
+ { decl with top_decl_desc = ImportedNode (arrow_taint_inode nd) }
+ in
+ update_node nd.nodei_id decl';
+ decl'
+ | Include _ | Open _ | Const _ | TypeDef _ ->
+ decl
-let arrow_taint_prog decls =
- List.map arrow_taint_decl decls
+let arrow_taint_prog decls = List.map arrow_taint_decl decls
diff --git a/src/automata.ml b/src/automata.ml
index 506b2d7d..1e3f48c3 100644
--- a/src/automata.ml
+++ b/src/automata.ml
@@ -34,13 +34,9 @@ let as_clock var_decl =
}
let mkbool loc b = mkexpr loc (Expr_const (const_of_bool b))
-
let mkident loc id = mkexpr loc (Expr_ident id)
-
let mkconst loc id = mkexpr loc (Expr_const (Const_tag id))
-
let mkfby loc e1 e2 = mkexpr loc (Expr_arrow (e1, mkexpr loc (Expr_pre e2)))
-
let mkpair loc e1 e2 = mkexpr loc (Expr_tuple [ e1; e2 ])
let mkidentpair loc restart state =
@@ -378,7 +374,10 @@ let node_of_assign_until nused used node aut_id aut_state handler =
List.map
copy_var_decl
(aut_state.incoming_r :: aut_state.incoming_s :: new_var_outputs);
- node_locals = List.map (fun v -> copy_var_decl v, None) (new_var_locals @ handler.hand_locals);
+ node_locals =
+ List.map
+ (fun v -> copy_var_decl v, None)
+ (new_var_locals @ handler.hand_locals);
node_gencalls = [];
node_checks = [];
node_asserts = handler.hand_asserts;
@@ -520,7 +519,11 @@ let expand_node_stmts nused used loc owner node =
node.node_stmts
in
let node' =
- { node with node_locals = List.map (fun v -> v, None) locals' @ node.node_locals; node_stmts = eqs' }
+ {
+ node with
+ node_locals = List.map (fun v -> v, None) locals' @ node.node_locals;
+ node_stmts = eqs';
+ }
in
let top_node = mktop_decl loc owner false (Node node') in
top_types', top_node, top_nodes'
diff --git a/src/automata.mli b/src/automata.mli
index fa72518f..6d4a3d3d 100644
--- a/src/automata.mli
+++ b/src/automata.mli
@@ -11,7 +11,6 @@ val mkhandler :
handler_desc
val mkautomata : Location.t -> ident -> handler_desc list -> automata_desc
-
val expand_decls : program_t -> program_t
(* val expand_automata: (ident -> bool) -> (ident -> bool) -> ident -> typedef_desc -> node_desc ->
diff --git a/src/backends/Ada/ada_backend_adb.ml b/src/backends/Ada/ada_backend_adb.ml
index 2b35098b..1241e972 100644
--- a/src/backends/Ada/ada_backend_adb.ml
+++ b/src/backends/Ada/ada_backend_adb.ml
@@ -173,7 +173,7 @@ let pp_step_definition env typed_submachines fmt (m, m_spec_opt, guarantees) =
@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 (var, _) =
- mkinstr (MStateAssign (var, mk_default_value var.var_type))
+ mkinstr (MStateAssign (var, mk_default_value var.var_type))
in
let env, memory =
match m_spec_opt with None -> env, m.mmemory | Some _ -> env, m.mmemory
diff --git a/src/backends/Ada/ada_backend_ads.ml b/src/backends/Ada/ada_backend_ads.ml
index 6ecf0e1c..d4c3d820 100644
--- a/src/backends/Ada/ada_backend_ads.ml
+++ b/src/backends/Ada/ada_backend_ads.ml
@@ -20,17 +20,11 @@ open Ada_backend_common
(** Functions printing the .ads file **)
let suffixOld = "_old"
-
let suffixNew = "_new"
-
let pp_invariant_name fmt = fprintf fmt "inv"
-
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_axiomatize_package_name fmt = fprintf fmt "axiomatize"
(** Print the expression function representing the transition predicate. @param
@@ -129,7 +123,9 @@ let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
match m_spec_opt with | None -> [] | Some m_spec -> List.map
(build_pp_var_decl AdaNoMode (Some (true, false, [], []))) (m_spec.mmemory)
in *)
- let vars = List.map (fun (x, _) -> build_pp_var_decl AdaNoMode None x) m.mmemory in
+ let vars =
+ List.map (fun (x, _) -> build_pp_var_decl AdaNoMode None x) m.mmemory
+ in
let states =
List.map
(build_pp_state_decl_from_subinstance AdaNoMode None)
diff --git a/src/backends/Ada/ada_backend_common.mli b/src/backends/Ada/ada_backend_common.mli
index 2e5c322d..e124a9d8 100644
--- a/src/backends/Ada/ada_backend_common.mli
+++ b/src/backends/Ada/ada_backend_common.mli
@@ -5,42 +5,26 @@ open Ada_printer
open Misc_printer
val pp_state_name : printer
-
val pp_state_type : printer
-
val pp_reset_procedure_name : printer
-
val pp_step_procedure_name : printer
-
val pp_main_procedure_name : printer
-
val pp_polymorphic_type : int -> printer
-
val pp_past_name : int -> printer
-
val is_builtin_fun : string -> bool
-
val ada_supported_funs : (string * (string * string)) list
-
val pp_var_name : var_decl -> formatter -> unit
-
val pp_var : (string * printer) list -> formatter -> var_decl -> unit
-
val pp_value : (string * printer) list -> formatter -> value_t -> unit
-
val pp_type : formatter -> Types.t -> unit
-
val pp_var_type : formatter -> var_decl -> unit
-
val pp_package_name : machine_t -> printer
val pp_package_name_with_polymorphic :
(int * Types.t) list -> machine_t -> printer
val mk_default_value : Types.t -> value_t
-
val build_pp_var_decl : parameter_mode -> ada_with -> var_decl -> ada_var_decl
-
val build_pp_var_decl_local : ada_with -> var_decl -> ada_local_decl
val build_pp_var_decl_step_input :
@@ -50,7 +34,6 @@ val build_pp_var_decl_step_output :
parameter_mode -> ada_with -> machine_t -> ada_var_decl list list
val build_pp_arg_step : machine_t -> ada_var_decl list list
-
val build_pp_arg_reset : machine_t -> ada_var_decl list list
val build_pp_state_decl_from_subinstance :
@@ -60,7 +43,5 @@ val build_pp_state_decl_from_subinstance :
ada_var_decl
val build_pp_state_decl : parameter_mode -> ada_with -> ada_var_decl
-
val pp_machine_filename : string -> formatter -> machine_t -> unit
-
val pp_main_filename : formatter -> machine_t -> unit
diff --git a/src/backends/Ada/ada_printer.ml b/src/backends/Ada/ada_printer.ml
index c1df895c..f856dd89 100644
--- a/src/backends/Ada/ada_printer.ml
+++ b/src/backends/Ada/ada_printer.ml
@@ -12,11 +12,8 @@ type kind_def =
| AdaPackageBody
type visibility = AdaNoVisibility | AdaPrivate | AdaLimitedPrivate
-
type printer = Format.formatter -> unit
-
type ada_with = (bool * bool * printer list * printer list) option
-
type ada_var_decl = parameter_mode * printer * printer * ada_with
type ada_local_decl =
diff --git a/src/backends/Ada/ada_printer.mli b/src/backends/Ada/ada_printer.mli
index 54edca86..ec1c96e5 100644
--- a/src/backends/Ada/ada_printer.mli
+++ b/src/backends/Ada/ada_printer.mli
@@ -11,9 +11,7 @@ type kind_def =
| AdaPackageBody
type visibility = AdaNoVisibility | AdaPrivate | AdaLimitedPrivate
-
type ada_with = (bool * bool * printer list * printer list) option
-
type ada_var_decl = parameter_mode * printer * printer * ada_with
type ada_local_decl =
@@ -30,33 +28,19 @@ type def_content =
| AdaPackageInstanciation of (printer * (printer * printer) list)
val pp_integer_type : printer
-
val pp_float_type : printer
-
val pp_boolean_type : printer
-
val pp_clean_ada_identifier : formatter -> string -> unit
-
val pp_package_access : printer * printer -> printer
-
val pp_block : formatter -> printer list -> unit
-
val pp_oneline_comment : formatter -> string -> unit
-
val pp_with : visibility -> formatter -> printer -> unit
-
val pp_var_decl : ada_var_decl -> printer
-
val pp_access : printer -> printer -> formatter -> unit
-
val pp_call : formatter -> printer * printer list list -> unit
-
val pp_old : printer -> printer
-
val pp_adastring : printer -> printer
-
val pp_or : printer list -> printer
-
val pp_and : printer list -> printer
(* declaration printer *)
@@ -66,7 +50,6 @@ val pp_package_instanciation :
printer -> printer -> formatter -> (printer * printer) list -> unit
val pp_type_decl : printer -> visibility -> printer
-
val pp_record : printer -> formatter -> ada_var_decl list list -> unit
val pp_procedure :
diff --git a/src/backends/Ada/misc_lustre_function.ml b/src/backends/Ada/misc_lustre_function.ml
index b2686b21..e585fbbe 100644
--- a/src/backends/Ada/misc_lustre_function.ml
+++ b/src/backends/Ada/misc_lustre_function.ml
@@ -25,7 +25,8 @@ let get_machine machines instance =
(** Extract all the inputs and outputs. @param machine the machine @return a
list of all the var_decl of a macine **)
let get_all_vars_machine m =
- List.map fst m.mmemory @ m.mstep.step_inputs @ m.mstep.step_outputs @ m.mstatic
+ List.map fst m.mmemory @ m.mstep.step_inputs @ m.mstep.step_outputs
+ @ m.mstatic
(** Check if a type is polymorphic. @param typ the type @return true if its
polymorphic **)
diff --git a/src/backends/Ada/misc_lustre_function.mli b/src/backends/Ada/misc_lustre_function.mli
index a2a54e00..762c1c90 100644
--- a/src/backends/Ada/misc_lustre_function.mli
+++ b/src/backends/Ada/misc_lustre_function.mli
@@ -2,7 +2,6 @@ open Utils
open Machine_code_types
val is_machine_statefull : machine_t -> bool
-
val is_arrow : machine_t -> bool
val find_all_polymorphic_type : machine_t -> int list
diff --git a/src/backends/C/c_backend.ml b/src/backends/C/c_backend.ml
index 64f95f4e..5e524fee 100644
--- a/src/backends/C/c_backend.ml
+++ b/src/backends/C/c_backend.ml
@@ -41,8 +41,7 @@ let gen_files
( print_alloc_header,
print_lib_c,
print_main_c,
- print_makefile
- (* , print_cmake *) ) basename prog machines dependencies =
+ print_makefile (* , print_cmake *) ) basename prog machines dependencies =
let destname = !Options.dest_dir ^ "/" ^ basename in
(* Generating H alloc file *)
diff --git a/src/backends/C/c_backend_common.ml b/src/backends/C/c_backend_common.ml
index 4707881d..b74c6d95 100644
--- a/src/backends/C/c_backend_common.ml
+++ b/src/backends/C/c_backend_common.ml
@@ -39,7 +39,6 @@ let file_to_module_name basename =
baseNAME
let pp_ptr fmt = fprintf fmt "*%s"
-
let var_is name v = v.var_id = name
let mk_local n m =
@@ -55,19 +54,12 @@ let mk_local n m =
(* Generation of a non-clashing name for the self memory variable (for step and
reset functions) *)
let mk_self = mk_local "self"
-
let mk_mem = mk_local "mem"
-
let mk_mem_c = mk_local "mem_c"
-
let mk_mem_in = mk_local "mem_in"
-
let mk_mem_out = mk_local "mem_out"
-
let mk_mem_in_c = mk_local "mem_in_c"
-
let mk_mem_out_c = mk_local "mem_out_c"
-
let mk_mem_reset = mk_local "mem_reset"
(* Generation of a non-clashing name for the instance variable of static
@@ -75,7 +67,8 @@ let mk_mem_reset = mk_local "mem_reset"
let mk_instance m =
let used name =
let open List in
- exists (var_is name) m.mstep.step_inputs || exists (fun (x, _) -> var_is name x) m.mmemory
+ exists (var_is name) m.mstep.step_inputs
+ || exists (fun (x, _) -> var_is name x) m.mmemory
in
mk_new_name used "inst"
@@ -84,7 +77,8 @@ let mk_instance m =
let mk_attribute m =
let used name =
let open List in
- exists (var_is name) m.mstep.step_inputs || exists (fun (x, _) -> var_is name x) m.mmemory
+ exists (var_is name) m.mstep.step_inputs
+ || exists (fun (x, _) -> var_is name x) m.mmemory
in
mk_new_name used "attr"
@@ -105,12 +99,12 @@ let mk_call_var_decl loc id =
(* counter for loop variable creation *)
let loop_cpt = ref (-1)
-
let reset_loop_counter () = loop_cpt := -1
let mk_loop_var m () =
let vars =
- m.mstep.step_inputs @ m.mstep.step_outputs @ m.mstep.step_locals @ List.map fst m.mmemory
+ m.mstep.step_inputs @ m.mstep.step_outputs @ m.mstep.step_locals
+ @ List.map fst m.mmemory
in
let rec aux () =
incr loop_cpt;
@@ -127,7 +121,6 @@ let mk_loop_var m () =
addr_cpt; let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in if
List.exists (fun v -> v.var_id = s) vars then aux () else s in aux () *)
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
-
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
let pp_machine_memtype_name ?(ghost = false) fmt id =
@@ -140,9 +133,7 @@ let pp_machine_decl' ?(ghost = false) fmt =
pp_machine_decl ~ghost pp_print_string fmt
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
-
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
-
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id
let pp_machine_static_declare_name ?(ghost = false) fmt id =
@@ -155,13 +146,9 @@ let pp_machine_static_alloc_name ?(ghost = false) fmt id =
fprintf fmt "%s_ALLOC%s" id (if ghost then "_GHOST" else "")
let pp_machine_set_reset_name fmt id = fprintf fmt "%s_set_reset" id
-
let pp_machine_clear_reset_name fmt id = fprintf fmt "%s_clear_reset" id
-
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
-
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
-
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
let pp_mod pp_val v1 v2 fmt =
@@ -1255,7 +1242,8 @@ let pp_static_declare_macro ?(ghost = false) fmt ((m, attr, inst) as macro) =
List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals
in
let array_mem =
- List.filter_map (fun (v, _) -> if Types.is_array_type v.var_type then Some v else None)
+ List.filter_map
+ (fun (v, _) -> if Types.is_array_type v.var_type then Some v else None)
m.mmemory
in
fprintf
@@ -1299,7 +1287,8 @@ let pp_static_link_instance ?(ghost = false) fmt (i, (m, _)) =
it to a pointer (see pp_registers_struct) *)
let pp_static_link_macro ?(ghost = false) fmt (m, _, inst) =
let array_mem =
- List.filter_map (fun (v, _) -> if Types.is_array_type v.var_type then Some v else None)
+ List.filter_map
+ (fun (v, _) -> if Types.is_array_type v.var_type then Some v else None)
m.mmemory
in
fprintf
diff --git a/src/backends/C/c_backend_common.mli b/src/backends/C/c_backend_common.mli
index 6b677bda..a0a5c28a 100644
--- a/src/backends/C/c_backend_common.mli
+++ b/src/backends/C/c_backend_common.mli
@@ -4,47 +4,26 @@ 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 : ?ghost:bool -> 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 : ?ghost:bool -> formatter -> ident -> unit
-
val pp_machine_static_link_name : ?ghost:bool -> 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 :
@@ -61,9 +40,7 @@ val pp_c_var :
unit
val pp_c_dimension : formatter -> Dimension.t -> unit
-
val pp_c_tag : formatter -> label -> unit
-
val pp_reset_assign : ident -> formatter -> bool -> unit
val pp_assign :
@@ -91,11 +68,8 @@ val pp_basic_c_type :
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 :
@@ -107,7 +81,6 @@ 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 :
@@ -170,9 +143,7 @@ val pp_static_alloc_macro :
?ghost:bool -> formatter -> machine_t * ident * ident -> unit
val mk_call_var_decl : Location.t -> ident -> var_decl
-
val pp_c_basic_type_desc : Types.t -> string
-
val has_c_prototype : ident -> dep_t list -> bool
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t
@@ -207,19 +178,12 @@ val pp_value_suffix :
(* 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_c : machine_t -> ident
-
val mk_mem_in : machine_t -> ident
-
val mk_mem_out : machine_t -> ident
-
val mk_mem_in_c : machine_t -> ident
-
val mk_mem_out_c : machine_t -> ident
-
val mk_mem_reset : machine_t -> ident
(* Generation of a non-clashing name for the attribute variable of static
@@ -229,15 +193,10 @@ 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 mpfr_vars : var_decl list -> var_decl list
-
val mpfr_consts : const_desc list -> const_desc list
-
val reset_flag_name : string
-
val file_to_module_name : string -> string
-
val protect_filename : string -> string
(* Computes the depth to which multi-dimension array assignments should be
@@ -269,6 +228,5 @@ module Protos (Mod : MODIFIERS_GHOST_PROTO) : sig
ident -> ident -> formatter -> ident * var_decl list * var_decl list -> unit
val pp_init_prototype : ident -> formatter -> ident * var_decl list -> unit
-
val pp_clear_prototype : ident -> formatter -> ident * var_decl list -> unit
end
diff --git a/src/backends/C/c_backend_header.ml b/src/backends/C/c_backend_header.ml
index 9608bc4d..3d8400ea 100644
--- a/src/backends/C/c_backend_header.ml
+++ b/src/backends/C/c_backend_header.ml
@@ -25,11 +25,8 @@ module type MODIFIERS_HDR = sig
module GhostProto : MODIFIERS_GHOST_PROTO
val pp_machine_decl_prefix : formatter -> machine_t -> unit
-
val pp_predicates : formatter -> machine_t list -> unit
-
val pp_import_arrow : formatter -> unit -> unit
-
val pp_machine_alloc_decl : formatter -> machine_t -> unit
end
@@ -37,7 +34,6 @@ module EmptyMod = struct
module GhostProto = EmptyGhostProto
let pp_machine_decl_prefix _ _ = ()
-
let pp_predicates _ _ = ()
let pp_import_arrow fmt () =
diff --git a/src/backends/C/c_backend_header.mli b/src/backends/C/c_backend_header.mli
index abe9e9a5..4f4aa965 100644
--- a/src/backends/C/c_backend_header.mli
+++ b/src/backends/C/c_backend_header.mli
@@ -7,11 +7,8 @@ module type MODIFIERS_HDR = sig
module GhostProto : MODIFIERS_GHOST_PROTO
val pp_machine_decl_prefix : formatter -> machine_t -> unit
-
val pp_predicates : formatter -> machine_t list -> unit
-
val pp_import_arrow : formatter -> unit -> unit
-
val pp_machine_alloc_decl : formatter -> machine_t -> unit
end
diff --git a/src/backends/C/c_backend_main.ml b/src/backends/C/c_backend_main.ml
index ba36c690..876ab82f 100644
--- a/src/backends/C/c_backend_main.ml
+++ b/src/backends/C/c_backend_main.ml
@@ -19,9 +19,7 @@ module Mpfr = Lustrec_mpfr
module type MODIFIERS_MAINSRC = sig
val pp_declare_ghost_state : formatter -> ident -> unit
-
val pp_ghost_state_parameter : formatter -> unit -> unit
-
val pp_main_spec : formatter -> unit
val pp_main_loop_invariants :
@@ -30,11 +28,8 @@ end
module EmptyMod = struct
let pp_declare_ghost_state _ _ = ()
-
let pp_ghost_state_parameter _ _ = ()
-
let pp_main_spec _ = ()
-
let pp_main_loop_invariants _ _ _ _ = ()
end
diff --git a/src/backends/C/c_backend_main.mli b/src/backends/C/c_backend_main.mli
index 32cd587c..e8135e8d 100644
--- a/src/backends/C/c_backend_main.mli
+++ b/src/backends/C/c_backend_main.mli
@@ -5,9 +5,7 @@ open Machine_code_types
module type MODIFIERS_MAINSRC = sig
val pp_declare_ghost_state : formatter -> ident -> unit
-
val pp_ghost_state_parameter : formatter -> unit -> unit
-
val pp_main_spec : formatter -> unit
val pp_main_loop_invariants :
diff --git a/src/backends/C/c_backend_makefile.ml b/src/backends/C/c_backend_makefile.ml
index ee088fa7..38f7c80a 100644
--- a/src/backends/C/c_backend_makefile.ml
+++ b/src/backends/C/c_backend_makefile.ml
@@ -60,37 +60,33 @@ let pp_print_dependencies arrow_suffix fmt deps =
"${INC}/io_frontend.c"
:: sprintf "${INC}/arrow%s.c" arrow_suffix
:: (* IO functions when a main function is computed *)
- List.map
- (fun dep ->
- (if dep.local then dep.name
- else Version.include_path ^ "/" ^ dep.name)
- ^ ".c")
- compiled_deps
+ List.map
+ (fun dep ->
+ (if dep.local then dep.name
+ else Version.include_path ^ "/" ^ dep.name)
+ ^ ".c")
+ compiled_deps
in
pp_print_list
~pp_open_box:pp_open_vbox0
~pp_sep:pp_print_cut
~pp_epilogue:pp_print_cut
(fun fmt s ->
- Log.report ~level:1 (fun fmt -> fprintf fmt "Adding dependency: %s@." s);
- fprintf fmt "\t@[<h>${GCC} -I${INC} -c %s@]" s)
+ Log.report ~level:1 (fun fmt -> fprintf fmt "Adding dependency: %s@." s);
+ fprintf fmt "\t@[<h>${GCC} -I${INC} -c %s@]" s)
fmt
deps
module type MODIFIERS_MKF = sig
(* dep was (bool * ident * top_decl list) *)
val other_targets : string -> string -> dep_t list -> formatter -> unit
-
val pp_print_dependencies : formatter -> dep_t list -> unit
-
val pp_arrow_o : formatter -> unit -> unit
end
module EmptyMod : MODIFIERS_MKF = struct
let other_targets _ _ _ _ = ()
-
let pp_print_dependencies = pp_print_dependencies ""
-
let pp_arrow_o fmt () = pp_print_string fmt "arrow.o"
end
@@ -120,9 +116,9 @@ functor
else nodename ^ "run"
else s
in
- fprintf fmt
- "@[<v 0>\
- BINNAME?=%s@;\
+ fprintf
+ fmt
+ "@[<v 0>BINNAME?=%s@;\
GCC=gcc -O0@;\
LUSTREC=%s@;\
LUSTREC_BASE=%s@;\
@@ -131,34 +127,35 @@ functor
%s_%s: %s.c %s_main.c@;\
\t@[<h>${GCC} -I${INC} -I. -c %s.c@]@;\
\t@[<h>${GCC} -I${INC} -I. -c %s_main.c@]@;\
- %a\
- \t@[<h>${GCC} -o ${BINNAME} io_frontend.o %a %a %s.o %s_main.o %a@]@;\
+ %a\t@[<h>${GCC} -o ${BINNAME} io_frontend.o %a %a %s.o %s_main.o %a@]@;\
@;\
clean:@;\
\t@[<h>\\rm -f *.o ${BINNAME}@]@;\
@;\
- %t\
- @]@."
- binname
- Sys.executable_name
- (Filename.dirname (Filename.dirname Sys.executable_name))
- Version.include_path
-
- (* Main binary *)
- basename "run" basename basename
- basename
- basename
- Mod.pp_print_dependencies dependencies
- Mod.pp_arrow_o ()
- (pp_print_list ~pp_open_box:pp_open_hbox
- (fun fmt dep -> fprintf fmt "%s.o" dep.name))
- (compiled_dependencies dependencies)
- basename
- basename
- (pp_print_list ~pp_open_box:pp_open_hbox
- (fun fmt -> fprintf fmt "-l%s"))
- (lib_dependencies dependencies)
- (Mod.other_targets basename nodename dependencies)
+ %t@]@."
+ binname
+ Sys.executable_name
+ (Filename.dirname (Filename.dirname Sys.executable_name))
+ Version.include_path
+ (* Main binary *)
+ basename
+ "run"
+ basename
+ basename
+ basename
+ basename
+ Mod.pp_print_dependencies
+ dependencies
+ Mod.pp_arrow_o
+ ()
+ (pp_print_list ~pp_open_box:pp_open_hbox (fun fmt dep ->
+ fprintf fmt "%s.o" dep.name))
+ (compiled_dependencies dependencies)
+ basename
+ basename
+ (pp_print_list ~pp_open_box:pp_open_hbox (fun fmt -> fprintf fmt "-l%s"))
+ (lib_dependencies dependencies)
+ (Mod.other_targets basename nodename dependencies)
end
(* Local Variables: *)
diff --git a/src/backends/C/c_backend_makefile.mli b/src/backends/C/c_backend_makefile.mli
index 1d63a72f..65add707 100644
--- a/src/backends/C/c_backend_makefile.mli
+++ b/src/backends/C/c_backend_makefile.mli
@@ -4,9 +4,7 @@ open Lustre_types
module type MODIFIERS_MKF = sig
val other_targets : string -> string -> dep_t list -> formatter -> unit
-
val pp_print_dependencies : formatter -> dep_t list -> unit
-
val pp_arrow_o : formatter -> unit -> unit
end
@@ -17,7 +15,5 @@ module Main (Mod : MODIFIERS_MKF) : sig
end
val pp_print_dependencies : string -> 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 6762862b..0a21b869 100644
--- a/src/backends/C/c_backend_mauve.ml
+++ b/src/backends/C/c_backend_mauve.ml
@@ -14,9 +14,7 @@ open Printers
(********************************************************************************************)
let shell_name node = node ^ "Shell"
-
let core_name node = node ^ "Core"
-
let fsm_name node = node ^ "FSM"
(* -------------------------------------------------- *)
diff --git a/src/backends/C/c_backend_mauve.mli b/src/backends/C/c_backend_mauve.mli
index fc04dfc8..feb64dad 100644
--- a/src/backends/C/c_backend_mauve.mli
+++ b/src/backends/C/c_backend_mauve.mli
@@ -2,9 +2,6 @@ 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
diff --git a/src/backends/C/c_backend_spec.ml b/src/backends/C/c_backend_spec.ml
index 024068f4..0dd2bfab 100644
--- a/src/backends/C/c_backend_spec.ml
+++ b/src/backends/C/c_backend_spec.ml
@@ -36,9 +36,7 @@ let pp_acsl_basic_type_desc t_desc =
(* Not a basic C type. Do not handle arrays or pointers *)
let pp_acsl pp fmt = fprintf fmt "@[<v>/*%@ @[<v>%a@]@,*/@]" pp
-
let pp_acsl_cut pp fmt = fprintf fmt "%a@," (pp_acsl pp)
-
let pp_acsl_line pp fmt = fprintf fmt "//%@ @[<h>%a@]" pp
let pp_acsl_line' ?(ghost = false) pp fmt x =
@@ -47,11 +45,8 @@ let pp_acsl_line' ?(ghost = false) pp fmt x =
fprintf fmt "/%s%@ @[<h>%a@] %s/" op pp x cl
let pp_acsl_line'_cut pp fmt = fprintf fmt "%a@," (pp_acsl_line' pp)
-
let pp_requires pp fmt = fprintf fmt "requires %a;" pp
-
let pp_ensures pp fmt = fprintf fmt "ensures %a;" pp
-
let pp_terminates pp fmt = fprintf fmt "terminates %a;" pp
let pp_assigns pp =
@@ -61,18 +56,14 @@ let pp_assigns pp =
pp
let pp_ghost pp fmt = fprintf fmt "ghost %a" pp
-
let pp_assert pp fmt = fprintf fmt "assert %a;" pp
-
let pp_loop_invariant pp fmt = fprintf fmt "loop invariant %a;" pp
let pp_mem_valid pp_var fmt (name, var) =
fprintf fmt "%s_valid(%a)" name pp_var var
let pp_mem_valid' = pp_mem_valid pp_print_string
-
let pp_ref pp fmt = fprintf fmt "&%a" pp
-
let pp_ref' = pp_ref pp_print_string
let pp_indirect pp_ptr pp_field fmt (ptr, field) =
@@ -84,33 +75,19 @@ let pp_access pp_stru pp_field fmt (stru, field) =
fprintf fmt "%a.%a" pp_stru stru pp_field field
let pp_access' = pp_access pp_print_string pp_print_string
-
let pp_var_decl fmt v = pp_print_string fmt v.var_id
-
let pp_true fmt () = pp_print_string fmt "\\true"
-
let pp_cast pp_ty pp fmt (ty, x) = fprintf fmt "(%a) %a" pp_ty ty pp x
-
let pp_bool_cast pp fmt x = pp_cast pp_print_string pp fmt ("_Bool", x)
-
let pp_double_cast pp fmt x = pp_cast pp_print_string pp fmt ("double", x)
-
let pp_int_cast pp fmt x = pp_cast pp_print_string pp fmt ("int", x)
-
let pp_true_c_bool fmt () = pp_bool_cast pp_print_string fmt "1"
-
let pp_false fmt () = pp_print_string fmt "\\false"
-
let pp_nothing fmt () = pp_print_string fmt "\\nothing"
-
let pp_null fmt () = pp_print_string fmt "\\null"
-
let pp_stdout fmt () = pp_print_string fmt "stdout"
-
let pp_at pp_v fmt (v, l) = fprintf fmt "\\at(%a, %s)" pp_v v l
-
let pp_at_pre pp_v fmt v = pp_at pp_v fmt (v, "Pre")
-
let find_machine f = List.find (fun m -> m.mname.node_id = f)
let instances machines m =
@@ -184,7 +161,6 @@ let pp_exists pp_l pp_r fmt (l, r) =
fprintf fmt "@[<v 2>\\exists %a;@,%a@]" pp_l l pp_r r
let pp_equal pp_l pp_r fmt (l, r) = fprintf fmt "%a == %a" pp_l l pp_r r
-
let pp_gequal pp_l pp_r fmt (l, r) = fprintf fmt "%a >= %a" pp_l l pp_r r
let pp_implies pp_l pp_r fmt (l, r) =
@@ -210,11 +186,8 @@ let pp_or_l pp_v fmt =
fmt
let pp_not pp fmt = fprintf fmt "!%a" pp
-
let pp_valid pp = pp_and_l (fun fmt x -> fprintf fmt "\\valid(%a)" pp x)
-
let pp_valid_read pp fmt = fprintf fmt "\\valid_read(%a)" pp
-
let pp_old pp fmt = fprintf fmt "\\old(%a)" pp
let pp_ite pp_c pp_t pp_f fmt (c, t, f) =
@@ -226,7 +199,6 @@ let pp_initialization pp_mem fmt (name, mem) =
fprintf fmt "%s_initialization(%a)" name pp_mem mem
let pp_init pp_mem fmt (name, mem) = fprintf fmt "%s_init(%a)" name pp_mem mem
-
let pp_initialization' = pp_initialization pp_print_string
let pp_local m =
@@ -237,7 +209,8 @@ let pp_locals m =
let pp_ptr_decl fmt v = pp_ptr fmt v.var_id
-let pp_basic_assign_spec ?(pp_op = pp_equal) pp_l pp_r fmt (typ, var_name, value) =
+let pp_basic_assign_spec ?(pp_op = pp_equal) pp_l pp_r fmt (typ, var_name, value)
+ =
if Types.is_real_type typ && !Options.mpfr then assert false
(* Mpfr.pp_inject_assign pp_var fmt (var_name, value) *)
else pp_op pp_l pp_r fmt (var_name, value)
@@ -287,16 +260,10 @@ let pp_assign_spec ?pp_op m self_l pp_var_l indirect_l self_r pp_var_r
aux var_type fmt reordered_loop_vars
let pp_memory_pack_base_aux pp_mem pp_self fmt (name, mem, self) =
- fprintf
- fmt
- "%s_pack_base(@[<hov>%a,@ %a@])"
- name
- pp_mem
- mem
- pp_self
- self
+ fprintf fmt "%s_pack_base(@[<hov>%a,@ %a@])" name pp_mem mem pp_self self
-let pp_memory_pack_aux_taint ?i pp_mem_reset pp_mem pp_self fmt (name, mem_reset, mem, self) =
+let pp_memory_pack_aux_taint ?i pp_mem_reset pp_mem pp_self fmt
+ (name, mem_reset, mem, self) =
fprintf
fmt
"%s_pack%a(@[<hov>%a,@ %a,@ %a@])"
@@ -311,16 +278,10 @@ let pp_memory_pack_aux_taint ?i pp_mem_reset pp_mem pp_self fmt (name, mem_reset
self
let pp_memory_pack_aux pp_mem pp_self fmt (name, mem, self) =
- fprintf
- fmt
- "%s_pack(@[<hov>%a,@ %a@])"
- name
- pp_mem
- mem
- pp_self
- self
+ fprintf fmt "%s_pack(@[<hov>%a,@ %a@])" name pp_mem mem pp_self self
-let pp_memory_pack_taint pp_mem_reset pp_mem pp_self fmt (mp, mem_reset, mem, self) =
+let pp_memory_pack_taint pp_mem_reset pp_mem pp_self fmt
+ (mp, mem_reset, mem, self) =
pp_memory_pack_aux_taint
?i:mp.mpindex
pp_mem_reset
@@ -330,11 +291,7 @@ let pp_memory_pack_taint pp_mem_reset pp_mem pp_self fmt (mp, mem_reset, mem, se
(mp.mpname.node_id, mem_reset, mem, self)
let pp_memory_pack pp_mem pp_self fmt (mp, mem, self) =
- pp_memory_pack_aux
- pp_mem
- pp_self
- fmt
- (mp.mpname.node_id, mem, self)
+ pp_memory_pack_aux pp_mem pp_self fmt (mp.mpname.node_id, mem, self)
let pp_transition_aux ?i stateless pp_mem_in pp_mem_out pp_var fmt
(name, vars, mem_in, mem_out) =
@@ -420,10 +377,10 @@ module PrintSpec = struct
| Val v ->
let pp = pp_c_val ~indirect:false m mem (pp_c_var_read ~test_output m) in
(if not_var v then
- if Types.is_bool_type v.value_type then pp_bool_cast pp
- else if Types.is_real_type v.value_type then pp_double_cast pp
- else if is_const v && Types.is_int_type v.value_type then pp_int_cast pp
- else pp
+ if Types.is_bool_type v.value_type then pp_bool_cast pp
+ else if Types.is_real_type v.value_type then pp_double_cast pp
+ else if is_const v && Types.is_int_type v.value_type then pp_int_cast pp
+ else pp
else pp)
fmt
v
@@ -475,19 +432,27 @@ module PrintSpec = struct
fmt
(r, (mem_out, 1), (mem_out, (mem_in, inst)))
| MemoryPackBase f ->
- pp_memory_pack_base_aux pp_print_string pp_print_string fmt (f, mem_out, mem_in)
- | MemoryPack (f, inst, i) ->
- begin match inst with
- | Some inst ->
- let pp_mem, pp_self =
- ( (fun fmt mem -> pp_access' fmt (mem, inst)),
- fun fmt self -> pp_indirect' fmt (self, inst) )
- in
- pp_memory_pack_aux pp_mem pp_self fmt (f, mem_out, mem_in)
- | None ->
- pp_memory_pack_aux_taint ?i pp_print_string pp_print_string pp_print_string
- fmt (f, mem_in', mem_out, mem_in)
- end
+ pp_memory_pack_base_aux
+ pp_print_string
+ pp_print_string
+ fmt
+ (f, mem_out, mem_in)
+ | MemoryPack (f, inst, i) -> (
+ match inst with
+ | Some inst ->
+ let pp_mem, pp_self =
+ ( (fun fmt mem -> pp_access' fmt (mem, inst)),
+ fun fmt self -> pp_indirect' fmt (self, inst) )
+ in
+ pp_memory_pack_aux pp_mem pp_self fmt (f, mem_out, mem_in)
+ | None ->
+ pp_memory_pack_aux_taint
+ ?i
+ pp_print_string
+ pp_print_string
+ pp_print_string
+ fmt
+ (f, mem_in', mem_out, mem_in))
| ResetCleared f ->
pp_reset_cleared' fmt (f, mem_in, mem_out)
(* fprintf fmt "ResetCleared_%a" pp_print_string f *)
@@ -515,36 +480,32 @@ module PrintSpec = struct
let rec find_arrow_val loc m v =
let find = find_arrow_val loc m in
match v.value_desc with
- | Var v ->
- begin match find_tainter_arrow m v with
- | Some (Some a) ->
- Some a
- | Some None ->
- if not (Hashtbl.mem bad_inits v) then begin
- Hashtbl.add bad_inits v ();
- Error.pp_warning loc (fun fmt ->
- fprintf fmt
- "Generating stateful spec for uninitialized state variable %s."
- v.var_id);
- end;
- None
- | None -> None
- end
+ | Var v -> (
+ match find_tainter_arrow m v with
+ | Some (Some a) ->
+ Some a
+ | Some None ->
+ if not (Hashtbl.mem bad_inits v) then (
+ Hashtbl.add bad_inits v ();
+ Error.pp_warning loc (fun fmt ->
+ fprintf
+ fmt
+ "Generating stateful spec for uninitialized state variable \
+ %s."
+ v.var_id));
+ None
+ | None ->
+ None)
| Array vl | Fun (_, vl) ->
List.find_map find vl
- | Access (t, i) | Power (t, i) ->
- begin match find t with
- | None -> find i
- | a -> a
- end
+ | Access (t, i) | Power (t, i) -> (
+ match find t with None -> find i | a -> a)
| _ ->
None
in
find_arrow_val
- let find_arrow loc m = function
- | Val v -> find_arrow_val loc m v
- | _ -> None
+ let find_arrow loc m = function Val v -> find_arrow_val loc m v | _ -> None
let pp_spec mode m fmt f =
let rec pp_spec mode fmt f =
@@ -593,10 +554,10 @@ module PrintSpec = struct
pp_print_option
~none:pp_eq
(fun fmt inst ->
- pp_paren
- (pp_implies (pp_not (pp_initialization pp_access')) pp_eq)
- fmt
- ((Arrow.arrow_id, (mem_in, inst)), ()))
+ pp_paren
+ (pp_implies (pp_not (pp_initialization pp_access')) pp_eq)
+ fmt
+ ((Arrow.arrow_id, (mem_in, inst)), ()))
fmt
inst
| GEqual (a, b) ->
@@ -617,10 +578,10 @@ module PrintSpec = struct
pp_or_l pp_spec' fmt fs
| Imply (a, b) ->
pp_paren (pp_implies pp_spec' pp_spec') fmt (a, b)
- | Exists ([x], a) ->
+ | Exists ([ x ], a) ->
pp_exists (pp_local m) pp_spec' fmt (x, a)
| Exists (xs, a) ->
- pp_spec' fmt (List.fold_left (fun spec x -> Exists ([x], spec)) a xs)
+ pp_spec' fmt (List.fold_left (fun spec x -> Exists ([ x ], spec)) a xs)
| Forall (xs, a) ->
pp_forall (pp_locals m) pp_spec' fmt (xs, a)
| Ternary (e, a, b) ->
@@ -629,10 +590,10 @@ module PrintSpec = struct
pp_print_option
~none:pp_ite
(fun fmt inst ->
- pp_paren
- (pp_implies (pp_not (pp_initialization pp_access')) pp_ite)
- fmt
- ((Arrow.arrow_id, (mem_in, inst)), ()))
+ pp_paren
+ (pp_implies (pp_not (pp_initialization pp_access')) pp_ite)
+ fmt
+ ((Arrow.arrow_id, (mem_in, inst)), ()))
fmt
inst
| Predicate p ->
@@ -671,7 +632,9 @@ module PrintSpec = struct
pp_paren
(pp_implies (pp_not (pp_initialization pp_access')) pp_eq)
fmt
- ((Arrow.arrow_id, ((if tainted then mem_reset else mem_out), inst)), ()))
+ ( ( Arrow.arrow_id,
+ ((if tainted then mem_reset else mem_out), inst) ),
+ () ))
fmt
inst
| ExistsMem (f, rc, tr) ->
@@ -813,7 +776,9 @@ let pp_transition_footprint_lemma m fmt t =
let stateless = fst (get_stateless_status m) in
let mems =
ISet.(
- diff (of_list (List.map (fun (v, _) -> v.var_id) m.mmemory)) t.tmem_footprint)
+ diff
+ (of_list (List.map (fun (v, _) -> v.var_id) m.mmemory))
+ t.tmem_footprint)
in
let insts =
IMap.(
@@ -824,7 +789,8 @@ let pp_transition_footprint_lemma m fmt t =
let memories =
List.map
(fun v -> { v with var_type = { v.var_type with tid = -1 } })
- (List.filter_map (fun (v, _) -> if ISet.mem v.var_id mems then Some v else None)
+ (List.filter_map
+ (fun (v, _) -> if ISet.mem v.var_id mems then Some v else None)
m.mmemory)
in
let mems_empty = ISet.is_empty mems in
@@ -1030,17 +996,7 @@ module SrcMod = struct
(fun fmt () ->
fprintf
fmt
- "%a@,\
- %a@,\
- %a@,\
- %a@,\
- %a@,\
- %a@,\
- %a@,\
- %a@,\
- %a@,\
- %a@,\
- %a"
+ "%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a"
(pp_requires pp_mem_valid')
(name, self)
(pp_requires (pp_separated' self mem))
@@ -1054,8 +1010,7 @@ module SrcMod = struct
pp_ptr
pp_print_string))
(name, mem, mem, self)
- (pp_ensures
- (pp_reset_cleared (pp_old pp_ptr) pp_ptr))
+ (pp_ensures (pp_reset_cleared (pp_old pp_ptr) pp_ptr))
(name, mem, mem)
(pp_assigns pp_reset_flag')
[ self ]
@@ -1119,7 +1074,6 @@ module SrcMod = struct
((name, (name, mem)), ((name, mem), mem))
let rename n x = sprintf "%s_%d" x n
-
let rename_var_decl n vd = { vd with var_id = rename n vd.var_id }
let rec rename_value n v =
@@ -1207,7 +1161,6 @@ module SrcMod = struct
mem_out
let pp_k_induction_base_case m = pp_k_induction_case "base" m
-
let pp_k_induction_inductive_case m = pp_k_induction_case "inductive" m
let pp_base_cases m fmt (c, m_c, k) =
@@ -1581,30 +1534,36 @@ module SrcMod = struct
pp_ensures
(pp_forall
(fun fmt vs ->
- fprintf fmt "%a%a"
- (if stateless_c then pp_print_nothing
- else
- pp_machine_decl
- ~ghost:true
- (pp_comma_list ~pp_eol:pp_print_comma pp_print_string))
- (m_c.mname.node_id, [ mem_in; mem_out ])
- (pp_locals m) vs)
- (pp_implies
- (pp_transition_aux
- stateless_c
- pp_print_string
- pp_print_string
- (fun fmt v ->
+ fprintf
+ fmt
+ "%a%a"
+ (if stateless_c then pp_print_nothing
+ else
+ pp_machine_decl
+ ~ghost:true
+ (pp_comma_list
+ ~pp_eol:pp_print_comma
+ pp_print_string))
+ (m_c.mname.node_id, [ mem_in; mem_out ])
+ (pp_locals m)
+ vs)
+ (pp_implies
+ (pp_transition_aux
+ stateless_c
+ pp_print_string
+ pp_print_string
+ (fun fmt v ->
(if is_output m v then pp_ptr_decl else pp_var_decl)
fmt
v))
- (pp_contract m)))
- fmt
- (m_c.mstep.step_outputs, ( ( m_c.mname.node_id,
- m_c.mstep.step_inputs @ m_c.mstep.step_outputs,
- mem_in,
- mem_out ),
- c )))
+ (pp_contract m)))
+ fmt
+ ( m_c.mstep.step_outputs,
+ ( ( m_c.mname.node_id,
+ m_c.mstep.step_inputs @ m_c.mstep.step_outputs,
+ mem_in,
+ mem_out ),
+ c ) ))
fmt
m_c)
in
@@ -1629,7 +1588,7 @@ module SrcMod = struct
(* else *)
(* pp_machine_decl *)
(* ~ghost:true *)
- (* (pp_comma_list ~pp_eol:pp_print_semicolon pp_print_string)) *)
+ (* (pp_comma_list ~pp_eol:pp_print_semicolon pp_print_string)) *)
(* (m_c.mname.node_id, [ mem_in; mem_out ]))) *)
(* | _ -> *)
(* pp_print_nothing *)
@@ -1726,11 +1685,9 @@ module SrcMod = struct
(pp_print_list
~pp_open_box:pp_open_vbox0
~pp_prologue:pp_print_cut
- (pp_acsl_line'
- ~ghost
- (fun fmt (spec, asrt) ->
- let pp = PrintSpec.pp_spec (InstrMode self) m in
- (if asrt then pp_assert pp else pp) fmt spec)))
+ (pp_acsl_line' ~ghost (fun fmt (spec, asrt) ->
+ let pp = PrintSpec.pp_spec (InstrMode self) m in
+ (if asrt then pp_assert pp else pp) fmt spec)))
instr.instr_spec
let pp_ghost_parameter mem fmt inst =
@@ -1772,22 +1729,28 @@ module SrcMod = struct
let pp_c_decl_local_spec_var m fmt v =
pp_acsl_line'
- (fun fmt v ->
- fprintf fmt "%a;"
- (pp_ghost (pp_c_decl_local_var m))
- v)
- fmt v
+ (fun fmt v -> fprintf fmt "%a;" (pp_ghost (pp_c_decl_local_var m)) v)
+ fmt
+ v
let get_spec_locals m =
let rec gather vs instr =
- let vs = List.fold_left (fun vs (spec, _) -> match Spec_common.red spec with
- | Predicate (GhostAssign (v, _)) -> VSet.add v vs
- | _ -> vs) vs instr.instr_spec
+ let vs =
+ List.fold_left
+ (fun vs (spec, _) ->
+ match Spec_common.red spec with
+ | Predicate (GhostAssign (v, _)) ->
+ VSet.add v vs
+ | _ ->
+ vs)
+ vs
+ instr.instr_spec
in
match instr.instr_desc with
| MBranch (_, hl) ->
List.fold_left (fun vs (_, il) -> List.fold_left gather vs il) vs hl
- | _ -> vs
+ | _ ->
+ vs
in
List.fold_left gather VSet.empty m.mstep.step_instrs |> VSet.elements
@@ -1795,15 +1758,16 @@ module SrcMod = struct
let name = m.mname.node_id in
let mem_r = mk_mem_reset m in
pp_acsl_line'
- (pp_ghost
- (fun fmt () ->
- fprintf fmt "%a = %a;"
- (pp_machine_decl' ~ghost:true)
- (name, mem_r)
- pp_ptr mem))
+ (pp_ghost (fun fmt () ->
+ fprintf
+ fmt
+ "%a = %a;"
+ (pp_machine_decl' ~ghost:true)
+ (name, mem_r)
+ pp_ptr
+ mem))
fmt
()
-
end
module MainMod = struct
@@ -1877,7 +1841,6 @@ end
module MakefileMod = struct
let pp_print_dependencies = C_backend_makefile.pp_print_dependencies "_spec"
-
let pp_arrow_o fmt () = pp_print_string fmt "arrow_spec.o"
let other_targets basename _nodename dependencies fmt =
@@ -1943,11 +1906,8 @@ end
(* TODO: complete this list *)
let acsl_keywords = ISet.of_list [ "set" ]
-
let sanitize x = if ISet.mem x acsl_keywords then "__" ^ x else x
-
let sanitize_var_decl vd = { vd with var_id = sanitize vd.var_id }
-
let sanitize_var_decls = List.map sanitize_var_decl
let rec sanitize_value v =
@@ -2009,9 +1969,11 @@ let rec sanitize_formula = function
Value (sanitize_value v)
| f ->
f
+
and sanitize_formulae fs = List.map (fun spec -> sanitize_formula spec) fs
-let sanitize_spec fs = List.map (fun (spec, asrt) -> sanitize_formula spec, asrt) fs
+let sanitize_spec fs =
+ List.map (fun (spec, asrt) -> sanitize_formula spec, asrt) fs
let rec sanitize_instr i =
let sanitize_instr_desc = function
diff --git a/src/backends/C/c_backend_spec.mli b/src/backends/C/c_backend_spec.mli
index b9a51786..5529317b 100644
--- a/src/backends/C/c_backend_spec.mli
+++ b/src/backends/C/c_backend_spec.mli
@@ -1,9 +1,6 @@
module HdrMod : C_backend_header.MODIFIERS_HDR
-
module SrcMod : C_backend_src.MODIFIERS_SRC
-
module MakefileMod : C_backend_makefile.MODIFIERS_MKF
-
module MainMod : C_backend_main.MODIFIERS_MAINSRC
val sanitize_machines :
diff --git a/src/backends/C/c_backend_src.ml b/src/backends/C/c_backend_src.ml
index 2f94de5a..15f7da4c 100644
--- a/src/backends/C/c_backend_src.ml
+++ b/src/backends/C/c_backend_src.ml
@@ -22,9 +22,7 @@ module type MODIFIERS_SRC = sig
module GhostProto : MODIFIERS_GHOST_PROTO
val pp_predicates : formatter -> machine_t list -> unit
-
val pp_set_reset_spec : formatter -> ident -> ident -> machine_t -> unit
-
val pp_clear_reset_spec : formatter -> ident -> ident -> machine_t -> unit
val pp_step_spec :
@@ -38,34 +36,23 @@ module type MODIFIERS_SRC = sig
val pp_contract :
formatter -> machine_t list -> ident -> ident -> machine_t -> unit
- val pp_c_decl_local_spec_var: machine_t -> formatter -> var_decl -> unit
-
- val get_spec_locals: machine_t -> var_decl list
-
- val pp_ghost_reset_memory: machine_t -> formatter -> ident -> unit
+ val pp_c_decl_local_spec_var : machine_t -> formatter -> var_decl -> unit
+ val get_spec_locals : machine_t -> var_decl list
+ val pp_ghost_reset_memory : machine_t -> formatter -> ident -> unit
end
module EmptyMod = struct
module GhostProto = EmptyGhostProto
let pp_predicates _ _ = ()
-
let pp_set_reset_spec _ _ _ _ = ()
-
let pp_clear_reset_spec _ _ _ _ = ()
-
let pp_step_spec _ _ _ _ _ = ()
-
let pp_step_instr_spec _ _ _ _ _ = ()
-
let pp_ghost_parameter _ _ _ = ()
-
let pp_contract _ _ _ _ _ = ()
-
let pp_c_decl_local_spec_var _ _ _ = ()
-
let get_spec_locals _ = []
-
let pp_ghost_reset_memory _ _ _ = ()
end
@@ -489,7 +476,8 @@ module Main (Mod : MODIFIERS_SRC) = struct
fprintf fmt "free (_alloc->_reg.%s);" vdecl.var_id
let array_mems m =
- List.filter_map (fun (v, _) -> if Types.is_array_type v.var_type then Some v else None)
+ List.filter_map
+ (fun (v, _) -> if Types.is_array_type v.var_type then Some v else None)
m.mmemory
let pp_alloc_code fmt m =
@@ -559,14 +547,11 @@ module Main (Mod : MODIFIERS_SRC) = struct
check
let pp_print_function ~pp_prototype ~prototype ?(is_contract = false)
- ?(pp_spec = pp_print_nothing)
- ?(pp_local = pp_print_nothing)
- ?(base_locals = [])
- ?(pp_array_mem = pp_print_nothing) ?(array_mems = [])
+ ?(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_spec_local = pp_print_nothing)
- ?(spec_locals = [])
+ ?(pp_spec_local = pp_print_nothing) ?(spec_locals = [])
?(pp_check = pp_print_nothing) ?(checks = [])
?(pp_extra = pp_print_nothing)
?(pp_instr = fun fmt _ -> pp_print_nothing fmt ()) ?(instrs = []) fmt =
diff --git a/src/backends/C/c_backend_src.mli b/src/backends/C/c_backend_src.mli
index 30e674dc..47a56650 100644
--- a/src/backends/C/c_backend_src.mli
+++ b/src/backends/C/c_backend_src.mli
@@ -8,9 +8,7 @@ module type MODIFIERS_SRC = sig
module GhostProto : MODIFIERS_GHOST_PROTO
val pp_predicates : formatter -> machine_t list -> unit
-
val pp_set_reset_spec : formatter -> ident -> ident -> machine_t -> unit
-
val pp_clear_reset_spec : formatter -> ident -> ident -> machine_t -> unit
val pp_step_spec :
@@ -24,11 +22,9 @@ module type MODIFIERS_SRC = sig
val pp_contract :
formatter -> machine_t list -> ident -> ident -> machine_t -> unit
- val pp_c_decl_local_spec_var: machine_t -> formatter -> var_decl -> unit
-
- val get_spec_locals: machine_t -> var_decl list
-
- val pp_ghost_reset_memory: machine_t -> formatter -> ident -> unit
+ val pp_c_decl_local_spec_var : machine_t -> formatter -> var_decl -> unit
+ val get_spec_locals : machine_t -> var_decl list
+ val pp_ghost_reset_memory : machine_t -> formatter -> ident -> unit
end
module EmptyMod : MODIFIERS_SRC
diff --git a/src/backends/EMF/EMF_common.ml b/src/backends/EMF/EMF_common.ml
index f03f5bb2..2c5c8c61 100644
--- a/src/backends/EMF/EMF_common.ml
+++ b/src/backends/EMF/EMF_common.ml
@@ -269,7 +269,6 @@ let pp_emf_var_decl fmt v =
v
let pp_emf_vars_decl = pp_emf_list pp_emf_var_decl
-
let reset_name id = "reset_" ^ id
let pp_tag_id fmt t =
diff --git a/src/backends/EMF/EMF_common.mli b/src/backends/EMF/EMF_common.mli
index e8ecbb75..78c61434 100644
--- a/src/backends/EMF/EMF_common.mli
+++ b/src/backends/EMF/EMF_common.mli
@@ -4,23 +4,14 @@ 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 pp_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 :
@@ -31,11 +22,7 @@ val pp_emf_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/Horn/horn_backend.mli b/src/backends/Horn/horn_backend.mli
index a89ee90e..32c74296 100644
--- a/src/backends/Horn/horn_backend.mli
+++ b/src/backends/Horn/horn_backend.mli
@@ -4,6 +4,5 @@ val translate :
Machine_code_types.machine_t list ->
unit
-val preprocess: Machine_code_types.machine_t list ->
- Machine_code_types.machine_t list
-
+val preprocess :
+ Machine_code_types.machine_t list -> Machine_code_types.machine_t list
diff --git a/src/backends/Horn/horn_backend_common.ml b/src/backends/Horn/horn_backend_common.ml
index af9f787f..1b42ce16 100644
--- a/src/backends/Horn/horn_backend_common.ml
+++ b/src/backends/Horn/horn_backend_common.ml
@@ -16,17 +16,11 @@ open Machine_code_types
open Corelang
let get_machine = Machine_code_common.get_machine
-
let machine_reset_name id = id ^ "_reset"
-
let machine_step_name id = id ^ "_step"
-
let machine_stateless_name id = id ^ "_fun"
-
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
-
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
-
let pp_machine_stateless_name fmt id = fprintf fmt "%s_fun" id
let rec pp_type fmt t =
@@ -67,7 +61,6 @@ let pp_conj pp fmt l =
(* Workaround to prevent the use of declared keywords as node name *)
(********************************************************************************************)
let registered_keywords = [ "implies" ]
-
let protect_kwd s = if List.mem s registered_keywords then "__" ^ s else s
let node_name n =
@@ -75,23 +68,14 @@ let node_name n =
protect_kwd name
let concat prefix x = if prefix = "" then x else prefix ^ "." ^ x
-
let rename f v = { v with var_id = f v.var_id }
-
let rename_machine p = rename (fun n -> concat p n)
-
let rename_machine_list p = List.map (rename_machine p)
-
let rename_current = rename (fun n -> n ^ "_c")
-
let rename_current_list = List.map rename_current
-
let rename_mid = rename (fun n -> n ^ "_m")
-
let rename_mid_list = List.map rename_mid
-
let rename_next = rename (fun n -> n ^ "_x")
-
let rename_next_list = List.map rename_next
let local_memory_vars machine =
@@ -100,7 +84,9 @@ let local_memory_vars machine =
let instances_memory_vars ?(without_arrow = false) machines machine =
let rec aux first prefix m =
(if not first then
- rename_machine_list (concat prefix m.mname.node_id) (List.map fst m.mmemory)
+ rename_machine_list
+ (concat prefix m.mname.node_id)
+ (List.map fst m.mmemory)
else [])
@ List.fold_left
(fun accu (id, (n, _)) ->
@@ -129,7 +115,9 @@ let arrow_vars machines machine : Lustre_types.var_decl list =
rename_machine_list
(concat
prefix
- (concat (if first then id else concat m.mname.node_id id) "_arrow"))
+ (concat
+ (if first then id else concat m.mname.node_id id)
+ "_arrow"))
(List.map fst arrow_machine.mmemory)
@ accu
else
diff --git a/src/backends/Horn/horn_backend_common.mli b/src/backends/Horn/horn_backend_common.mli
index 15d3c95a..e6fedcbb 100644
--- a/src/backends/Horn/horn_backend_common.mli
+++ b/src/backends/Horn/horn_backend_common.mli
@@ -3,63 +3,36 @@ open Format
open Lustre_types
open Machine_code_types
-val machine_reset_name: ident -> ident
-
-val machine_step_name: ident -> ident
-
-val machine_stateless_name: ident -> ident
-
+val machine_reset_name : ident -> ident
+val machine_step_name : ident -> ident
+val machine_stateless_name : 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 step_vars_c_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 node_name: Lustre_types.top_decl -> ident
+val node_name : Lustre_types.top_decl -> ident
diff --git a/src/backends/Horn/horn_backend_printers.ml b/src/backends/Horn/horn_backend_printers.ml
index fc176afc..1fa5c206 100644
--- a/src/backends/Horn/horn_backend_printers.ml
+++ b/src/backends/Horn/horn_backend_printers.ml
@@ -782,9 +782,7 @@ let rec pp_xml_expr fmt expr =
pp_xml_app fmt id e r)
and pp_xml_tuple fmt el = pp_comma_list pp_xml_expr fmt el
-
and pp_xml_handler fmt (t, h) = fprintf fmt "(%s -> %a)" t pp_xml_expr h
-
and pp_xml_handlers fmt hl = pp_print_list pp_xml_handler fmt hl
and pp_xml_app fmt id e r =
diff --git a/src/backends/Horn/horn_backend_printers.mli b/src/backends/Horn/horn_backend_printers.mli
index 46645330..a6e175b2 100644
--- a/src/backends/Horn/horn_backend_printers.mli
+++ b/src/backends/Horn/horn_backend_printers.mli
@@ -3,9 +3,6 @@ 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
diff --git a/src/backends/Java/java_backend.ml b/src/backends/Java/java_backend.ml
index a64e5543..98f4973d 100644
--- a/src/backends/Java/java_backend.ml
+++ b/src/backends/Java/java_backend.ml
@@ -37,7 +37,6 @@ let pp_type fmt t =
Types.print_ty fmt t
let pp_var fmt id = fprintf fmt "%a %s" pp_type id.var_type id.var_id
-
let pp_tag fmt t = pp_print_string fmt t
let rec pp_const fmt c =
diff --git a/src/backends/VHDL/vhdl_ast.ml b/src/backends/VHDL/vhdl_ast.ml
index 08da000c..e1a85bd5 100644
--- a/src/backends/VHDL/vhdl_ast.ml
+++ b/src/backends/VHDL/vhdl_ast.ml
@@ -136,11 +136,8 @@ type 'basetype vhdl_type_attributes_t =
| TAttStringArg of { id : string; arg : string }
let typ_att_noarg = [ "base"; "left"; "right"; "high"; "low" ]
-
let typ_att_intarg = [ "pos"; "val"; "succ"; "pred"; "leftof"; "rightof" ]
-
let typ_att_valarg = [ "image" ]
-
let typ_att_stringarg = [ "value" ]
let pp_type_attribute pp_val fmt tatt =
@@ -244,9 +241,7 @@ let rec pp_vhdl_expr fmt e =
(* Available operators in the standard library. There are some restrictions on
types. See reference doc. *)
let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "rem"; "abs"; "**" ]
-
let bool_funs = [ "and"; "or"; "nand"; "nor"; "xor"; "not" ]
-
let rel_funs = [ "<"; ">"; "<="; ">="; "/="; "=" ]
type vhdl_if_case_t = {
diff --git a/src/backends/backends.mli b/src/backends/backends.mli
index 303d93c7..bcc21354 100644
--- a/src/backends/backends.mli
+++ b/src/backends/backends.mli
@@ -1,7 +1,4 @@
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 2253e161..f9bfb0b2 100644
--- a/src/basic_library.ml
+++ b/src/basic_library.ml
@@ -169,11 +169,8 @@ let eval_dim_env =
defs
let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "uminus" ]
-
let bool_funs = [ "&&"; "||"; "xor"; "equi"; "impl"; "not" ]
-
let rel_funs = [ "<"; ">"; "<="; ">="; "!="; "=" ]
-
let internal_funs = arith_funs @ bool_funs @ rel_funs
let rec is_internal_fun x targs =
@@ -205,9 +202,7 @@ let is_value_internal_fun v =
assert false
let is_numeric_operator x = List.mem x arith_funs
-
let is_homomorphic_fun x = List.mem x internal_funs
-
let is_stateless_fun x = List.mem x internal_funs
(* let pp_java i pp_val fmt vl = *)
diff --git a/src/basic_library.mli b/src/basic_library.mli
index b422f219..a4e9d74c 100644
--- a/src/basic_library.mli
+++ b/src/basic_library.mli
@@ -1,29 +1,17 @@
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 :
diff --git a/src/causality.ml b/src/causality.ml
index 92f060d6..8b389b1b 100644
--- a/src/causality.ml
+++ b/src/causality.ml
@@ -80,8 +80,10 @@ let slice_graph gr v =
(fun s ->
IdentDepGraph.add_vertex gr' s;
IdentDepGraph.add_edge gr' v s)
- gr v)
- gr v;
+ gr
+ v)
+ gr
+ v;
gr'
module ExprDep = struct
@@ -106,9 +108,7 @@ module ExprDep = struct
Format.sprintf "!%s_%d" id !instance_var_cpt
let is_read_var v = v.[0] = '#'
-
let is_instance_var v = v.[0] = '!'
-
let is_ghost_var v = is_instance_var v || is_read_var v
let undo_read_var id =
diff --git a/src/causality.mli b/src/causality.mli
index 07883938..4e187c7a 100644
--- a/src/causality.mli
+++ b/src/causality.mli
@@ -9,18 +9,13 @@ type error =
exception Error of error
val pp_error : Format.formatter -> error -> unit
-
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
end
@@ -35,33 +30,22 @@ module VarClockDep : sig
val sort : (var_decl * 'a) list -> (var_decl * 'a) list
end
-val slice_graph: IdentDepGraph.t -> ident -> IdentDepGraph.t
-
+val slice_graph : IdentDepGraph.t -> ident -> IdentDepGraph.t
+
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 mk_read_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
@@ -75,9 +59,7 @@ module Disjunction : sig
type disjoint_map = (ident, CISet.t) Hashtbl.t
val pp_ciset : Format.formatter -> CISet.t -> unit
-
val clock_disjoint_map : var_decl list -> disjoint_map
-
val pp_disjoint_map : Format.formatter -> disjoint_map -> unit
end
@@ -90,5 +72,4 @@ 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 pp_dep_graph : Format.formatter -> IdentDepGraph.t -> unit
diff --git a/src/checks/algebraicLoop.ml b/src/checks/algebraicLoop.ml
index 4927fa24..4f0a3278 100644
--- a/src/checks/algebraicLoop.ml
+++ b/src/checks/algebraicLoop.ml
@@ -28,7 +28,6 @@ type call = ident * expr * eq
(* fun id, expression, and containing equation *)
type algebraic_loop = ident list * (call * bool) list * bool
-
type report = (node_desc * algebraic_loop list) list
(* XXX: UNUSED *)
diff --git a/src/checks/liveness.mli b/src/checks/liveness.mli
index 082c83ed..5e0e563c 100644
--- a/src/checks/liveness.mli
+++ b/src/checks/liveness.mli
@@ -1,8 +1,7 @@
open Utils
open Lustre_types
-val cone_of_influence: IdentDepGraph.t -> string -> ISet.t
-
+val cone_of_influence : IdentDepGraph.t -> string -> ISet.t
val compute_unused_variables : node_desc -> IdentDepGraph.t -> ISet.t
type fanin = (ident, tag) Hashtbl.t
@@ -10,7 +9,6 @@ type fanin = (ident, tag) Hashtbl.t
(* 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 pp_fanin : Format.formatter -> fanin -> unit
val compute_reuse_policy :
diff --git a/src/checks/stateless.mli b/src/checks/stateless.mli
index 41d4d96c..6f6b131e 100644
--- a/src/checks/stateless.mli
+++ b/src/checks/stateless.mli
@@ -9,11 +9,7 @@ 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 pp_error : Format.formatter -> error -> unit
diff --git a/src/clock_calculus.ml b/src/clock_calculus.ml
index ab5bfcea..c3ae2125 100644
--- a/src/clock_calculus.ml
+++ b/src/clock_calculus.ml
@@ -684,7 +684,9 @@ let clock_node env loc nd =
(* let is_main = nd.node_id = !Options.main_node in *)
let new_env = clock_var_decl_list env false nd.node_inputs in
let new_env = clock_var_decl_list new_env true nd.node_outputs in
- let new_env = clock_var_decl_list new_env true (List.map fst nd.node_locals) in
+ let new_env =
+ clock_var_decl_list new_env true (List.map fst nd.node_locals)
+ in
let eqs, _ = get_node_eqs nd in
(* TODO XXX: perform the clocking on auts. For the moment, it is ignored *)
List.iter (clock_eq new_env) eqs;
@@ -803,7 +805,8 @@ let uneval_top_generics decl =
| Node nd ->
(* A node could contain first-order carrier variable in local vars. This is
not the case for types. *)
- uneval_node_generics (nd.node_inputs @ List.map fst nd.node_locals @ nd.node_outputs)
+ uneval_node_generics
+ (nd.node_inputs @ List.map fst nd.node_locals @ nd.node_outputs)
| ImportedNode nd ->
uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
| Const _ | Include _ | Open _ | TypeDef _ ->
diff --git a/src/clock_calculus.mli b/src/clock_calculus.mli
index 5af4f6fc..63a1f7d2 100644
--- a/src/clock_calculus.mli
+++ b/src/clock_calculus.mli
@@ -1,11 +1,7 @@
open Lustre_types
val clock_node : Clocks.t Env.t -> Location.t -> node_desc -> Clocks.t Env.t
-
val compute_root_clock : Clocks.t -> Clocks.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 uneval_prog_generics : program_t -> unit
diff --git a/src/clock_predef.mli b/src/clock_predef.mli
index 6f6ce618..74209dc1 100644
--- a/src/clock_predef.mli
+++ b/src/clock_predef.mli
@@ -1,7 +1,4 @@
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 083443c4..3b5868b1 100644
--- a/src/clocks.ml
+++ b/src/clocks.ml
@@ -70,13 +70,9 @@ type error =
| Clock_extrusion of t * t
exception Unify of t * t
-
exception Mismatch of carrier_expr * carrier_expr
-
exception Scope_carrier of carrier_expr
-
exception Scope_clock of t
-
exception Error of Location.t * error
let rec print_carrier fmt cr =
@@ -118,7 +114,6 @@ let rec print_ck_long fmt ck =
fprintf fmt "(%a:%a)" print_carrier cr print_ck_long ck'
let new_id = ref (-1)
-
let rec bottom = { cdesc = Clink bottom; cid = -666; cscoped = false }
let new_ck desc scoped =
@@ -126,9 +121,7 @@ let new_ck desc scoped =
{ cdesc = desc; cid = !new_id; cscoped = scoped }
let new_var scoped = new_ck Cvar scoped
-
let new_univar () = new_ck Cunivar false
-
let new_carrier_id = ref (-1)
let new_carrier desc scoped =
@@ -303,17 +296,20 @@ let rec eq_clock ck1 ck2 =
let ck1' = repr ck1 in
let ck2' = repr ck2 in
ck1'.cid = ck2'.cid
- || match ck1'.cdesc, ck2'.cdesc with
+ ||
+ match ck1'.cdesc, ck2'.cdesc with
| Carrow (ck11, ck12), Carrow (ck21, ck22) ->
eq_clock ck11 ck21 && eq_clock ck12 ck22
- | Ctuple cks1, Ctuple cks2 ->
- begin try List.for_all2 eq_clock cks1 cks2 with Invalid_argument _ -> false end
+ | Ctuple cks1, Ctuple cks2 -> (
+ try List.for_all2 eq_clock cks1 cks2 with Invalid_argument _ -> false)
| Con (ck1, cr1, x1), Con (ck2, cr2, x2) ->
eq_clock ck1 ck2 && eq_carrier cr1 cr2 && x1 = x2
| Ccarrying (cr1, ck1), Ccarrying (cr2, ck2) ->
eq_carrier cr1 cr2 && eq_clock ck1 ck2
- | Cunivar, _ | _, Cunivar -> true
- | _ -> false
+ | Cunivar, _ | _, Cunivar ->
+ true
+ | _ ->
+ false
let equal ck1 ck2 =
(* let ck1 = repr ck1 in *)
diff --git a/src/clocks.mli b/src/clocks.mli
index 69502461..586ec869 100644
--- a/src/clocks.mli
+++ b/src/clocks.mli
@@ -45,35 +45,20 @@ type error =
(* Nice pretty-printing. Simplifies expressions before printing them. Non-linear
complexity. *)
val pp : Format.formatter -> t -> unit
-
val print_ck_long : Format.formatter -> t -> unit
-
val pp_suffix : Format.formatter -> t -> unit
-
val new_var : bool -> t
-
val new_univar : unit -> t
-
val new_ck : clock_desc -> bool -> t
-
val new_carrier : carrier_desc -> bool -> carrier_expr
-
val bottom : t
-
val repr : t -> t
-
val carrier_repr : carrier_expr -> carrier_expr
-
val simplify : t -> 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 root : t -> t
-
val branch : t -> (carrier_expr * ident) list
val common_prefix :
@@ -82,30 +67,19 @@ val common_prefix :
(carrier_expr * ident) list
val clock_of_root_branch : t -> (carrier_expr * ident) list -> t
-
val split_arrow : t -> t * t
-
val clock_current : t -> t
-
val uneval : ident -> carrier_expr -> unit
-
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 const_of_carrier : carrier_expr -> ident
-
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 ba31aefd..98c66ef8 100644
--- a/src/compiler_common.ml
+++ b/src/compiler_common.ml
@@ -357,7 +357,8 @@ let resolve_contracts prog =
let nd =
{
nd with
- node_locals = nd.node_locals @ List.map (fun v -> v, None) locals;
+ node_locals =
+ nd.node_locals @ List.map (fun v -> v, None) locals;
node_stmts = nd.node_stmts @ stmts;
node_spec = Some (Contract c);
}
diff --git a/src/compiler_common.mli b/src/compiler_common.mli
index 5b686c31..44bdafea 100644
--- a/src/compiler_common.mli
+++ b/src/compiler_common.mli
@@ -11,20 +11,13 @@ val check_compatibility :
unit
val update_vdecl_parents_prog : program_t -> unit
-
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 force_stateful_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 clock_decls : Clocks.t Env.t -> program_t -> Clocks.t Env.t
-
val create_dest_dir : unit -> unit
-
val track_exception : unit -> unit
diff --git a/src/corelang.ml b/src/corelang.ml
index 069b3ac2..528ff69a 100644
--- a/src/corelang.ml
+++ b/src/corelang.ml
@@ -35,7 +35,6 @@ module VSet : sig
include Set.S
val pp : Format.formatter -> t -> unit
-
val get : ident -> t -> elt
end
with type elt = var_decl = struct
@@ -50,7 +49,6 @@ with type elt = var_decl = struct
end
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 }
(************************************************************)
@@ -58,19 +56,17 @@ let dummy_clock_dec = { ck_dec_desc = Ckdec_any; ck_dec_loc = Location.dummy }
let fv_expr e =
let open ISet in
- let rec fv s e = match e.expr_desc with
+ let rec fv s e =
+ match e.expr_desc with
| Expr_ident x ->
add x s
- | Expr_tuple es
- | Expr_array es ->
+ | Expr_tuple es | Expr_array es ->
List.fold_left fv s es
| Expr_ite (e1, e2, e3) ->
fv (fv (fv s e1) e2) e3
- | Expr_arrow (e1, e2)
- | Expr_fby (e1, e2) ->
+ | Expr_arrow (e1, e2) | Expr_fby (e1, e2) ->
fv (fv s e1) e2
- | Expr_access (e1, d)
- | Expr_power (e1, d) ->
+ | Expr_access (e1, d) | Expr_power (e1, d) ->
union (fv s e1) (Dimension.fv d)
| Expr_pre e ->
fv s e
@@ -80,12 +76,12 @@ let fv_expr e =
List.fold_left (fun s (_, e) -> fv s e) (add x s) br
| Expr_appl (x, e, r) ->
fv (add x (Option.fold ~none:s ~some:(fv s) r)) e
- | Expr_const _ -> s
+ | Expr_const _ ->
+ s
in
fv ISet.empty e
let mktyp loc d = { ty_dec_desc = d; ty_dec_loc = loc }
-
let mkclock loc d = { ck_dec_desc = d; ck_dec_loc = loc }
let mkvar_decl loc ?(var_is_contract = false) ?(orig = false)
@@ -153,7 +149,6 @@ let mk_new_name used id =
new_name id 1
let mkeq loc (lhs, rhs) = { eq_lhs = lhs; eq_rhs = rhs; eq_loc = loc }
-
let mkassert loc expr = { assert_loc = loc; assert_expr = expr }
let mktop_decl top_decl_loc top_decl_owner top_decl_itf top_decl_desc =
@@ -342,13 +337,11 @@ let mkinstr ?lustre_eq ?(instr_spec = []) instr_desc =
instr_spec; lustre_eq }
let get_instr_desc i = i.instr_desc
-
let update_instr_desc i id = { i with instr_desc = id }
(***********************************************************)
(* Fast access to nodes, by name *)
let (node_table : (ident, top_decl) Hashtbl.t) = Hashtbl.create 30
-
let consts_table = Hashtbl.create 30
let pp_node_table fmt () =
@@ -399,7 +392,6 @@ let node_inputs td =
assert false
let node_from_name id = Hashtbl.find node_table id
-
let update_node id top = Hashtbl.replace node_table id top
let is_imported_node td =
@@ -423,7 +415,6 @@ let is_contract td =
(* alias and type definition table *)
let mktop = mktop_decl Location.dummy !Options.dest_dir false
-
let top_int_type = mktop (TypeDef { tydef_id = "int"; tydef_desc = Tydec_int })
let top_bool_type =
@@ -782,7 +773,8 @@ let rec is_eq_expr e1 e2 =
| _ ->
false
-let get_node_vars nd = nd.node_inputs @ List.map fst nd.node_locals @ nd.node_outputs
+let get_node_vars nd =
+ nd.node_inputs @ List.map fst nd.node_locals @ nd.node_outputs
let mk_new_node_name nd id =
let used_vars = get_node_vars nd in
@@ -1133,7 +1125,9 @@ let rename_node f_node f_var nd =
let rename_stmts = rename_stmts f_node f_var in
let inputs = rename_vars nd.node_inputs in
let outputs = rename_vars nd.node_outputs in
- let locals = List.map (fun (v, i) -> rename_var v, Option.map f_var i) nd.node_locals in
+ let locals =
+ List.map (fun (v, i) -> rename_var v, Option.map f_var i) nd.node_locals
+ in
let gen_calls = List.map rename_expr nd.node_gencalls in
let node_checks = List.map (Dimension.rename f_node f_var) nd.node_checks in
let node_asserts =
@@ -1579,7 +1573,6 @@ let rec expr_contains_expr expr_tag expr =
(* Generate a new local [node] variable *)
let cpt_fresh = ref 0
-
let reset_cpt_fresh () = cpt_fresh := 0
let mk_fresh_var (parentid, ctx_env) loc ty ck =
diff --git a/src/corelang.mli b/src/corelang.mli
index 13b98ff3..e24cd429 100644
--- a/src/corelang.mli
+++ b/src/corelang.mli
@@ -34,19 +34,14 @@ module VSet : sig
include Set.S
val pp : Format.formatter -> t -> unit
-
val get : ident -> t -> elt
end
with type elt = var_decl
val fv_expr : expr -> ISet.t
-
val dummy_type_dec : type_dec
-
val dummy_clock_dec : clock_dec
-
val mktyp : Location.t -> type_dec_desc -> type_dec
-
val mkclock : Location.t -> clock_dec_desc -> clock_dec
val mkvar_decl :
@@ -64,23 +59,14 @@ val mkvar_decl :
var_decl
val dummy_var_decl : ident -> Types.t -> var_decl
-
val var_decl_of_const : ?parentid:ident option -> const_desc -> var_decl
-
val mkexpr : Location.t -> expr_desc -> expr
-
val mkeq : Location.t -> ident list * expr -> eq
-
val mkassert : Location.t -> expr -> assert_t
-
val mktop_decl : Location.t -> ident -> bool -> top_decl_desc -> top_decl
-
val mkpredef_call : Location.t -> ident -> expr list -> expr
-
val mk_new_name : (ident -> bool) -> ident -> ident
-
val mk_new_node_name : node_desc -> ident -> ident
-
val mktop : top_decl_desc -> top_decl
(* constructor for machine types *)
@@ -101,137 +87,77 @@ val update_instr_desc :
(*val node_table : (ident, top_decl) Hashtbl.t*)
val pp_node_table : Format.formatter -> unit -> unit
-
val node_name : top_decl -> ident
-
val node_inputs : top_decl -> var_decl list
-
val node_from_name : ident -> top_decl
-
val update_node : ident -> top_decl -> unit
-
val is_generic_node : top_decl -> bool
-
val is_imported_node : top_decl -> bool
-
val is_contract : top_decl -> bool
-
val is_node_contract : node_desc -> bool
-
val get_node_contract : node_desc -> contract_desc
-
val consts_table : (ident, top_decl) Hashtbl.t
-
val pp_consts_table : Format.formatter -> unit -> unit
-
val type_table : (type_dec_desc, top_decl) Hashtbl.t
-
val pp_type_table : Format.formatter -> unit -> unit
-
val is_clock_dec_type : type_dec_desc -> bool
-
val get_repr_type : type_dec_desc -> type_dec_desc
-
val is_user_type : type_dec_desc -> bool
-
val coretype_equal : type_dec_desc -> type_dec_desc -> bool
-
val tag_default : label
-
val tag_table : (label, top_decl) Hashtbl.t
-
val field_table : (label, top_decl) Hashtbl.t
-
val get_enum_type_tags : type_dec_desc -> label list
-
val get_struct_type_fields : type_dec_desc -> (label * type_dec_desc) list
-
val consts_of_enum_type : top_decl -> top_decl list
-
val const_of_bool : bool -> constant
-
val const_is_bool : constant -> bool
-
val const_negation : constant -> constant
-
val const_or : constant -> constant -> constant
-
val const_and : constant -> constant -> constant
-
val const_xor : constant -> constant -> constant
-
val const_impl : constant -> constant -> constant
-
val get_var : ident -> var_decl list -> var_decl
-
val get_node_vars : node_desc -> var_decl list
-
val get_node_var : ident -> node_desc -> var_decl
-
val get_node_eqs : node_desc -> eq list * automata_desc list
-
val get_contract_eqs : contract_desc -> eq list * automata_desc list
-
val get_node_eq : ident -> node_desc -> eq
-
val get_node_interface : node_desc -> imported_node_desc
(* val get_const: ident -> constant *)
val sort_handlers : (label * 'a) list -> (label * 'a) list
-
val is_eq_expr : expr -> expr -> bool
(* val pp_error : Format.formatter -> error -> unit *)
(* Caution, returns an untyped, unclocked, etc, expression *)
val is_tuple_expr : expr -> bool
-
val ident_of_expr : expr -> ident
-
val expr_of_vdecl : var_decl -> expr
-
val expr_of_ident : ident -> Location.t -> expr
-
val expr_list_of_expr : expr -> expr list
-
val expr_of_expr_list : Location.t -> expr list -> expr
-
val call_of_expr : expr -> ident * expr list * expr option
-
val expr_of_dimension : Dimension.t -> expr
-
val dimension_of_expr : expr -> Dimension.t
-
val dimension_of_const : Location.t -> constant -> Dimension.t
-
val expr_to_eexpr : expr -> eexpr
(* REMOVED, pushed in utils.ml val new_tag : unit -> tag *)
val add_internal_funs : unit -> unit
-
val pp_prog_type : Format.formatter -> program_t -> unit
-
val pp_prog_clock : Format.formatter -> program_t -> unit
-
val const_of_top : top_decl -> const_desc
-
val node_of_top : top_decl -> node_desc
-
val imported_node_of_top : top_decl -> imported_node_desc
-
val typedef_of_top : top_decl -> typedef_desc
-
val dependency_of_top : top_decl -> bool * ident
-
val get_nodes : program_t -> top_decl list
-
val get_imported_nodes : program_t -> top_decl list
-
val get_consts : program_t -> top_decl list
-
val get_typedefs : program_t -> top_decl list
-
val get_dependencies : program_t -> top_decl list
(* val prog_unfold_consts: program_t -> program_t *)
@@ -239,9 +165,7 @@ 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_carrier : (ident -> ident) -> clock_dec_desc -> clock_dec_desc
-
val get_expr_vars : expr -> Utils.ISet.t
(*val expr_replace_var: (ident -> ident) -> expr -> expr*)
@@ -266,17 +190,11 @@ val rename_prog :
(** rename_prog f_node f_var f_const prog *)
val rename_node : (ident -> ident) -> (ident -> ident) -> node_desc -> node_desc
-
val substitute_expr : var_decl list -> eq list -> expr -> expr
-
val copy_var_decl : var_decl -> var_decl
-
val copy_const : const_desc -> const_desc
-
val copy_node : node_desc -> node_desc
-
val copy_top : top_decl -> top_decl
-
val copy_prog : top_decl list -> top_decl list
val mkeexpr : Location.t -> expr -> eexpr
@@ -296,16 +214,12 @@ val mk_contract_mode :
ident -> eexpr list -> eexpr list -> Location.t -> contract_desc
val mk_contract_import : ident -> expr -> expr -> Location.t -> contract_desc
-
val merge_contracts : contract_desc -> contract_desc -> contract_desc
-
val extend_eexpr : (quantifier_type * var_decl list) list -> eexpr -> eexpr
-
val update_expr_annot : ident -> expr -> expr_annot -> expr
(* val mkpredef_call: Location.t -> ident -> eexpr list -> eexpr*)
val expr_contains_expr : tag -> expr -> bool
-
val reset_cpt_fresh : unit -> unit
(* mk_fresh_var parentid to be registered as parent_nodeid, vars is the list of
@@ -314,15 +228,12 @@ val mk_fresh_var :
ident * var_decl list -> Location.t -> Types.t -> Clocks.t -> var_decl
val find_eq : ident list -> eq list -> eq * eq list
-
val get_expr_calls : top_decl list -> expr -> Utils.ISet.t
(* val eq_has_arrows: eq -> bool *)
val push_negations : ?neg:bool -> expr -> expr
-
val add_pre_expr : ident list -> expr -> expr
-
val mk_eq : Location.t -> expr -> expr -> expr
(* Simple transformations: eg computation over constants *)
diff --git a/src/delay.ml b/src/delay.ml
index 114267d6..ff8d3154 100644
--- a/src/delay.ml
+++ b/src/delay.ml
@@ -31,7 +31,6 @@ let new_delay desc =
{ ddesc = desc; did = !new_id }
let new_var () = new_delay Dvar
-
let new_univar () = new_delay Dunivar
(* XXX: UNUSED *)
diff --git a/src/delay.mli b/src/delay.mli
index 57e4739b..ed78acd4 100644
--- a/src/delay.mli
+++ b/src/delay.mli
@@ -11,7 +11,5 @@ and delay_desc =
(* Polymorphic type variable *)
val new_var : unit -> t
-
val new_univar : unit -> t
-
val new_delay : delay_desc -> t
diff --git a/src/delay_predef.mli b/src/delay_predef.mli
index d9dd4ec9..da0b589e 100644
--- a/src/delay_predef.mli
+++ b/src/delay_predef.mli
@@ -1,7 +1,4 @@
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/error.mli b/src/error.mli
index 0dffec45..34848d13 100644
--- a/src/error.mli
+++ b/src/error.mli
@@ -14,9 +14,6 @@ type t =
exception Error of Location.t * t
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
diff --git a/src/features/machine_types/machine_types.ml b/src/features/machine_types/machine_types.ml
index 50765873..ffd57311 100644
--- a/src/features/machine_types/machine_types.ml
+++ b/src/features/machine_types/machine_types.ml
@@ -33,7 +33,6 @@
open Lustre_types
let is_active = false
-
let keywords = [ "machine_types" ]
module MT = struct
@@ -121,23 +120,14 @@ module MT = struct
match t with MTbool | MTint _ | MTreal _ -> true | _ -> false
let is_numeric_type t = match t with MTint _ | MTreal _ -> true | _ -> false
-
let is_int_type t = match t with MTint _ -> true | _ -> false
-
let is_real_type t = match t with MTreal _ -> true | _ -> false
-
let is_bool_type t = t = MTbool
-
let is_dimension_type t = match t with MTint _ | MTbool -> true | _ -> false
-
let type_int_builder = MTint None
-
let type_real_builder = MTreal None
-
let type_bool_builder = MTbool
-
let type_string_builder = MTstring
-
let unify _ _ = ()
let is_unifiable b1 b2 =
@@ -161,19 +151,12 @@ end
module MTypes = Types.Make (MT)
let type_uint8 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint8_t)))
-
let type_uint16 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint16_t)))
-
let type_uint32 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint32_t)))
-
let type_uint64 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint64_t)))
-
let type_int8 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint8_t)))
-
let type_int16 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint16_t)))
-
let type_int32 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint32_t)))
-
let type_int64 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint64_t)))
module ConvTypes = struct
@@ -459,7 +442,9 @@ let load prog =
match top.top_decl_desc with
| Node nd ->
(* Format.eprintf "Registeing node %s@." nd.node_id; *)
- let vars = nd.node_inputs @ nd.node_outputs @ List.map fst nd.node_locals in
+ let vars =
+ nd.node_inputs @ nd.node_outputs @ List.map fst nd.node_locals
+ in
let constrained_vars = register_node vars nd.node_annot in
check_node nd constrained_vars;
diff --git a/src/features/machine_types/machine_types.mli b/src/features/machine_types/machine_types.mli
index 3301a70b..e0033267 100644
--- a/src/features/machine_types/machine_types.mli
+++ b/src/features/machine_types/machine_types.mli
@@ -3,17 +3,11 @@ open Format
open Lustre_types
val is_exportable : var_decl -> bool
-
val has_machine_type : unit -> bool
-
val is_specified : var_decl -> bool
-
val is_active : bool
-
val pp_var_type : formatter -> var_decl -> unit
-
val pp_c_var_type : formatter -> var_decl -> unit
-
val load : program_t -> unit
(* Typing the expression (vars = expr) in node *)
@@ -22,7 +16,5 @@ val type_def : ident * var_decl list -> var_decl list -> expr -> unit
module ConvTypes : Typing.EXPR_TYPE_HUB
val get_specified_type : var_decl -> ConvTypes.type_expr
-
val type_name : ConvTypes.type_expr -> ident
-
val keywords : string list
diff --git a/src/global.mli b/src/global.mli
index 3228633f..752237dc 100644
--- a/src/global.mli
+++ b/src/global.mli
@@ -1,7 +1,4 @@
val type_env : Types.t Env.t ref
-
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 e1b15397..e5d964b6 100644
--- a/src/inliner.ml
+++ b/src/inliner.ml
@@ -180,7 +180,7 @@ let inline_call node loc uid args reset locals caller =
let vdecl' = rename_var vdecl in
{ vdecl' with var_dec_value = Some (Corelang.expr_of_dimension arg) })
static_inputs
- @ List.map ( fun (v, _) -> rename_var v) node.node_locals
+ @ List.map (fun (v, _) -> rename_var v) node.node_locals
in
(* checking we are at the appropriate (early) step: node_checks and
node_gencalls should be empty (not yet assigned) *)
diff --git a/src/inliner.mli b/src/inliner.mli
index a257d505..252545e8 100644
--- a/src/inliner.mli
+++ b/src/inliner.mli
@@ -2,7 +2,5 @@ open Utils
open Lustre_types
val global_inline : program_t -> program_t
-
val local_inline : program_t -> program_t
-
val keyword : ident list
diff --git a/src/lusic.mli b/src/lusic.mli
index bbf1a31a..522802fd 100644
--- a/src/lusic.mli
+++ b/src/lusic.mli
@@ -11,5 +11,4 @@ val read_lusic : string -> string -> t
(* encode and write a header in a file *)
val write_lusic : bool -> program_t -> string -> string -> unit
-
val check_obsolete : t -> string -> unit
diff --git a/src/lustre_live.ml b/src/lustre_live.ml
index a81db2a5..9a9dfe84 100644
--- a/src/lustre_live.ml
+++ b/src/lustre_live.ml
@@ -71,9 +71,7 @@ let rec occur_expr s e =
s
let occur s eq = occur_expr s eq.eq_rhs
-
let live : (ident, ISet.t Live.t) Hashtbl.t = Hashtbl.create 32
-
let of_var_decls = List.fold_left (fun s v -> add v.var_id s) empty
let set_live_of nid outputs locals sorted_eqs =
diff --git a/src/lustre_live.mli b/src/lustre_live.mli
index 1d3eeccf..9cc8e925 100644
--- a/src/lustre_live.mli
+++ b/src/lustre_live.mli
@@ -2,7 +2,5 @@ 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
diff --git a/src/lustre_types.ml b/src/lustre_types.ml
index 79b38408..4d8bdbb4 100644
--- a/src/lustre_types.ml
+++ b/src/lustre_types.ml
@@ -28,11 +28,9 @@ and type_dec_desc =
| Tydec_array of Dimension.t * type_dec_desc
type typedec_desc = { tydec_id : ident }
-
type typedef_desc = { tydef_id : ident; tydef_desc : type_dec_desc }
type clock_dec = { ck_dec_desc : clock_dec_desc; ck_dec_loc : Location.t }
-
and clock_dec_desc = Ckdec_any | Ckdec_bool of (ident * ident) list
type constant =
@@ -129,7 +127,6 @@ type contract_import = {
}
type offset = Index of Dimension.t | Field of label
-
type assert_t = { assert_expr : expr; assert_loc : Location.t }
type statement = Eq of eq | Aut of automata_desc
@@ -243,7 +240,6 @@ type spec_types =
| TopContract of top_decl list
let tag_true = "true"
-
let tag_false = "false"
(* Project the contract node as a pure contract: local memories are pushed back
diff --git a/src/lustre_types.mli b/src/lustre_types.mli
index d533bbfe..54fa5868 100644
--- a/src/lustre_types.mli
+++ b/src/lustre_types.mli
@@ -17,11 +17,9 @@ and type_dec_desc =
| Tydec_array of Dimension.t * type_dec_desc
type typedec_desc = { tydec_id : ident }
-
type typedef_desc = { tydef_id : ident; tydef_desc : type_dec_desc }
type clock_dec = { ck_dec_desc : clock_dec_desc; ck_dec_loc : Location.t }
-
and clock_dec_desc = Ckdec_any | Ckdec_bool of (ident * ident) list
type constant =
@@ -118,7 +116,6 @@ type contract_import = {
}
type offset = Index of Dimension.t | Field of label
-
type assert_t = { assert_expr : expr; assert_loc : Location.t }
type statement = Eq of eq | Aut of automata_desc
@@ -231,7 +228,5 @@ type spec_types =
| TopContract of top_decl list
val tag_true : label
-
val tag_false : label
-
val node_as_contract : node_desc -> contract_desc
diff --git a/src/lustre_utils.ml b/src/lustre_utils.ml
index c267fc4d..d4f3ab86 100644
--- a/src/lustre_utils.ml
+++ b/src/lustre_utils.ml
@@ -75,7 +75,7 @@ let check_eq nd1 nd2 =
check_nd with
node_id = "check_eq_" ^ nd1.node_id ^ "_" ^ nd2.node_id;
node_outputs = [ ok_var ];
- node_locals = List.map (fun v -> v, None) (out_vars1 @ out_vars2);
+ node_locals = List.map (fun v -> v, None) (out_vars1 @ out_vars2);
node_stmts = [ call_n1; call_n2; ok_stmt ];
node_spec = Some (Contract contract);
}
diff --git a/src/lustre_utils.mli b/src/lustre_utils.mli
index c1ff4951..cfa62b31 100644
--- a/src/lustre_utils.mli
+++ b/src/lustre_utils.mli
@@ -1 +1,2 @@
-val check_eq: Lustre_types.node_desc -> Lustre_types.node_desc -> Lustre_types.node_desc
+val check_eq :
+ Lustre_types.node_desc -> Lustre_types.node_desc -> Lustre_types.node_desc
diff --git a/src/machine_code.ml b/src/machine_code.ml
index 17f91d2f..29a73c8e 100644
--- a/src/machine_code.ml
+++ b/src/machine_code.ml
@@ -149,15 +149,16 @@ let rec translate_act env (y, expr) =
let c = translate_guard c in
let t, spec_t = translate_act (y, t) in
let e, spec_e = translate_act (y, e) in
- mk_conditional ~lustre_eq c [ t ] [ e ],
- mk_conditional_tr c spec_t spec_e
+ mk_conditional ~lustre_eq c [ t ] [ e ], mk_conditional_tr c spec_t spec_e
| Expr_merge (x, hl) ->
let var_x = env.get_var x in
let hl, spec_hl =
- List.fold_right (fun (t, h) (hl, spec_hl) ->
+ List.fold_right
+ (fun (t, h) (hl, spec_hl) ->
let h, spec_h = translate_act (y, h) in
(t, [ h ]) :: hl, (t, spec_h) :: spec_hl)
- hl ([], [])
+ hl
+ ([], [])
in
mk_branch' ~lustre_eq var_x hl, mk_branch_tr var_x spec_hl
| _ ->
@@ -179,7 +180,7 @@ type machine_ctx = {
(* memories *)
m : ISet.t;
(* arrows *)
- a: ident IMap.t;
+ a : ident IMap.t;
(* Reset instructions *)
si : instr_t list;
(* Instances *)
@@ -189,7 +190,7 @@ type machine_ctx = {
(* Memory pack base spec *)
mp_base : mc_formula_t;
(* tainted state vars *)
- tainted: ISet.t;
+ tainted : ISet.t;
(* Memory pack spec *)
mp : (int * mc_formula_t) list;
(* Transition spec *)
@@ -211,10 +212,12 @@ let ctx_init =
si = [];
j = IMap.empty;
s = [];
- mp_base = And [ StateVarPack (ResetFlag, false); Equal (Memory ResetFlag, Val zero) ];
+ mp_base =
+ And
+ [ StateVarPack (ResetFlag, false); Equal (Memory ResetFlag, Val zero) ];
tainted = ISet.empty;
mp = [];
- t = []
+ t = [];
}
(****************************************************************)
@@ -265,17 +268,16 @@ let translate_eq env ctx nd mems inputs locals outputs i eq =
let outputs_i = Lustre_live.inter_live_i_with id i outputs in
let pred_mp_base ctx a =
(* let j = try fst (List.hd ctx.mp) with _ -> 0 in *)
- match a with
- | Some a ->
- And [ ctx.mp_base; a ]
- | None ->
- ctx.mp_base
+ match a with Some a -> And [ ctx.mp_base; a ] | None -> ctx.mp_base
in
let pred_mp ctx =
- let spec = VMap.fold (fun v _ a ->
- let tainted = ISet.mem v.var_id ctx.tainted in
- And [ a; mk_state_variable_pack ~tainted v ])
- mems (mk_memory_pack_base id)
+ let spec =
+ VMap.fold
+ (fun v _ a ->
+ let tainted = ISet.mem v.var_id ctx.tainted in
+ And [ a; mk_state_variable_pack ~tainted v ])
+ mems
+ (mk_memory_pack_base id)
in
(i, spec) :: ctx.mp
in
@@ -307,17 +309,17 @@ let translate_eq env ctx nd mems inputs locals outputs i eq =
(if fst (get_stateless_status_node nd) || not mk_mp then []
else [ mk_memory_pack ~i id, true ])
@ [
- mk_transition
- ~i
- stateless
- id
- (vdecls_to_vals (inputs @ locals_i @ outputs_i)),
- true
+ ( mk_transition
+ ~i
+ stateless
+ id
+ (vdecls_to_vals (inputs @ locals_i @ outputs_i)),
+ true );
];
}
:: ctx.s;
mp_base = pred_mp_base ctx spec_mp_base;
- mp = if not mk_mp then ctx.mp else pred_mp ctx;
+ mp = (if not mk_mp then ctx.mp else pred_mp ctx);
t = pred_t ctx (fspec spec_t);
}
in
@@ -344,17 +346,23 @@ let translate_eq env ctx nd mems inputs locals outputs i eq =
true
(Some (mk_memory_pack ~inst (node_name td)))
(mk_transition ~inst false (node_name td) [ vdecl_to_val var_x ])
- { ctx with
+ {
+ ctx with
j = IMap.add inst (td, []) ctx.j;
a = IMap.add x inst ctx.a;
- tainted = VMap.fold (fun v x' s ->
- match x' with
- | Some x' when x = x' -> ISet.add v.var_id s
- | _ -> s) mems ctx.tainted
+ tainted =
+ VMap.fold
+ (fun v x' s ->
+ match x' with
+ | Some x' when x = x' ->
+ ISet.add v.var_id s
+ | _ ->
+ s)
+ mems
+ ctx.tainted;
}
in
{ ctx with si = mkinstr (MSetReset inst) :: ctx.si }
-
| [ x ], Expr_pre e when env.is_local x ->
let var_x = env.get_var x in
let e = translate_expr e in
@@ -363,10 +371,7 @@ let translate_eq env ctx nd mems inputs locals outputs i eq =
true
None
(mk_state_assign_tr var_x e)
- { ctx with
- m = ISet.add x ctx.m;
- tainted = ISet.remove x ctx.tainted
- }
+ { ctx with m = ISet.add x ctx.m; tainted = ISet.remove x ctx.tainted }
| [ x ], Expr_fby (e1, e2) when env.is_local x ->
let var_x = env.get_var x in
let e2 = translate_expr e2 in
@@ -376,10 +381,7 @@ let translate_eq env ctx nd mems inputs locals outputs i eq =
true
None
(mk_state_assign_tr var_x e2)
- { ctx with
- m = ISet.add x ctx.m;
- tainted = ISet.remove x ctx.tainted
- }
+ { ctx with m = ISet.add x ctx.m; tainted = ISet.remove x ctx.tainted }
in
{
ctx with
@@ -406,7 +408,8 @@ let translate_eq env ctx nd mems inputs locals outputs i eq =
let stateless = Stateless.check_node node_f in
let inst = if stateless then None else Some i in
let mk_mp, mp =
- if stateless then false, None else true, Some (mk_memory_pack ?inst (node_name node_f))
+ if stateless then false, None
+ else true, Some (mk_memory_pack ?inst (node_name node_f))
in
let ctx =
ctl
@@ -440,7 +443,12 @@ let translate_eq env ctx nd mems inputs locals outputs i eq =
let instr, spec = translate_act (var_x, eq.eq_rhs) in
control_on_clock eq.eq_rhs.expr_clock instr false None spec ctx
with Not_found ->
- Format.eprintf "ERROR: node %s, eq %a : unknown variable %s@." id Printers.pp_node_eq eq x;
+ Format.eprintf
+ "ERROR: node %s, eq %a : unknown variable %s@."
+ id
+ Printers.pp_node_eq
+ eq
+ x;
raise Not_found)
| _ ->
Format.eprintf
@@ -517,12 +525,16 @@ let translate_core env nd sorted_eqs mems inputs locals outputs =
let constant_eqs = constant_equations locals in
(* Compute constants' instructions *)
- let ctx0 = translate_eqs env ctx_init nd mems inputs locals outputs constant_eqs in
+ let ctx0 =
+ translate_eqs env ctx_init nd mems inputs locals outputs constant_eqs
+ in
assert (ctx0.si = []);
assert (IMap.is_empty ctx0.j);
(* Compute ctx for all eqs *)
- let ctx = translate_eqs env ctx_init nd mems inputs locals outputs sorted_eqs in
+ let ctx =
+ translate_eqs env ctx_init nd mems inputs locals outputs sorted_eqs
+ in
ctx, ctx0.s
@@ -530,10 +542,13 @@ let memory_pack_0 nd mems =
{
mpname = nd;
mpindex = Some 0;
- mpformula = VSet.fold (fun v a ->
- And [ a; mk_state_variable_pack v ])
- mems (mk_memory_pack_base nd.node_id)
- (* And [ StateVarPack (ResetFlag, false); Equal (Memory ResetFlag, Val zero) ]; *)
+ mpformula =
+ VSet.fold
+ (fun v a -> And [ a; mk_state_variable_pack v ])
+ mems
+ (mk_memory_pack_base nd.node_id)
+ (* And [ StateVarPack (ResetFlag, false); Equal (Memory ResetFlag, Val
+ zero) ]; *);
}
let memory_pack_toplevel nd i =
@@ -542,7 +557,9 @@ let memory_pack_toplevel nd i =
mpindex = None;
mpformula =
Ternary
- (Memory ResetFlag, StateVarPack (ResetFlag, false), mk_memory_pack ~i nd.node_id);
+ ( Memory ResetFlag,
+ StateVarPack (ResetFlag, false),
+ mk_memory_pack ~i nd.node_id );
}
let transition_0 nd =
@@ -651,14 +668,26 @@ let translate_decl nd sch =
Lustre_live.set_live_of nd.node_id nd.node_outputs locals equations;
(* Translate equations *)
- let mems_taints = VSet.fold (fun v m ->
- match List.assoc_opt v nd.node_locals with
- | Some x -> VMap.add v x m
- | None -> m)
- mems VMap.empty
+ let mems_taints =
+ VSet.fold
+ (fun v m ->
+ match List.assoc_opt v nd.node_locals with
+ | Some x ->
+ VMap.add v x m
+ | None ->
+ m)
+ mems
+ VMap.empty
in
let ctx, ctx0_s =
- translate_core env nd equations mems_taints nd.node_inputs locals nd.node_outputs
+ translate_core
+ env
+ nd
+ equations
+ mems_taints
+ nd.node_inputs
+ locals
+ nd.node_outputs
in
(* Format.eprintf "ok4@.@?"; *)
@@ -695,19 +724,21 @@ let translate_decl nd sch =
((if fst (get_stateless_status_node nd) then []
else [ mk_memory_pack ~i:0 nd.node_id, true ])
@ [
- mk_transition
- ~i:0
- stateless
- nd.node_id
- (vdecls_to_vals nd.node_inputs),
- true
+ ( mk_transition
+ ~i:0
+ stateless
+ nd.node_id
+ (vdecls_to_vals nd.node_inputs),
+ true );
])
MClearReset
in
let find_arrow v =
match List.assoc_opt v nd.node_locals with
- | Some (Some x) -> IMap.find_opt x ctx.a
- | _ -> None
+ | Some (Some x) ->
+ IMap.find_opt x ctx.a
+ | _ ->
+ None
in
let mnode_spec = Utils.option_map (translate_spec env) nd.node_spec in
{
@@ -743,7 +774,13 @@ let translate_decl nd sch =
been processed already. Either one of the other machine is a cocospec
node, or the current one is a cocospec node. Contract do not contain any
statement or import. *)
- mspec = { mnode_spec; mtransitions; mmemory_packs; mmemory_pack_base = ctx.mp_base };
+ mspec =
+ {
+ mnode_spec;
+ mtransitions;
+ mmemory_packs;
+ mmemory_pack_base = ctx.mp_base;
+ };
mannot = nd.node_annot;
msch = Some sch;
mis_contract = nd.node_iscontract;
diff --git a/src/machine_code_common.ml b/src/machine_code_common.ml
index 50326f19..c0110d9e 100644
--- a/src/machine_code_common.ml
+++ b/src/machine_code_common.ml
@@ -8,14 +8,10 @@ open Format
let print_statelocaltag = true
let find_tainter_arrow m id =
- List.find_opt (fun (x, _) -> x.var_id = id.var_id) m.mmemory
- |> Option.map snd
-
-let is_memory m id =
- Option.is_some (find_tainter_arrow m id)
+ List.find_opt (fun (x, _) -> x.var_id = id.var_id) m.mmemory |> Option.map snd
+let is_memory m id = Option.is_some (find_tainter_arrow m id)
let is_reset_flag id = id.var_id = "_reset"
-
let pp_vdecl fmt v = pp_print_string fmt v.var_id
let rec pp_val m fmt v =
@@ -85,11 +81,7 @@ module PrintSpec = struct
(pp_val m)
r
| MemoryPackBase f ->
- fprintf
- fmt
- "MemoryPackBase_%a"
- pp_print_string
- f
+ fprintf fmt "MemoryPackBase_%a" pp_print_string f
| MemoryPack (f, inst, i) ->
fprintf
fmt
@@ -164,9 +156,13 @@ module PrintSpec = struct
| Predicate p ->
pp_predicate m fmt p
| StateVarPack (r, tainted) ->
- fprintf fmt "StateVarPack%a<%a>"
- (if tainted then pp_print_string else pp_print_nothing) "_tainted"
- pp_reg r
+ fprintf
+ fmt
+ "StateVarPack%a<%a>"
+ (if tainted then pp_print_string else pp_print_nothing)
+ "_tainted"
+ pp_reg
+ r
| ExistsMem (_f, a, b) ->
fprintf fmt "@[<hv 2>∃ MEM,@ %a@]" pp_spec (And [ a; b ])
| Value v ->
@@ -184,7 +180,8 @@ let pp_spec m =
pp_print_list
~pp_open_box:pp_open_vbox0
~pp_prologue:pp_print_cut
- (fun fmt (spec, _) -> fprintf fmt "@[<h>--%@ %a@]" (PrintSpec.pp_spec m) spec)
+ (fun fmt (spec, _) ->
+ fprintf fmt "@[<h>--%@ %a@]" (PrintSpec.pp_spec m) spec)
let rec pp_instr m fmt i =
let pp_val = pp_val m in
@@ -261,7 +258,8 @@ let get_node_def id m =
(* merge log: machine_vars was in 44686 *)
let machine_vars m =
- m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs @ List.map fst m.mmemory
+ m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs
+ @ List.map fst m.mmemory
let pp_step m fmt s =
fprintf
@@ -311,8 +309,11 @@ let pp_memory_packs m fmt =
| Options.SpecNo ->
pp_print_nothing fmt
| _ ->
- fprintf fmt "@[<v 2>memory_packs:@ %a@ %a@]"
- pp_memory_pack_base m
+ fprintf
+ fmt
+ "@[<v 2>memory_packs:@ %a@ %a@]"
+ pp_memory_pack_base
+ m
(pp_print_list (pp_memory_pack m))
let pp_transition m fmt t =
@@ -404,7 +405,6 @@ let get_stateless_status_top_decl td =
true, false
let get_stateless_status m = get_stateless_status_node m.mname
-
let is_stateless m = m.minstances = [] && m.mmemory = []
(* let is_input m id =
@@ -414,11 +414,8 @@ let is_output m id =
List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_outputs
let get_instr_spec i = i.instr_spec
-
let mk_val v t = { value_desc = v; value_type = t; value_annot = None }
-
let vdecl_to_val vd = mk_val (Var vd) vd.var_type
-
let vdecls_to_vals = List.map vdecl_to_val
let id_to_tag id =
@@ -428,10 +425,10 @@ let id_to_tag id =
let mk_conditional ?lustre_eq c t e =
mkinstr ?lustre_eq (MBranch (c, [ tag_true, t; tag_false, e ]))
-let mk_branch ?lustre_eq c br = mkinstr ?lustre_eq (MBranch (c, sort_handlers br))
+let mk_branch ?lustre_eq c br =
+ mkinstr ?lustre_eq (MBranch (c, sort_handlers br))
let mk_branch' ?lustre_eq v = mk_branch ?lustre_eq (vdecl_to_val v)
-
let mk_assign ?lustre_eq x v = mkinstr ?lustre_eq (MLocalAssign (x, v))
let arrow_machine =
@@ -475,7 +472,13 @@ let arrow_machine =
];
step_asserts = [];
};
- mspec = { mnode_spec = None; mtransitions = []; mmemory_packs = -1, []; mmemory_pack_base = True };
+ mspec =
+ {
+ mnode_spec = None;
+ mtransitions = [];
+ mmemory_packs = -1, [];
+ mmemory_pack_base = True;
+ };
mannot = [];
msch = None;
mis_contract = false;
@@ -518,7 +521,13 @@ let empty_machine =
step_instrs = [];
step_asserts = [];
};
- mspec = { mnode_spec = None; mtransitions = []; mmemory_packs = -1, []; mmemory_pack_base = True };
+ mspec =
+ {
+ mnode_spec = None;
+ mtransitions = [];
+ mmemory_packs = -1, [];
+ mmemory_pack_base = True;
+ };
mannot = [];
msch = None;
mis_contract = false;
diff --git a/src/machine_code_common.mli b/src/machine_code_common.mli
index e6e07d35..84a7e4ae 100644
--- a/src/machine_code_common.mli
+++ b/src/machine_code_common.mli
@@ -3,33 +3,19 @@ open Lustre_types
open Machine_code_types
val pp_val : machine_t -> Format.formatter -> value_t -> unit
-
val find_tainter_arrow : machine_t -> var_decl -> ident option option
-
val is_memory : machine_t -> var_decl -> bool
-
val is_reset_flag : var_decl -> bool
-
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_stateless_status_node : node_desc -> bool * bool
-
val get_stateless_status : machine_t -> bool * bool
-
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 vdecl_to_val : var_decl -> value_t
-
val vdecls_to_vals : var_decl list -> value_t list
-
val id_to_tag : ident -> value_t
val mk_conditional :
@@ -42,32 +28,20 @@ val mk_branch' :
?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 empty_machine : machine_t
-
val arrow_machine : machine_t
-
val new_instance : top_decl -> tag -> ident
-
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_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
(* Same function but fails if no such a machine exists *)
val get_machine : machine_t list -> string -> machine_t
-
val get_node_def : string -> machine_t -> node_desc
-
val join_guards_list : instr_t list -> instr_t list
-
val machine_vars : machine_t -> var_decl list
module PrintSpec : sig
diff --git a/src/machine_code_dep.ml b/src/machine_code_dep.ml
index b93760fb..5e14a0f8 100644
--- a/src/machine_code_dep.ml
+++ b/src/machine_code_dep.ml
@@ -3,42 +3,47 @@ open Machine_code_types
open Corelang
open Utils
-let rec add_expr_dependencies g x e = match e.value_desc with
+let rec add_expr_dependencies g x e =
+ match e.value_desc with
| Var y ->
let y' = y.var_id in
- if y' <> x then
- IdentDepGraph.add_edge g x y'
- | Fun (_, es)
- | Array es ->
+ if y' <> x then IdentDepGraph.add_edge g x y'
+ | Fun (_, es) | Array es ->
List.iter (add_expr_dependencies g x) es
- | Access (e1, e2)
- | Power (e1, e2) ->
+ | Access (e1, e2) | Power (e1, e2) ->
add_expr_dependencies g x e1;
add_expr_dependencies g x e2
- | _ -> ()
+ | _ ->
+ ()
-let rec add_instr_dependencies g deps instr = match get_instr_desc instr with
- | MLocalAssign (x, e)
- | MStateAssign (x, e) ->
+let rec add_instr_dependencies g deps instr =
+ match get_instr_desc instr with
+ | MLocalAssign (x, e) | MStateAssign (x, e) ->
add_expr_dependencies g x.var_id e;
List.iter (add_expr_dependencies g x.var_id) deps
| MStep (xs, i, es) ->
- List.iter (fun x ->
+ List.iter
+ (fun x ->
IdentDepGraph.add_edge g x.var_id i;
List.iter (add_expr_dependencies g x.var_id) es;
- List.iter (add_expr_dependencies g x.var_id) deps) xs;
+ List.iter (add_expr_dependencies g x.var_id) deps)
+ xs;
List.iter (add_expr_dependencies g i) deps
- | MSetReset i
- | MNoReset i ->
+ | MSetReset i | MNoReset i ->
List.iter (add_expr_dependencies g i) deps
| MBranch (e, hl) ->
- List.iter (fun (_, l) -> List.iter (add_instr_dependencies g (e :: deps)) l) hl
- | _ -> ()
+ List.iter
+ (fun (_, l) -> List.iter (add_instr_dependencies g (e :: deps)) l)
+ hl
+ | _ ->
+ ()
let dep_graph m =
let g = IdentDepGraph.create () in
List.iter (add_instr_dependencies g []) m.mstep.step_instrs;
- List.iter (fun x -> IdentDepGraph.add_edge g Causality.world x.var_id) m.mstep.step_outputs;
+ List.iter
+ (fun x -> IdentDepGraph.add_edge g Causality.world x.var_id)
+ m.mstep.step_outputs;
g
(* computes the cone of influence of a given [var] wrt a dependency graph
@@ -62,11 +67,16 @@ let cone_of_influence g var =
let compute_unused_variables m =
let g = dep_graph m in
- (* Format.printf "graph of %s: %a@." m.mname.node_id Causality.pp_dep_graph g; *)
+ (* Format.printf "graph of %s: %a@." m.mname.node_id Causality.pp_dep_graph
+ g; *)
List.fold_left
(fun unused x ->
- let coi = cone_of_influence g x.var_id in
- (* Format.printf "unused: %a@;coi of %s: %a@." ISet.pp unused x.var_id ISet.pp coi; *)
- ISet.diff unused coi)
- (List.fold_left (fun s v -> ISet.add v.var_id s) ISet.empty m.mstep.step_locals)
+ let coi = cone_of_influence g x.var_id in
+ (* Format.printf "unused: %a@;coi of %s: %a@." ISet.pp unused x.var_id
+ ISet.pp coi; *)
+ ISet.diff unused coi)
+ (List.fold_left
+ (fun s v -> ISet.add v.var_id s)
+ ISet.empty
+ m.mstep.step_locals)
(m.mstep.step_outputs @ List.map fst m.mmemory)
diff --git a/src/machine_code_types.mli b/src/machine_code_types.mli
index 4c4c8ed4..eff5d73d 100644
--- a/src/machine_code_types.mli
+++ b/src/machine_code_types.mli
@@ -27,7 +27,8 @@ type instr_t = {
*) *)
lustre_eq : eq option;
(* possible representation as a lustre flow equation *)
- instr_spec : (mc_formula_t * bool) list; (* spec, where the boolean specifies assert *)
+ instr_spec : (mc_formula_t * bool) list;
+ (* spec, where the boolean specifies assert *)
}
and instr_t_desc =
@@ -52,9 +53,7 @@ type step_t = {
}
type static_call = top_decl * Dimension.t list
-
type mc_transition_t = value_t transition_t
-
type mc_memory_pack_t = value_t memory_pack_t
type mc_contract_t = {
@@ -71,24 +70,23 @@ type machine_spec = {
}
type machine_t = {
- mname : node_desc;
- mmemory : (var_decl * ident option) list;
- (* in mmemory, a pair (v, Some arrow_instance_id) means that we
- have a memory (pre v) which is protected by at least an arrow
- *)
- mcalls : (ident * static_call) list;
- (* map from stateful/stateless instance to node, no internals *)
- minstances : (ident * static_call) list;
- (* sub-map of mcalls, from stateful instance to node *)
- minit : instr_t list;
- mstatic : var_decl list;
- (* static inputs only *)
- mconst : instr_t list;
- (* assignments of node constant locals *)
- mstep : step_t;
- mspec : machine_spec;
- mannot : expr_annot list;
- msch : Scheduling_type.schedule_report option;
- (* Equations scheduling *)
- mis_contract : bool;
- }
+ mname : node_desc;
+ mmemory : (var_decl * ident option) list;
+ (* in mmemory, a pair (v, Some arrow_instance_id) means that we have a memory
+ (pre v) which is protected by at least an arrow *)
+ mcalls : (ident * static_call) list;
+ (* map from stateful/stateless instance to node, no internals *)
+ minstances : (ident * static_call) list;
+ (* sub-map of mcalls, from stateful instance to node *)
+ minit : instr_t list;
+ mstatic : var_decl list;
+ (* static inputs only *)
+ mconst : instr_t list;
+ (* assignments of node constant locals *)
+ mstep : step_t;
+ mspec : machine_spec;
+ mannot : expr_annot list;
+ msch : Scheduling_type.schedule_report option;
+ (* Equations scheduling *)
+ mis_contract : bool;
+}
diff --git a/src/main_lustre_compiler.ml b/src/main_lustre_compiler.ml
index 0c6ce419..a89dfb9e 100644
--- a/src/main_lustre_compiler.ml
+++ b/src/main_lustre_compiler.ml
@@ -14,7 +14,6 @@ open Compiler_common
open Utils
let usage = "Usage: lustrec [options] \x1b[4msource file\x1b[0m"
-
let extensions = [ ".ec"; ".lus"; ".lusi" ]
(* print a .lusi header file from a source prog *)
diff --git a/src/main_lustre_testgen.ml b/src/main_lustre_testgen.ml
index 75c1af08..8f15747c 100644
--- a/src/main_lustre_testgen.ml
+++ b/src/main_lustre_testgen.ml
@@ -17,7 +17,6 @@ open Format
open Compiler_common
let usage = "Usage: lustret [options] \x1b[4msource file\x1b[0m"
-
let extensions = [ ".lus" ]
let pp_trace trace_filename mutation_list =
diff --git a/src/main_lustre_verifier.ml b/src/main_lustre_verifier.ml
index 8d490b56..0f940202 100644
--- a/src/main_lustre_verifier.ml
+++ b/src/main_lustre_verifier.ml
@@ -14,7 +14,6 @@ open Compiler_common
open Utils
let usage = "Usage: lustrev [options] \x1b[4msource file\x1b[0m"
-
let extensions = [ ".ec"; ".lus"; ".lusi" ]
(* verify a .lus source file
diff --git a/src/mutation.ml b/src/mutation.ml
index 651cfc1a..9e77b6c2 100644
--- a/src/mutation.ml
+++ b/src/mutation.ml
@@ -83,11 +83,8 @@ type records = {
}
let arith_op = [ "+"; "-"; "*"; "/" ]
-
let bool_op = [ "&&"; "||"; "xor"; "impl" ]
-
let rel_op = [ "<"; "<="; ">"; ">="; "!="; "=" ]
-
let ops = arith_op @ bool_op @ rel_op
(* XXX: UNUSED *)
@@ -420,13 +417,9 @@ type mutant_t =
type mutation_loc = ident * ident list * Location.t
let target : mutant_t option ref = ref None
-
let mutation_info : mutation_loc option ref = ref None
-
let current_node : ident option ref = ref None
-
let current_eq_lhs : ident list option ref = ref None
-
let current_loc : Location.t option ref = ref None
let set_mutation_loc () =
diff --git a/src/mutation.mli b/src/mutation.mli
index 09dcb289..2cc41494 100644
--- a/src/mutation.mli
+++ b/src/mutation.mli
@@ -11,9 +11,7 @@ type mutant_t =
| SwitchIntCst of int * int
val pp_directive_json : formatter -> mutant_t -> unit
-
val pp_directive : formatter -> mutant_t -> unit
-
val pp_loc_json : formatter -> ident * ident list * Location.t -> unit
val mutate :
diff --git a/src/optimize_machine.ml b/src/optimize_machine.ml
index 9171eb51..e00aea1f 100644
--- a/src/optimize_machine.ml
+++ b/src/optimize_machine.ml
@@ -28,8 +28,7 @@ let rec fixpoint f x =
if c then fixpoint f y else y
let eliminate_var_decl elim m v a =
- if is_memory m v then a
- else try IMap.find v.var_id elim with Not_found -> a
+ if is_memory m v then a else try IMap.find v.var_id elim with Not_found -> a
let rec eliminate_val m elim expr =
let eliminate_val = eliminate_val m in
@@ -62,10 +61,10 @@ let rec value_eq v1 v2 =
f1 = f2 && values_eq vs1 vs2
| Array vs1, Array vs2 ->
values_eq vs1 vs2
- | Access (v1, v2), Access (w1, w2)
- | Power (v1, v2), Power (w1, w2) ->
+ | Access (v1, v2), Access (w1, w2) | Power (v1, v2), Power (w1, w2) ->
value_eq v1 w1 && value_eq v2 w2
- | v1, v2 -> v1 = v2
+ | v1, v2 ->
+ v1 = v2
let eliminate_val m elim expr =
let f expr =
@@ -142,6 +141,7 @@ let rec eliminate_formula m elim =
Value (eliminate_val m elim v)
| f ->
f
+
let eliminate_spec m elim =
List.map (fun (f, asrt) -> eliminate_formula m elim f, asrt)
@@ -216,8 +216,13 @@ let rec fv_formula m s = function
s
let eliminate_transition m elim t =
- (* let tvars = List.filter (fun vd -> not (IMap.mem vd.var_id elim)) t.tvars in *)
- let elim = IMap.filter (fun x _ -> not (List.exists (fun v -> v.var_id = x) t.tvars)) elim in
+ (* let tvars = List.filter (fun vd -> not (IMap.mem vd.var_id elim)) t.tvars
+ in *)
+ let elim =
+ IMap.filter
+ (fun x _ -> not (List.exists (fun v -> v.var_id = x) t.tvars))
+ elim
+ in
let tformula = eliminate_formula m elim t.tformula in
(* let fv = *)
(* VSet.(elements (diff (fv_formula m empty tformula) (of_list tvars))) *)
@@ -225,7 +230,6 @@ let eliminate_transition m elim t =
(* let tformula = Exists (fv, tformula) in *)
{ t with tformula }
-
(* XXX: UNUSED *)
(* let eliminate_dim elim dim =
* Dimension.expr_replace_expr
@@ -405,7 +409,6 @@ let merge_elim elim1 elim2 =
in
IMap.merge merge elim1 elim2
-
let get_exprs elim = IMap.map (fun (_, e, _) -> e) elim
(* see if elim has to take in account the provided instr: if so, update elim and
@@ -442,11 +445,20 @@ let instrs_unfold m fanin elim instrs =
| _ ->
elim, instr :: instrs
in
- let elim, instrs = List.fold_left gather_elim (IMap.map (fun x -> x, true) elim, []) instrs in
+ let elim, instrs =
+ List.fold_left gather_elim (IMap.map (fun x -> x, true) elim, []) instrs
+ in
(* we don't eliminate clock definitions *)
- let elim = IMap.filter_map (fun _ ((v, e, _ as x), k) ->
- if not (is_clock_dec_type v.var_dec_type.ty_dec_desc)
- && unfoldable_assign fanin v e && k then Some x else None) elim
+ let elim =
+ IMap.filter_map
+ (fun _ (((v, e, _) as x), k) ->
+ if
+ (not (is_clock_dec_type v.var_dec_type.ty_dec_desc))
+ && unfoldable_assign fanin v e
+ && k
+ then Some x
+ else None)
+ elim
in
let elim_exprs = get_exprs elim in
let rec filter instrs =
@@ -456,13 +468,13 @@ let instrs_unfold m fanin elim instrs =
| MLocalAssign (v, e)
when (* not (is_clock_dec_type v.var_dec_type.ty_dec_desc) *)
(* && unfoldable_assign fanin v expr *)
- (* && *) IMap.mem v.var_id elim ->
- (* we transform the assignment into a comment in order to keep its spec *)
+ (* && *)
+ IMap.mem v.var_id elim ->
+ (* we transform the assignment into a comment in order to keep its
+ spec *)
Format.(fprintf str_formatter "%s := %a" v.var_id (pp_val m) e);
let instr = eliminate_spec_instr m elim_exprs instr in
- update_instr_desc
- instr
- (MComment (Format.flush_str_formatter ()))
+ update_instr_desc instr (MComment (Format.flush_str_formatter ()))
| MBranch (g, hl) ->
let instr =
update_instr_desc
@@ -823,44 +835,50 @@ let is_reused_reassigned m fvar asg v =
&& List.exists (fun v' -> fvar v' = v && v <> v') m.mstep.step_locals
&& IMap.mem v.var_id r_asg
-let ghost_vd v =
- { v with var_id = "__" ^ v.var_id }
+let ghost_vd v = { v with var_id = "__" ^ v.var_id }
let rec instr_spec_replace m fvar asg t =
let aux instr = instr_spec_replace m fvar asg instr in
- (* rename reused vars that appears freely in the formula before substitution, *)
- (* to handle the fact that those vars can be modified in a way that the formula does not hold anymore *)
- let fv_m = VSet.fold (fun v fv_m ->
- if is_reused_reassigned m fvar asg v
- then IMap.add v.var_id (ghost_vd v) fv_m
- else fv_m) (fv_formula m VSet.empty t) IMap.empty
+ (* rename reused vars that appears freely in the formula before
+ substitution, *)
+ (* to handle the fact that those vars can be modified in a way that the
+ formula does not hold anymore *)
+ let fv_m =
+ VSet.fold
+ (fun v fv_m ->
+ if is_reused_reassigned m fvar asg v then
+ IMap.add v.var_id (ghost_vd v) fv_m
+ else fv_m)
+ (fv_formula m VSet.empty t)
+ IMap.empty
in
let fvar v = try IMap.find v.var_id fv_m with Not_found -> fvar v in
- let t' = match t with
- | Equal (e1, e2) ->
- Equal (expr_spec_replace fvar e1, expr_spec_replace fvar e2)
- | GEqual (e1, e2) ->
- GEqual (expr_spec_replace fvar e1, expr_spec_replace fvar e2)
- | And f ->
- And (List.map aux f)
- | Or f ->
- Or (List.map aux f)
- | Imply (a, b) ->
- Imply (aux a, aux b)
- | Exists (xs, a) ->
- let fvar v = if List.mem v xs then v else fvar v in
- Exists (xs, instr_spec_replace m fvar asg a)
- | Forall (xs, a) ->
- let fvar v = if List.mem v xs then v else fvar v in
- Forall (xs, instr_spec_replace m fvar asg a)
- | Ternary (e, a, b) ->
- Ternary (expr_spec_replace fvar e, aux a, aux b)
- | Predicate p ->
- Predicate (predicate_spec_replace fvar p)
- | ExistsMem (f, a, b) ->
- ExistsMem (f, aux a, aux b)
- | f ->
- f
+ let t' =
+ match t with
+ | Equal (e1, e2) ->
+ Equal (expr_spec_replace fvar e1, expr_spec_replace fvar e2)
+ | GEqual (e1, e2) ->
+ GEqual (expr_spec_replace fvar e1, expr_spec_replace fvar e2)
+ | And f ->
+ And (List.map aux f)
+ | Or f ->
+ Or (List.map aux f)
+ | Imply (a, b) ->
+ Imply (aux a, aux b)
+ | Exists (xs, a) ->
+ let fvar v = if List.mem v xs then v else fvar v in
+ Exists (xs, instr_spec_replace m fvar asg a)
+ | Forall (xs, a) ->
+ let fvar v = if List.mem v xs then v else fvar v in
+ Forall (xs, instr_spec_replace m fvar asg a)
+ | Ternary (e, a, b) ->
+ Ternary (expr_spec_replace fvar e, aux a, aux b)
+ | Predicate p ->
+ Predicate (predicate_spec_replace fvar p)
+ | ExistsMem (f, a, b) ->
+ ExistsMem (f, aux a, aux b)
+ | f ->
+ f
in
(* let fv_t = VSet.of_list (IMap.bindings fv_m |> List.split |> snd) in *)
(* let fv = VSet.(elements (inter fv_t (fv_formula m empty t'))) in *)
@@ -868,13 +886,10 @@ let rec instr_spec_replace m fvar asg t =
t'
let add_assigned v =
- IMap.update v.var_id (function
- | Some n -> Some (n + 1)
- | None -> Some 1)
+ IMap.update v.var_id (function Some n -> Some (n + 1) | None -> Some 1)
-let silly_asg i v = match v.value_desc with
- | Var w -> w.var_id = i.var_id
- | _ -> false
+let silly_asg i v =
+ match v.value_desc with Var w -> w.var_id = i.var_id | _ -> false
let rec instr_replace_var m fvar (asg, instrs) instr =
let asg, instr_desc =
@@ -882,24 +897,27 @@ let rec instr_replace_var m fvar (asg, instrs) instr =
| MLocalAssign (i, v) ->
let v = value_replace_var fvar v in
let i = fvar i in
- (if silly_asg i v then asg else add_assigned i asg),
- MLocalAssign (i, v)
+ (if silly_asg i v then asg else add_assigned i asg), MLocalAssign (i, v)
| MStateAssign (i, v) ->
asg, MStateAssign (i, value_replace_var fvar v)
| MStep (il, i, vl) ->
let il = List.map fvar il in
- List.fold_right add_assigned il asg,
- MStep (il, i, List.map (value_replace_var fvar) vl)
+ ( List.fold_right add_assigned il asg,
+ MStep (il, i, List.map (value_replace_var fvar) vl) )
| MBranch (g, hl) ->
let asg, hl =
- List.fold_left (fun (asg', hl) (h, il) ->
+ List.fold_left
+ (fun (asg', hl) (h, il) ->
let asg'', il = instrs_replace_var m fvar asg il in
- (* Format.(printf "%s: before %a after %a@." h (IMap.pp pp_print_int) asg (IMap.pp pp_print_int) asg''); *)
- IMap.union (fun _ n1 n2 -> Some (max n1 n2)) asg' asg'', (h, il) :: hl)
- (IMap.empty, []) hl
+ (* Format.(printf "%s: before %a after %a@." h (IMap.pp
+ pp_print_int) asg (IMap.pp pp_print_int) asg''); *)
+ ( IMap.union (fun _ n1 n2 -> Some (max n1 n2)) asg' asg'',
+ (h, il) :: hl ))
+ (IMap.empty, [])
+ hl
in
(* Format.(printf "%a@." (IMap.pp pp_print_int) asg); *)
- asg, MBranch ( value_replace_var fvar g, List.rev hl)
+ asg, MBranch (value_replace_var fvar g, List.rev hl)
| MSetReset _
| MNoReset _
| MClearReset
@@ -908,37 +926,59 @@ let rec instr_replace_var m fvar (asg, instrs) instr =
| MComment _ ->
asg, instr.instr_desc
in
- let instr_spec = List.map (fun (f, asrt) -> instr_spec_replace m fvar asg f, asrt) instr.instr_spec in
+ let instr_spec =
+ List.map
+ (fun (f, asrt) -> instr_spec_replace m fvar asg f, asrt)
+ instr.instr_spec
+ in
asg, instr_cons { instr with instr_desc; instr_spec } instrs
and instrs_replace_var m fvar asg instrs =
- let asg, instrs = List.fold_left (instr_replace_var m fvar) (asg, []) instrs in
+ let asg, instrs =
+ List.fold_left (instr_replace_var m fvar) (asg, []) instrs
+ in
asg, List.rev instrs
let add_ghost_assign (firsts, spec) v =
- ISet.add v.var_id firsts, (Predicate (GhostAssign (ghost_vd v, v)), false) :: spec
+ ( ISet.add v.var_id firsts,
+ (Predicate (GhostAssign (ghost_vd v, v)), false) :: spec )
let add_ghost_assigns m fvar asg instrs =
let rec aux (firsts, instrs) instr =
- let firsts, instr = match instr.instr_desc with
+ let firsts, instr =
+ match instr.instr_desc with
| MLocalAssign (i, _)
- when is_reused_reassigned m fvar asg i && not (ISet.mem i.var_id firsts) ->
- let firsts, instr_spec = add_ghost_assign (firsts, instr.instr_spec) i in
+ when is_reused_reassigned m fvar asg i && not (ISet.mem i.var_id firsts)
+ ->
+ let firsts, instr_spec =
+ add_ghost_assign (firsts, instr.instr_spec) i
+ in
firsts, { instr with instr_spec }
| MStep (il, _, _) ->
- let firsts, instr_spec = List.fold_left (fun (firsts, _ as acc) i ->
- if is_reused_reassigned m fvar asg i && not (ISet.mem i.var_id firsts)
- then add_ghost_assign acc i else acc) (firsts, instr.instr_spec) il
+ let firsts, instr_spec =
+ List.fold_left
+ (fun ((firsts, _) as acc) i ->
+ if
+ is_reused_reassigned m fvar asg i
+ && not (ISet.mem i.var_id firsts)
+ then add_ghost_assign acc i
+ else acc)
+ (firsts, instr.instr_spec)
+ il
in
firsts, { instr with instr_spec }
| MBranch (g, hl) ->
- let firsts, hl = List.fold_left (fun (firsts', hl) (h, il) ->
- let firsts, il = aux' firsts il in
- ISet.union firsts firsts', ((h, il) :: hl))
- (ISet.empty, []) hl
+ let firsts, hl =
+ List.fold_left
+ (fun (firsts', hl) (h, il) ->
+ let firsts, il = aux' firsts il in
+ ISet.union firsts firsts', (h, il) :: hl)
+ (ISet.empty, [])
+ hl
in
firsts, { instr with instr_desc = MBranch (g, List.rev hl) }
- | _ -> firsts, instr
+ | _ ->
+ firsts, instr
in
firsts, instr :: instrs
and aux' firsts instrs =
@@ -952,7 +992,8 @@ let step_replace_var m fvar step =
List.fold_left
(fun res l ->
let l' = fvar l in
- if List.exists (fun o -> o.var_id = l'.var_id) step.step_outputs then res
+ if List.exists (fun o -> o.var_id = l'.var_id) step.step_outputs then
+ res
else Utils.add_cons l' res)
[]
step.step_locals
@@ -960,38 +1001,40 @@ let step_replace_var m fvar step =
let step_checks =
List.map (fun (l, v) -> l, value_replace_var fvar v) step.step_checks
in
- let asg, step_instrs = instrs_replace_var m fvar IMap.empty step.step_instrs in
+ let asg, step_instrs =
+ instrs_replace_var m fvar IMap.empty step.step_instrs
+ in
let step_instrs = add_ghost_assigns m fvar asg step_instrs in
- {
- step with
- step_checks;
- step_locals;
- step_instrs
- }
+ { step with step_checks; step_locals; step_instrs }
let machine_replace_variables fvar m =
{ m with mstep = step_replace_var m fvar m.mstep }
let pp_reuse fmt reuse =
Format.fprintf fmt "{ @[<hv>";
- Hashtbl.iter (fun v1 v2 -> Format.fprintf fmt "%s --> %s@ " v1 v2.var_id) reuse;
+ Hashtbl.iter
+ (fun v1 v2 -> Format.fprintf fmt "%s --> %s@ " v1 v2.var_id)
+ reuse;
Format.fprintf fmt "@]@;}"
let machine_reuse_variables reuse m =
(* Some outputs may have been replaced by locals. We reverse such bindings. *)
- List.iter (fun out ->
+ List.iter
+ (fun out ->
try
let x = out.var_id in
let v = Hashtbl.find reuse x in
Hashtbl.remove reuse x;
Hashtbl.add reuse v.var_id out
- with Not_found -> ()) m.mstep.step_outputs;
+ with Not_found -> ())
+ m.mstep.step_outputs;
Log.report ~level:1 (fun fmt ->
Format.fprintf
fmt
"@[<v 2>.. machine %s reuse table:@,%a@]@,"
m.mname.node_id
- pp_reuse reuse);
+ pp_reuse
+ reuse);
let fvar v = try Hashtbl.find reuse v.var_id with Not_found -> v in
let fvar v =
let f v =
@@ -1007,20 +1050,24 @@ let machines_reuse_variables reuse_tables prog =
Log.report ~level:1 (fun fmt ->
Format.fprintf
fmt
- "@,@[<v 2>.. machines optimization: minimize stack usage by reusing \
+ "@,\
+ @[<v 2>.. machines optimization: minimize stack usage by reusing \
variables@,");
- let prog = List.map (fun m ->
- machine_reuse_variables (IMap.find m.mname.node_id reuse_tables) m)
+ let prog =
+ List.map
+ (fun m ->
+ machine_reuse_variables (IMap.find m.mname.node_id reuse_tables) m)
prog
in
Log.report ~level:3 (fun fmt ->
- if IMap.exists (fun _ reuse -> Hashtbl.length reuse <> 0) reuse_tables then
+ if IMap.exists (fun _ reuse -> Hashtbl.length reuse <> 0) reuse_tables
+ then
Format.fprintf
fmt
"@[<v 2>.. generated machines (variable reuse):@ %a@]@ "
pp_machines
prog
- else pp_no_effect fmt);
+ else pp_no_effect fmt);
Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@]@,");
prog
@@ -1084,17 +1131,17 @@ let rec instrs_fusion instrs =
match instrs with
| [] | [ _ ] ->
false, instrs
- | i1 :: i2 :: q ->
- begin match i2.instr_desc with
- | MBranch ({ value_desc = Var v; _ }, hl) when instr_constant_assign v i1 ->
- true, instr_reduce
+ | i1 :: i2 :: q -> (
+ match i2.instr_desc with
+ | MBranch ({ value_desc = Var v; _ }, hl) when instr_constant_assign v i1 ->
+ ( true,
+ instr_reduce
(List.map (fun (h, b) -> h, snd (instrs_fusion b)) hl)
{ i1 with instr_spec = i1.instr_spec @ i2.instr_spec }
- (snd (instrs_fusion q))
- | _ ->
- let b, instrs = instrs_fusion (i2 :: q) in
- b, i1 :: instrs
- end
+ (snd (instrs_fusion q)) )
+ | _ ->
+ let b, instrs = instrs_fusion (i2 :: q) in
+ b, i1 :: instrs)
let step_fusion step =
let b, step_instrs = instrs_fusion step.step_instrs in
@@ -1128,27 +1175,42 @@ let machine_clean m =
fmt
"@[<v 2>.. machine %s unused variables:@,%a@]@,"
m.mname.node_id
- ISet.pp unused);
+ ISet.pp
+ unused);
let is_unused v = ISet.mem v.var_id unused in
let is_used v = not (ISet.mem v.var_id unused) in
let step_locals = List.filter is_used m.mstep.step_locals in
let rec filter_instrs instrs =
- List.filter_map (fun instr ->
- let instr = { instr with
- instr_spec = List.map (fun (t, asrt) ->
- let fv = VSet.(elements (filter is_unused (fv_formula m empty t))) in
- Exists (fv, t), asrt) instr.instr_spec }
+ List.filter_map
+ (fun instr ->
+ let instr =
+ {
+ instr with
+ instr_spec =
+ List.map
+ (fun (t, asrt) ->
+ let fv =
+ VSet.(elements (filter is_unused (fv_formula m empty t)))
+ in
+ Exists (fv, t), asrt)
+ instr.instr_spec;
+ }
in
match get_instr_desc instr with
| MLocalAssign (v, _) ->
if is_used v then Some instr else None
| MBranch (e, hl) ->
- Some (update_instr_desc instr
- (MBranch (e, List.map (fun (h, l) -> h, filter_instrs l) hl)))
- | _ -> Some instr) instrs
+ Some
+ (update_instr_desc
+ instr
+ (MBranch (e, List.map (fun (h, l) -> h, filter_instrs l) hl)))
+ | _ ->
+ Some instr)
+ instrs
in
let step_instrs = filter_instrs m.mstep.step_instrs in
- not (ISet.is_empty unused), { m with mstep = { m.mstep with step_locals; step_instrs }}
+ ( not (ISet.is_empty unused),
+ { m with mstep = { m.mstep with step_locals; step_instrs } } )
let machines_clean prog =
Log.report ~level:1 (fun fmt ->
@@ -1185,7 +1247,9 @@ let elim_prog_variables prog removed_table =
(fun v (_, eq) (accu_locals, accu_defs) ->
let locals =
try
- List.find (fun v' -> v'.var_id = v) (List.map fst nd.node_locals)
+ List.find
+ (fun v' -> v'.var_id = v)
+ (List.map fst nd.node_locals)
:: accu_locals
with Not_found -> accu_locals
(* Variable v shall be a global constant, we do no need to
@@ -1212,7 +1276,8 @@ let elim_prog_variables prog removed_table =
when List.exists (fun v -> v.var_id = lhs) vars_to_replace
->
(* We remove the def *)
- List.filter (fun (v, _) -> v.var_id <> lhs) locals, res_stmts
+ ( List.filter (fun (v, _) -> v.var_id <> lhs) locals,
+ res_stmts )
| _ ->
(* When more than one lhs we just keep the equation and do
not delete it *)
@@ -1322,8 +1387,7 @@ let optimize params prog node_schs machine_code =
let reuse_tables = Scheduling.compute_prog_reuse_table node_schs in
machine_code
|> machines_reuse_variables reuse_tables
- |> machines_fusion
- |> machines_clean
+ |> machines_fusion |> machines_clean
else machine_code
in
diff --git a/src/options.ml b/src/options.ml
index 82fcd958..e2925dc5 100644
--- a/src/options.ml
+++ b/src/options.ml
@@ -10,21 +10,13 @@
(********************************************************************)
let include_dirs = ref [ "." ]
-
let main_node = ref ""
-
let static_mem = ref true
-
let print_types = ref false
-
let print_clocks = ref false
-
let delay_calculus = ref true
-
let track_exceptions = ref true
-
let ansi = ref false
-
let check = ref false
type option_spec = SpecNo | SpecACSL | SpecC
@@ -53,63 +45,39 @@ let pp_output fmt =
"Lustre")
let dest_dir = ref "."
-
let verbose_level = ref 1
-
let global_inline = ref false
-
let witnesses = ref false
-
let optimization = ref 2
-
let lusi = ref false
-
let print_nodes = ref false
-
let print_reuse = ref false
-
let const_unfold = ref false
-
let mpfr = ref false
-
let mpfr_prec = ref 100
-
let print_dec_types = ref false
-
let compile_header = ref true
(* Option to select the expected behavior of integer division: Euclidian or C.
Default C !!! *)
let integer_div_euclidean = ref false
-
let traces = ref false
-
let horn_cex = ref false
-
let horn_query = ref true
-
let cpp = ref false
-
let int_type = ref "int"
-
let real_type = ref "double"
-
let print_prec_double = ref 15
-
let sfunction = ref ""
-
let mauve = ref ""
(* test generation options *)
let nb_mutants = ref 1000
-
let gen_mcdc = ref false
-
let no_mutation_suffix = ref false
(* Algebraic loops unrolling *)
let solve_al = ref false
-
let al_nb_max = ref 15
(* Printer options *)
diff --git a/src/options.mli b/src/options.mli
index 04c91085..4acde136 100644
--- a/src/options.mli
+++ b/src/options.mli
@@ -1,15 +1,9 @@
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
type option_spec = SpecNo | SpecACSL | SpecC
@@ -20,71 +14,37 @@ type option_output = OutC | OutAda | OutJava | OutEMF | OutHorn | OutLustre
(* | OutACSL *)
val output : option_output ref
-
val pp_output : Format.formatter -> unit
-
val ansi : bool ref
-
val int_type : string ref
-
val real_type : string ref
-
val optimization : int ref
-
val include_dirs : string list ref
-
val dest_dir : string ref
-
val print_types : bool ref
-
val print_clocks : bool ref
-
val print_nodes : bool ref
-
val print_prec_double : int ref
-
val solve_al : bool ref
-
val al_nb_max : int ref
-
val delay_calculus : bool ref
-
val static_mem : bool ref
-
val check : bool ref
-
val lusi : bool ref
-
val traces : bool ref
-
val horn_cex : 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
-
val c_main_options : bool ref
-
val compile_contracts : bool ref
diff --git a/src/options_management.ml b/src/options_management.ml
index ebfa7ce7..c7f00109 100644
--- a/src/options_management.ml
+++ b/src/options_management.ml
@@ -87,7 +87,6 @@ let set_real_type s =
real_type := s
let setup () = Backends.setup ()
-
let set_backend s = output := s
let common_options =
diff --git a/src/options_management.mli b/src/options_management.mli
index 6aa7d50c..5ede5cb1 100644
--- a/src/options_management.mli
+++ b/src/options_management.mli
@@ -7,15 +7,9 @@ val plugin_opt :
options_spec
val name_dependency : 'a * string -> string -> string
-
val get_witness_dir : string -> string
-
val verifier_opt : string * (unit -> unit) * options_spec -> options_spec
-
val lustrec_options : options_spec
-
val lustrev_options : options_spec
-
val lustret_options : options_spec
-
val setup : unit -> unit
diff --git a/src/pathConditions.ml b/src/pathConditions.ml
index 9720da97..12cff24e 100644
--- a/src/pathConditions.ml
+++ b/src/pathConditions.ml
@@ -370,7 +370,8 @@ let mcdc_top_decl td =
Node
{
nd with
- node_locals = nd.node_locals @ List.map (fun v -> v, None) fresh_vars;
+ node_locals =
+ nd.node_locals @ List.map (fun v -> v, None) fresh_vars;
node_stmts = nd.node_stmts @ fresh_eqs;
node_annot = nd.node_annot @ fresh_annots;
};
diff --git a/src/plugins/mpfr/lustrec_mpfr.ml b/src/plugins/mpfr/lustrec_mpfr.ml
index ccb2c6d0..e93f7fe2 100644
--- a/src/plugins/mpfr/lustrec_mpfr.ml
+++ b/src/plugins/mpfr/lustrec_mpfr.ml
@@ -17,26 +17,18 @@ open Normalization
open Machine_code_common
let report = Log.report ~plugin:"MPFR"
-
let mpfr_module = mktop (Open (false, "mpfr_lustre"))
-
let cpt_fresh = ref 0
-
let mpfr_rnd () = "MPFR_RNDN"
-
let mpfr_prec () = !Options.mpfr_prec
(* XXX: UNUSED *)
(* let inject_id = "MPFRId" *)
let inject_copy_id = "mpfr_set"
-
let inject_real_id = "mpfr_set_flt"
-
let inject_init_id = "mpfr_init2"
-
let inject_clear_id = "mpfr_clear"
-
let mpfr_t = "mpfr_t"
let unfoldable_value value =
@@ -359,7 +351,9 @@ let inject_node node =
(vars, [], [])
node.node_asserts
in
- let new_locals = List.filter_map (fun v -> if is_local v then Some (v, None) else None) vars in
+ let new_locals =
+ List.filter_map (fun v -> if is_local v then Some (v, None) else None) vars
+ in
(* Compute traceability info: - gather newly bound variables - compute the
associated expression without aliases *)
(* let diff_vars = List.filter (fun v -> not (List.mem v node.node_locals))
diff --git a/src/plugins/mpfr/lustrec_mpfr.mli b/src/plugins/mpfr/lustrec_mpfr.mli
index dea715c1..c3179ecc 100644
--- a/src/plugins/mpfr/lustrec_mpfr.mli
+++ b/src/plugins/mpfr/lustrec_mpfr.mli
@@ -4,21 +4,13 @@ open Lustre_types
open Machine_code_types
val unfoldable_value : Machine_code_types.value_t -> bool
-
val inject_prog : program_t -> program_t
-
val mpfr_module : top_decl
-
val mpfr_t : string
-
val mpfr_rnd : unit -> string
-
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 :
diff --git a/src/plugins/pluginList.ml b/src/plugins/pluginList.ml
index 06d8de15..179a5e77 100644
--- a/src/plugins/pluginList.ml
+++ b/src/plugins/pluginList.ml
@@ -1,3 +1,2 @@
let registered = ref []
-
let plugins () = !registered
diff --git a/src/plugins/pluginList.mli b/src/plugins/pluginList.mli
index 5be008f2..de6d96f3 100644
--- a/src/plugins/pluginList.mli
+++ b/src/plugins/pluginList.mli
@@ -1,3 +1,2 @@
val registered : (module PluginType.S) list ref
-
val plugins : unit -> (module PluginType.S) list
diff --git a/src/plugins/pluginType.ml b/src/plugins/pluginType.ml
index e58bc92f..c9a083ec 100644
--- a/src/plugins/pluginType.ml
+++ b/src/plugins/pluginType.ml
@@ -1,14 +1,9 @@
module type S = sig
val name : string
-
val activate : unit -> unit
-
val usage : Format.formatter -> unit
-
val options : Options_management.options_spec
-
val init : unit -> unit
-
val check_force_stateful : unit -> bool
val refine_machine_code :
@@ -24,20 +19,12 @@ end
module Default = struct
let name = "default"
-
let activate () = ()
-
let usage fmt = Format.fprintf fmt "No specific help."
-
let options = []
-
let init () = ()
-
let check_force_stateful () = false
-
let refine_machine_code _prog machines = machines
-
let c_backend_main_loop_body_prefix _basename _mname _fmt () = ()
-
let c_backend_main_loop_body_suffix _fmt () = ()
end
diff --git a/src/plugins/pluginType.mli b/src/plugins/pluginType.mli
index f127f7b6..8ec31572 100644
--- a/src/plugins/pluginType.mli
+++ b/src/plugins/pluginType.mli
@@ -1,14 +1,9 @@
module type S = sig
val name : string
-
val activate : unit -> unit
-
val usage : Format.formatter -> unit
-
val options : Options_management.options_spec
-
val init : unit -> unit
-
val check_force_stateful : unit -> bool
val refine_machine_code :
diff --git a/src/plugins/plugins.mli b/src/plugins/plugins.mli
index 17dad3f6..9a875d08 100644
--- a/src/plugins/plugins.mli
+++ b/src/plugins/plugins.mli
@@ -3,16 +3,12 @@ open Lustre_types
open Machine_code_types
val inline_annots : (ident -> ident) -> expr_annot list -> expr_annot list
-
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 refine_machine_code : program_t -> machine_t list -> machine_t list
-
val init : unit -> unit
-
val options : unit -> Options_management.options_spec
diff --git a/src/plugins/salsa/salsaDatatypes.ml b/src/plugins/salsa/salsaDatatypes.ml
index 887b570e..624e47ab 100644
--- a/src/plugins/salsa/salsaDatatypes.ml
+++ b/src/plugins/salsa/salsaDatatypes.ml
@@ -4,7 +4,6 @@ module MC = Machine_code_common
module ST = Salsa.Types
let debug = ref false
-
let _ = Salsa.Prelude.sliceSize := 5
let pp_hash ~sep f fmt r =
@@ -16,9 +15,7 @@ module type VALUE = sig
type t
val union : t -> t -> t
-
val pp : Format.formatter -> t -> unit
-
val leq : t -> t -> bool
end
@@ -30,7 +27,6 @@ functor
module Value = Value
type t = Value.t
-
type r_t = (LT.ident, Value.t) Hashtbl.t
let empty : r_t = Hashtbl.create 13
diff --git a/src/plugins/scopes/scopes.ml b/src/plugins/scopes/scopes.ml
index be6743f8..3c8785a6 100644
--- a/src/plugins/scopes/scopes.ml
+++ b/src/plugins/scopes/scopes.ml
@@ -21,9 +21,7 @@ let rec compute_scopes ?(first = true) prog root_node : scope_t list =
let node = get_node root_node prog in
let locals = List.map fst node.node_locals in
let all_vars = node.node_inputs @ locals @ node.node_outputs in
- let local_vars =
- if first then locals else node.node_inputs @ locals
- in
+ let local_vars = if first then locals else node.node_inputs @ locals in
let local_scopes = List.map (fun x -> [], x) local_vars in
let sub_scopes =
let sub_nodes =
@@ -314,13 +312,9 @@ let rec is_valid_path path nodename prog machines =
(****************************************************)
let scopes_def : string list list ref = ref []
-
let inputs = ref []
-
let option_show_scopes = ref false
-
let option_scopes = ref false
-
let option_all_scopes = ref false
(* let option_mems_scopes = ref false
* let option_input_scopes = ref false *)
@@ -412,7 +406,6 @@ end = struct
include PluginType.Default
let name = "scopes"
-
let is_active () = !option_scopes || !option_show_scopes || !option_all_scopes
(* || !option_mem_scopes || !option_input_scopes *)
@@ -441,13 +434,12 @@ end = struct
"list possible variables to log" );
( "-select-all",
Arg.Unit register_all_scopes,
- "select all possible variables to log" );
+ "select all possible variables to log" )
(* "-select-mems", Arg.Set option_mems_scopes, "select all memory variables to log";
- * "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; *)
+ * "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; *);
]
let activate = activate
-
let check_force_stateful () = is_active ()
let refine_machine_code prog machine_code =
diff --git a/src/plugins/scopes/scopes.mli b/src/plugins/scopes/scopes.mli
index 4fac288a..b6281510 100644
--- a/src/plugins/scopes/scopes.mli
+++ b/src/plugins/scopes/scopes.mli
@@ -11,5 +11,4 @@ end
type scope_t = (var_decl * string * string option) list * var_decl
val compute_scopes : ?first:bool -> program_t -> ident -> scope_t list
-
val pp_scopes : Format.formatter -> scope_t list -> unit
diff --git a/src/printers.ml b/src/printers.ml
index 73ba93b3..52e6ddd5 100644
--- a/src/printers.ml
+++ b/src/printers.ml
@@ -70,7 +70,6 @@ let pp_var_type fmt id =
else Types.pp_node_ty fmt id.var_type
let pp_var_clock fmt id = Clocks.pp_suffix fmt id.var_clock
-
let pp_eq_lhs = pp_comma_list pp_print_string
let pp_var fmt id =
@@ -196,7 +195,6 @@ 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
-
and pp_handlers fmt hl = pp_print_list pp_handler fmt hl
and pp_app fmt id e r =
@@ -743,7 +741,6 @@ let pp_short_decl fmt decl =
fprintf fmt "type %s" tdef.tydef_id
let pp_prog_short = pp_prog pp_short_decl
-
let pp_prog = pp_prog pp_decl
let pp_lusi fmt decl =
diff --git a/src/printers.mli b/src/printers.mli
index 5df6ee53..b6a9f8bc 100644
--- a/src/printers.mli
+++ b/src/printers.mli
@@ -2,45 +2,24 @@ 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_var_type: formatter -> var_decl -> unit
-
+val pp_var_type : 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/real.ml b/src/real.ml
index 653ea621..c63465ec 100644
--- a/src/real.ml
+++ b/src/real.ml
@@ -9,9 +9,7 @@ let pp fmt (_, _, s) =
(if String.get s (-1 + String.length s) = '.' then "0" else "")
let pp_ada fmt (c, e, _) = Format.fprintf fmt "%s.0*1.0e-%i" (Q.to_string c) e
-
let create m e s = Q.of_string m, e, s
-
let create_q q s = q, 0, s
(* let to_num (c, e, s) = let num_10 = Num.num_of_int 10 in Num.(c // (num_10
@@ -24,7 +22,6 @@ let rec to_q (c, e, s) =
Q.mul (to_q (c, e + 1, s)) (Q.of_int 10)
let to_num = to_q
-
let to_string (_, _, s) = s
(* let eq r1 r2 =
@@ -39,29 +36,16 @@ let arith_binop op r1 r2 =
create_q r (Q.to_string r)
let add = arith_binop Q.add
-
let minus = arith_binop Q.sub
-
let times = arith_binop Q.mul
-
let div = arith_binop Q.div
-
let uminus (c, e, s) = Q.neg c, e, "-" ^ s
-
let lt = num_binop Q.( < )
-
let le = num_binop Q.( <= )
-
let gt = num_binop Q.( > )
-
let ge = num_binop Q.( >= )
-
let diseq = num_binop Q.( <> )
-
let eq = num_binop Q.( = )
-
let zero = Q.zero, 0, "0.0"
-
let is_zero r = Q.equal (to_num r) Q.zero
-
let is_one r = Q.equal (to_num r) Q.one
diff --git a/src/real.mli b/src/real.mli
index 62a88c8e..87ee5099 100644
--- a/src/real.mli
+++ b/src/real.mli
@@ -1,44 +1,28 @@
type t
val pp : Format.formatter -> t -> unit
-
val pp_ada : Format.formatter -> t -> unit
-
val create : string -> int -> string -> t
(*val create_num: Num.num -> string -> t*)
val create_q : Q.t -> string -> t
-
val add : t -> t -> t
-
val minus : t -> t -> t
-
val times : t -> t -> t
-
val div : t -> t -> t
-
val uminus : t -> t
-
val lt : t -> t -> bool
-
val le : t -> t -> bool
-
val gt : t -> t -> bool
-
val ge : t -> t -> bool
-
val eq : t -> t -> bool
-
val diseq : t -> t -> bool
(*val to_num: t -> Num.num*)
val to_q : t -> Q.t
-
val to_string : t -> string
(* val eq: t -> t -> bool *)
val zero : t
-
val is_zero : t -> bool
-
val is_one : t -> bool
diff --git a/src/scheduling.ml b/src/scheduling.ml
index b23704ca..a8efd935 100644
--- a/src/scheduling.ml
+++ b/src/scheduling.ml
@@ -139,7 +139,9 @@ let compute_node_reuse_table report =
for node %s: %a" n'.node_id Disjunction.pp_disjoint_map disjoint );
Log.report ~level:0 (fun fmt -> Format.fprintf fmt "OPT:reuse policy for
node %s: %a" n'.node_id Liveness.pp_reuse_policy reuse ); end; *)
- Hashtbl.filter_map_inplace (fun x v -> if x = v.var_id then None else Some v) reuse;
+ Hashtbl.filter_map_inplace
+ (fun x v -> if x = v.var_id then None else Some v)
+ reuse;
reuse
let schedule_prog prog =
@@ -155,8 +157,7 @@ let schedule_prog prog =
prog
([], IMap.empty)
-let compute_prog_reuse_table report =
- IMap.map compute_node_reuse_table report
+let compute_prog_reuse_table report = IMap.map compute_node_reuse_table report
(* removes inlined local variables from schedule report, which are now
useless *)
diff --git a/src/scheduling.mli b/src/scheduling.mli
index e048264d..29e66c76 100644
--- a/src/scheduling.mli
+++ b/src/scheduling.mli
@@ -4,7 +4,6 @@ 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 :
@@ -17,9 +16,6 @@ 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.mli b/src/sortProg.mli
index 6b10cd42..830e9db0 100644
--- a/src/sortProg.mli
+++ b/src/sortProg.mli
@@ -1,5 +1,4 @@
open Lustre_types
val sort_nodes_locals : program_t -> program_t
-
val sort : program_t -> program_t
diff --git a/src/spec_common.ml b/src/spec_common.ml
index c6e07d4f..342fca6b 100644
--- a/src/spec_common.ml
+++ b/src/spec_common.ml
@@ -3,7 +3,6 @@ open Utils
(* a small reduction engine *)
let is_true = function True -> true | _ -> false
-
let is_false = function False -> true | _ -> false
let type_of_value = function
@@ -87,7 +86,6 @@ let rec red = function
(* smart constructors *)
let vals vs = List.map (fun v -> Val v) vs
-
let mk_pred_call pred = Predicate pred
let mk_transition ?(mems = ISet.empty) ?(insts = IMap.empty) ?r ?i ?inst
@@ -111,13 +109,12 @@ let mk_transition ?(mems = ISet.empty) ?(insts = IMap.empty) ?r ?i ?inst
tr
let mk_memory_pack ?i ?inst id = mk_pred_call (MemoryPack (id, inst, i))
-
let mk_memory_pack_base id = mk_pred_call (MemoryPackBase id)
-let mk_state_variable_pack ?(tainted=false) x = StateVarPack (StateVar x, tainted)
+let mk_state_variable_pack ?(tainted = false) x =
+ StateVarPack (StateVar x, tainted)
let mk_state_assign_tr x v = Equal (Memory (StateVar x), Val v)
-
let mk_conditional_tr v t f = Ternary (Val v, t, f)
let mk_branch_tr x =
diff --git a/src/spec_common.mli b/src/spec_common.mli
index 20022895..695f870f 100644
--- a/src/spec_common.mli
+++ b/src/spec_common.mli
@@ -3,15 +3,10 @@ open Lustre_types
open Spec_types
val type_of_value : Machine_code_types.value_t expression_t -> Types.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_assign_tr : var_decl -> 'a -> 'a formula_t
-
val mk_memory_pack : ?i:int -> ?inst:ident -> ident -> 'a formula_t
-
val mk_memory_pack_base : ident -> 'a formula_t
val mk_transition :
@@ -26,7 +21,5 @@ val mk_transition :
'a formula_t
val mk_state_variable_pack : ?tainted:bool -> var_decl -> 'a formula_t
-
val mk_state_assign_tr : var_decl -> 'a -> 'a formula_t
-
val red : 'a formula_t -> 'a formula_t
diff --git a/src/splitting.mli b/src/splitting.mli
index 10986aa2..34254e4b 100644
--- a/src/splitting.mli
+++ b/src/splitting.mli
@@ -1,5 +1,4 @@
open Lustre_types
val tuple_split_eq : eq -> eq list
-
val tuple_split_eq_list : eq list -> eq list
diff --git a/src/tools/importer/vhdl_json_lib.ml b/src/tools/importer/vhdl_json_lib.ml
index ce97ba36..05da678c 100644
--- a/src/tools/importer/vhdl_json_lib.ml
+++ b/src/tools/importer/vhdl_json_lib.ml
@@ -171,7 +171,6 @@ let numeric_literal_simpl json =
x
let flatten_numeric_literal json = map_all json numeric_literal_simpl
-
let to_list_str str json = map_all json (assoc_elem_as_list str)
let rec to_list_content_str str json =
diff --git a/src/tools/importer/vhdl_json_lib.mli b/src/tools/importer/vhdl_json_lib.mli
index 243d0f05..fac7c847 100644
--- a/src/tools/importer/vhdl_json_lib.mli
+++ b/src/tools/importer/vhdl_json_lib.mli
@@ -1,13 +1,8 @@
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
diff --git a/src/tools/seal/seal_export.ml b/src/tools/seal/seal_export.ml
index 5a80caad..259fd98c 100644
--- a/src/tools/seal/seal_export.ml
+++ b/src/tools/seal/seal_export.ml
@@ -20,7 +20,9 @@ let process_sw vars f_e sw =
Format.eprintf
"Looking for variable %s in remaining expressions: [%a]@."
vid
- (Utils.Format.pp_print_list ~pp_sep:Utils.Format.pp_print_semicolon (fun fmt (id, e) ->
+ (Utils.Format.pp_print_list
+ ~pp_sep:Utils.Format.pp_print_semicolon
+ (fun fmt (id, e) ->
Format.fprintf fmt "(%s -> %a)" id Printers.pp_expr e))
remaining;
assert false (* Missing variable v in list *)))
@@ -85,7 +87,8 @@ let sw_to_lustre m sw_init sw_step init_out update_out =
let mem_eq =
if m.mmemory = [] then []
else
- let memory_vars = List.map fst m.mmemory in (* do not consider the potential /protecting/ arrow instance *)
+ let memory_vars = List.map fst m.mmemory in
+ (* do not consider the potential /protecting/ arrow instance *)
let e_init = process_sw memory_vars (fun x -> x) sw_init in
let e_step = process_sw memory_vars (Corelang.add_pre_expr vl) sw_step in
[
@@ -171,11 +174,7 @@ let to_lustre basename prog new_node orig_node =
let fmt_verif = Format.formatter_of_out_channel out_verif in
let check_nd = Lustre_utils.check_eq new_node orig_node in
let check_top =
- Corelang.mktop_decl
- Location.dummy
- output_file_verif
- false
- (Node check_nd)
+ Corelang.mktop_decl Location.dummy output_file_verif false (Node check_nd)
in
Format.fprintf
fmt_verif
diff --git a/src/tools/seal/seal_export.mli b/src/tools/seal/seal_export.mli
index c7ac0bf3..8de57f92 100644
--- a/src/tools/seal/seal_export.mli
+++ b/src/tools/seal/seal_export.mli
@@ -1,18 +1,20 @@
-val node_to_lustre: string (* basename *)
- -> Lustre_types.top_decl list (* prog *)
- -> Machine_code_types.machine_t (* machine *)
- -> (Lustre_types.expr option * (string * Lustre_types.expr) list)
- list (* sw_init *)
- -> (Lustre_types.expr option * (string * Lustre_types.expr) list)
- list (* sw_step *)
- -> (Lustre_types.expr option * (string * Lustre_types.expr) list)
- list (* init_out *)
- -> (Lustre_types.expr option * (string * Lustre_types.expr) list)
- list (* update_out*)
- -> unit
+val node_to_lustre :
+ string (* basename *) ->
+ Lustre_types.top_decl list (* prog *) ->
+ Machine_code_types.machine_t (* machine *) ->
+ (Lustre_types.expr option * (string * Lustre_types.expr) list) list
+ (* sw_init *) ->
+ (Lustre_types.expr option * (string * Lustre_types.expr) list) list
+ (* sw_step *) ->
+ (Lustre_types.expr option * (string * Lustre_types.expr) list) list
+ (* init_out *) ->
+ (Lustre_types.expr option * (string * Lustre_types.expr) list) list
+ (* update_out*) ->
+ unit
-val fun_to_lustre : string (* basename *)
- -> Lustre_types.top_decl list (* prog *)
- -> Machine_code_types.machine_t (* machine *)
- -> ((Lustre_types.expr option * (string * Lustre_types.expr) list) list)
- -> unit
+val fun_to_lustre :
+ string (* basename *) ->
+ Lustre_types.top_decl list (* prog *) ->
+ Machine_code_types.machine_t (* machine *) ->
+ (Lustre_types.expr option * (string * Lustre_types.expr) list) list ->
+ unit
diff --git a/src/tools/seal/seal_extract.ml b/src/tools/seal/seal_extract.ml
index 8115fe91..d7275fb9 100644
--- a/src/tools/seal/seal_extract.ml
+++ b/src/tools/seal/seal_extract.ml
@@ -15,13 +15,9 @@ let add_init defs vid = Hashtbl.add defs vid [ [], IsInit ]
(**************************************************************)
let is_init_name = "__is_init"
-
let const_defs = Hashtbl.create 13
-
let is_const id = Hashtbl.mem const_defs id
-
let is_enum_const id = Hashtbl.mem Zustre_data.const_tags id
-
let get_const id = Hashtbl.find const_defs id
(* expressions are only basic constructs here, no more ite, tuples, arrows, fby,
@@ -29,9 +25,7 @@ let get_const id = Hashtbl.find const_defs id
(* Set of hash to support memoization *)
let expr_hash : (expr * Utils.tag) list ref = ref []
-
let ze_hash : (Z3.Expr.expr, Utils.tag) Hashtbl.t = Hashtbl.create 13
-
let e_hash : (Utils.tag, Z3.Expr.expr) Hashtbl.t = Hashtbl.create 13
let pp_hash pp_key pp_v fmt h =
@@ -80,7 +74,6 @@ let get_expr ze =
e
let neg_ze z3e = Z3.Boolean.mk_not !ctx z3e
-
let is_init_z3e = Z3.Expr.mk_const_s !ctx is_init_name Zustre_common.bool_sort
let get_zid (ze : Z3.Expr.expr) : Utils.tag =
@@ -1137,7 +1130,9 @@ let merge_updates sys =
"Guards:@.shared: [%a]@.disj: [@[<v 0>%a@ ]@]@.Updates: %a@."
Guards.pp_short
common
- (Format.pp_print_list ~pp_sep:Format.pp_print_semicolon Guards.pp_long)
+ (Format.pp_print_list
+ ~pp_sep:Format.pp_print_semicolon
+ Guards.pp_long)
disj
UpMap.pp
up);
diff --git a/src/tools/seal/seal_extract.mli b/src/tools/seal/seal_extract.mli
index 17719780..e17bed4d 100644
--- a/src/tools/seal/seal_extract.mli
+++ b/src/tools/seal/seal_extract.mli
@@ -1,8 +1,13 @@
+val node_as_switched_sys :
+ Lustre_types.const_desc list ->
+ (* mems *) Lustre_types.var_decl list ->
+ (* nd *) Lustre_types.node_desc ->
+ (Lustre_types.expr option * Seal_utils.UpMap.key) list
+ * (Lustre_types.expr option * Seal_utils.UpMap.key) list
+ * (Lustre_types.expr option * Seal_utils.UpMap.key) list
+ * (Lustre_types.expr option * Seal_utils.UpMap.key) list
-val node_as_switched_sys: Lustre_types.const_desc list -> (* mems *) Lustre_types.var_decl list -> (* nd *) Lustre_types.node_desc -> (Lustre_types.expr option * Seal_utils.UpMap.key) list *
- (Lustre_types.expr option * Seal_utils.UpMap.key) list *
- (Lustre_types.expr option * Seal_utils.UpMap.key) list *
- (Lustre_types.expr option * Seal_utils.UpMap.key) list
-
-val fun_as_switched_sys: Lustre_types.const_desc list -> Lustre_types.node_desc -> (Lustre_types.expr option * (string * Lustre_types.expr) list) list
-
+val fun_as_switched_sys :
+ Lustre_types.const_desc list ->
+ Lustre_types.node_desc ->
+ (Lustre_types.expr option * (string * Lustre_types.expr) list) list
diff --git a/src/tools/seal/seal_slice.ml b/src/tools/seal/seal_slice.ml
index e3493f6e..b43f97f5 100644
--- a/src/tools/seal/seal_slice.ml
+++ b/src/tools/seal/seal_slice.ml
@@ -9,9 +9,11 @@ open Seal_utils
(* Basic functions to search into nodes. Could be moved to corelang
eventually *)
-let is_variable nd vid = List.exists (fun (v,_) -> v.var_id = vid) nd.node_locals
+let is_variable nd vid =
+ List.exists (fun (v, _) -> v.var_id = vid) nd.node_locals
-let find_variable nd vid = List.find (fun (v,_) -> v.var_id = vid) nd.node_locals
+let find_variable nd vid =
+ List.find (fun (v, _) -> v.var_id = vid) nd.node_locals
(* Returns the vars required to compute v. Memories are specifically
identified. *)
@@ -38,9 +40,13 @@ let coi_var deps nd v =
fmt
"COI of var %s: (%a // %a)@."
v.var_id
- (Format.pp_print_list ~pp_sep:Format.pp_print_comma Format.pp_print_string)
+ (Format.pp_print_list
+ ~pp_sep:Format.pp_print_comma
+ Format.pp_print_string)
(ISet.elements vset)
- (Format.pp_print_list ~pp_sep:Format.pp_print_comma Format.pp_print_string)
+ (Format.pp_print_list
+ ~pp_sep:Format.pp_print_comma
+ Format.pp_print_string)
(ISet.elements memset));
vset, memset
@@ -58,7 +64,7 @@ let rec coi_vars deps nd vl seen =
memset
in
let memset_vars =
- ISet.fold (fun vid accu -> (fst (find_variable nd vid)) :: accu) memset []
+ ISet.fold (fun vid accu -> fst (find_variable nd vid) :: accu) memset []
in
let vset' = coi_vars memset_vars (vl @ seen) in
ISet.union accu (ISet.union vset vset'))
@@ -79,7 +85,9 @@ let slice_node vars_to_keep msch nd =
Format.fprintf
fmt
"COI Vars: %a@."
- (Format.pp_print_list ~pp_sep:Format.pp_print_comma Format.pp_print_string)
+ (Format.pp_print_list
+ ~pp_sep:Format.pp_print_comma
+ Format.pp_print_string)
coi_vars);
let outputs =
List.filter (fun v -> List.mem v.var_id coi_vars) nd.node_outputs
@@ -108,7 +116,9 @@ let slice_node vars_to_keep msch nd =
let sorted_eqs, unused =
Scheduling.sort_equations_from_schedule eqs msch.Scheduling_type.schedule
in
- let locals = List.filter (fun (v,_) -> not (List.mem v.var_id unused)) locals in
+ let locals =
+ List.filter (fun (v, _) -> not (List.mem v.var_id unused)) locals
+ in
report ~level:3 (fun fmt -> Format.fprintf fmt "Scheduled node@.");
let stmts =
diff --git a/src/tools/seal/seal_slice.mli b/src/tools/seal/seal_slice.mli
index 3dd46941..04ac28f5 100644
--- a/src/tools/seal/seal_slice.mli
+++ b/src/tools/seal/seal_slice.mli
@@ -1,3 +1,5 @@
-val slice_node: Lustre_types.var_decl list ->
- Scheduling_type.schedule_report ->
- Lustre_types.node_desc -> Lustre_types.node_desc
+val slice_node :
+ Lustre_types.var_decl list ->
+ Scheduling_type.schedule_report ->
+ Lustre_types.node_desc ->
+ Lustre_types.node_desc
diff --git a/src/tools/seal/seal_utils.ml b/src/tools/seal/seal_utils.ml
index 68646fcf..d73d29d1 100644
--- a/src/tools/seal/seal_utils.ml
+++ b/src/tools/seal/seal_utils.ml
@@ -2,19 +2,13 @@ open Lustre_types
open Utils
let report = Log.report ~plugin:"seal"
-
let seal_debug = ref false
type 'boolexpr guard = 'boolexpr list
-
type ('guard, 'elem) guarded_expr = 'guard * 'elem
-
type element = IsInit | Expr of expr
-
type elem_boolexpr = element * bool
-
type elem_guarded_expr = (elem_boolexpr guard, element) guarded_expr
-
type 'ge mdef_t = 'ge list
(* type mdef_t = guarded_expr list *)
@@ -118,6 +112,5 @@ module Guards = struct
end)
let pp_short fmt s = pp_gl_short fmt (elements s)
-
let pp_long fmt s = pp_gl Printers.pp_expr fmt (elements s)
end
diff --git a/src/tools/seal/seal_utils.mli b/src/tools/seal/seal_utils.mli
index 29afab0b..f8088a15 100644
--- a/src/tools/seal/seal_utils.mli
+++ b/src/tools/seal/seal_utils.mli
@@ -1,53 +1,73 @@
-val report: ?verbose_level:int ->
- level:int -> (Format.formatter -> unit) -> unit
+val report :
+ ?verbose_level:int -> level:int -> (Format.formatter -> unit) -> unit
-val seal_debug: bool ref
+val seal_debug : bool ref
type 'boolexpr guard = 'boolexpr list
-
type ('guard, 'elem) guarded_expr = 'guard * 'elem
-
type element = IsInit | Expr of Lustre_types.expr
-
type elem_boolexpr = element * bool
-
type elem_guarded_expr = (elem_boolexpr guard, element) guarded_expr
-
type 'ge mdef_t = 'ge list
-val pp_up: (Format.formatter -> 'a -> unit) -> Format.formatter -> (string * 'a) mdef_t -> unit
-
+val pp_up :
+ (Format.formatter -> 'a -> unit) ->
+ Format.formatter ->
+ (string * 'a) mdef_t ->
+ unit
+
val pp_sys :
(Format.formatter -> 'update_expr -> unit) ->
Format.formatter ->
- (Lustre_types.expr option * (Utils.ident * 'update_expr) list) list -> unit
+ (Lustre_types.expr option * (Utils.ident * 'update_expr) list) list ->
+ unit
-val pp_guard_list: (Format.formatter -> 'a -> unit) -> Format.formatter -> ('a * bool) mdef_t -> unit
+val pp_guard_list :
+ (Format.formatter -> 'a -> unit) ->
+ Format.formatter ->
+ ('a * bool) mdef_t ->
+ unit
+
+val pp_elem : Format.formatter -> element -> unit
-val pp_elem: Format.formatter -> element -> unit
+val pp_assign_map :
+ (Format.formatter -> 'a -> unit) ->
+ Format.formatter ->
+ (string * (('a * bool) mdef_t * 'a) mdef_t) mdef_t ->
+ unit
-val pp_assign_map : (Format.formatter -> 'a -> unit) -> Format.formatter -> (string * (('a * bool) mdef_t * 'a) mdef_t) mdef_t -> unit
-
val deelem : element -> Lustre_types.expr
-
-val pp_guard_expr: (Format.formatter -> element -> unit) -> Format.formatter -> elem_boolexpr list * element -> unit
-val select_elem: element -> elem_boolexpr -> bool
+val pp_guard_expr :
+ (Format.formatter -> element -> unit) ->
+ Format.formatter ->
+ elem_boolexpr list * element ->
+ unit
-val pp_mdefs: (Format.formatter -> element -> unit) -> Format.formatter -> (elem_boolexpr list * element) mdef_t -> unit
+val select_elem : element -> elem_boolexpr -> bool
-val pp_all_defs: Format.formatter -> (Utils.ident * (elem_boolexpr list * element) mdef_t) list -> unit
+val pp_mdefs :
+ (Format.formatter -> element -> unit) ->
+ Format.formatter ->
+ (elem_boolexpr list * element) mdef_t ->
+ unit
+val pp_all_defs :
+ Format.formatter ->
+ (Utils.ident * (elem_boolexpr list * element) mdef_t) list ->
+ unit
module Guards : sig
include Set.S
- val pp_short: Format.formatter -> t -> unit
- val pp_long: Format.formatter -> t -> unit
-
-end with type elt = Lustre_types.expr * bool
+ val pp_short : Format.formatter -> t -> unit
+ val pp_long : Format.formatter -> t -> unit
+end
+with type elt = Lustre_types.expr * bool
module UpMap : sig
include Map.S
- val pp: Format.formatter -> (string * Lustre_types.expr) mdef_t -> unit
-end with type key = (string * Lustre_types.expr) mdef_t
+
+ val pp : Format.formatter -> (string * Lustre_types.expr) mdef_t -> unit
+end
+with type key = (string * Lustre_types.expr) mdef_t
diff --git a/src/tools/seal/seal_verifier.ml b/src/tools/seal/seal_verifier.ml
index 38c77135..9667b225 100644
--- a/src/tools/seal/seal_verifier.ml
+++ b/src/tools/seal/seal_verifier.ml
@@ -25,7 +25,6 @@ open Seal_extract
open Seal_utils
let active = ref false
-
let seal_export = ref None
let set_export s =
@@ -177,7 +176,6 @@ module Verifier : VerifierType.S = struct
()
let is_active () = !active
-
let run = seal_run
end
diff --git a/src/tools/stateflow/common/basetypes.ml b/src/tools/stateflow/common/basetypes.ml
index 9769c916..3ef05e91 100644
--- a/src/tools/stateflow/common/basetypes.ml
+++ b/src/tools/stateflow/common/basetypes.ml
@@ -2,15 +2,10 @@ let sf_level = 2
(* Basic datatype for model elements: state and junction name, events ... *)
type state_name_t = string
-
type junction_name_t = string
-
type path_t = state_name_t list
-
type event_base_t = string
-
type event_t = event_base_t option
-
type user_variable_name_t = string
(* Connected to lustrec types *)
@@ -30,7 +25,6 @@ type base_condition_t = {
(* P(r)etty printers *)
let pp_state_name = Format.pp_print_string
-
let pp_junction_name = Format.pp_print_string
let pp_path fmt p =
@@ -49,7 +43,6 @@ let pp_path fmt p =
* Format.fprintf fmt "%s" s *)
let pp_base_act fmt a = Printers.pp_node_stmts fmt a.defs
-
let pp_base_cond fmt c = Printers.pp_expr fmt c.expr
(* Action and Condition types and functions. *)
@@ -89,15 +82,10 @@ module type ActionType = sig
type t
val nil : t
-
val aquote : base_action_t -> t
-
val open_path : path_t -> t
-
val close_path : path_t -> t
-
val call : 'c call_t -> 'c -> t
-
val pp_act : Format.formatter -> t -> unit
end
@@ -112,13 +100,9 @@ module Action = struct
type t = action_t
let nil = Nil
-
let aquote act = Quote act
-
let open_path p = Open p
-
let close_path p = Close p
-
let call c a = Call (c, a)
let pp_call : type c. Format.formatter -> c call_t -> c -> unit =
@@ -165,17 +149,11 @@ module type ConditionType = sig
type t
val cquote : base_condition_t -> t
-
val tru : t
-
val active : path_t -> t
-
val event : event_t -> t
-
val ( && ) : t -> t -> t
-
val neg : t -> t
-
val pp_cond : Format.formatter -> t -> unit
end
@@ -191,15 +169,10 @@ module Condition = struct
type t = condition_t
let cquote cond = Quote cond
-
let tru = True
-
let neg cond = Neg cond
-
let ( && ) cond1 cond2 = And (cond1, cond2)
-
let active path = Active path
-
let event evt = match evt with None -> True | Some e -> Event e
let rec pp_cond fmt cond =
diff --git a/src/tools/stateflow/common/basetypes.mli b/src/tools/stateflow/common/basetypes.mli
index fb54ab3b..0cf6c610 100644
--- a/src/tools/stateflow/common/basetypes.mli
+++ b/src/tools/stateflow/common/basetypes.mli
@@ -1,15 +1,10 @@
val sf_level : int
type state_name_t = string
-
type junction_name_t = string
-
type path_t = state_name_t list
-
type event_base_t = string
-
type event_t = event_base_t option
-
type user_variable_name_t = string
(* Connected to lustrec types *)
@@ -35,13 +30,9 @@ type _ 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
(* Conditions are either (1) simple strings, (2) the active status of a state or
@@ -50,17 +41,11 @@ module type ConditionType = sig
type t
val cquote : base_condition_t -> t
-
val tru : t
-
val active : path_t -> t
-
val event : event_t -> t
-
val ( && ) : t -> t -> t
-
val neg : t -> t
-
val pp_cond : Format.formatter -> t -> unit
end
@@ -78,15 +63,10 @@ module type ActionType = sig
type t
val nil : t
-
val aquote : base_action_t -> t
-
val open_path : path_t -> t
-
val close_path : path_t -> t
-
val call : 'c call_t -> 'c -> t
-
val pp_act : Format.formatter -> t -> unit
end
diff --git a/src/tools/stateflow/common/datatype.ml b/src/tools/stateflow/common/datatype.ml
index 332db20e..ab898598 100644
--- a/src/tools/stateflow/common/datatype.ml
+++ b/src/tools/stateflow/common/datatype.ml
@@ -39,12 +39,9 @@ type 'prog_t src_components_t =
| SFFunction of 'prog_t
type prog_t =
- | Program of
- state_name_t
- * prog_t src_components_t list
- * GlobalVarDef.t list
+ | Program of state_name_t * prog_t src_components_t list * GlobalVarDef.t list
-type scope_t = Constant | Input | Local | Output | Parameter
+type scope_t = Constant | Input | Local | Output | Parameter
(* XXX: UNUSED *)
(* type datatype_var_init_t = Bool of bool | Real of float | Int of int *)
@@ -56,9 +53,7 @@ type trace_t = event_t list
module type MODEL_T = sig
val name : string
-
val model : prog_t
-
val traces : trace_t list
end
@@ -68,11 +63,8 @@ module SF = struct
(* Basic constructors *)
let no_action = Action.nil
-
let no_condition = Condition.tru
-
let no_event = None
-
let event s = Some s
(* XXX: UNUSED *)
@@ -146,60 +138,96 @@ module SF = struct
let pp_comp fmt c =
match c with
| Or (_T, _S) ->
- Format.fprintf fmt "Or(%a, {%a})"
- pp_transitions _T
- (Format.pp_print_list ~pp_sep:Format.pp_print_semicolon pp_state_name) _S
- | And (_S) ->
- Format.fprintf fmt "And({%a})"
- (Format.pp_print_list ~pp_sep:Format.pp_print_semicolon pp_state_name) _S
+ Format.fprintf
+ fmt
+ "Or(%a, {%a})"
+ pp_transitions
+ _T
+ (Format.pp_print_list ~pp_sep:Format.pp_print_semicolon pp_state_name)
+ _S
+ | And _S ->
+ Format.fprintf
+ fmt
+ "And({%a})"
+ (Format.pp_print_list ~pp_sep:Format.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
+ 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
+ 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@ @]"
- (Format.pp_print_list ~pp_sep:Format.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
- ))
+ Format.fprintf
+ fmt
+ "@[<v>%a@ @]"
+ (Format.pp_print_list ~pp_sep:Format.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@ "
+ Format.fprintf
+ fmt
+ "SFFunction name: %s@ %a@ "
name
- (pp_src pp_sffunction) component_list
+ (pp_src pp_sffunction)
+ component_list
let pp_vars fmt src =
- Format.fprintf fmt "@[<v>%a@ @]"
- (Format.pp_print_list (fun fmt globvar -> Printers.pp_var fmt globvar.GlobalVarDef.variable))
- src
+ Format.fprintf
+ fmt
+ "@[<v>%a@ @]"
+ (Format.pp_print_list (fun fmt globvar ->
+ Printers.pp_var fmt globvar.GlobalVarDef.variable))
+ src
let pp_prog fmt (Program (name, component_list, vars)) =
- Format.fprintf fmt "Main node name: %s@ %a@ %a@"
+ Format.fprintf
+ fmt
+ "Main node name: %s@ %a@ %a@"
name
- (pp_src pp_sffunction) component_list
- pp_vars vars
+ (pp_src pp_sffunction)
+ component_list
+ pp_vars
+ 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
+ (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 f17833b4..bd00696c 100644
--- a/src/tools/stateflow/common/datatype.mli
+++ b/src/tools/stateflow/common/datatype.mli
@@ -37,20 +37,14 @@ type 'prog_t src_components_t =
| SFFunction of 'prog_t
type prog_t =
- | Program of
- state_name_t
- * prog_t src_components_t list
- * GlobalVarDef.t list
-
-type scope_t = Constant | Input | Local | Output | Parameter
+ | Program of state_name_t * prog_t src_components_t list * GlobalVarDef.t list
+type scope_t = Constant | Input | Local | Output | Parameter
type trace_t = event_t list
module type MODEL_T = sig
val name : string
-
val model : prog_t
-
val traces : trace_t list
end
@@ -58,26 +52,15 @@ end
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 -> Basetypes.GlobalVarDef.t 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/json-parser/json_parser.ml b/src/tools/stateflow/json-parser/json_parser.ml
index 7f6b9dab..4337b84d 100644
--- a/src/tools/stateflow/json-parser/json_parser.ml
+++ b/src/tools/stateflow/json-parser/json_parser.ml
@@ -1,110 +1,115 @@
open Basetypes
open Corelang
open Datatype
+
(*open LustreSpec*)
open Lustre_types
open Str
module Y = Yojson.Basic
-module type ParseExt =
-sig
+module type ParseExt = sig
val parse_condition : Y.t -> Condition.t
- val parse_action : Y.t -> Action.t
- val parse_event : Y.t -> Basetypes.event_t
+ val parse_action : Y.t -> Action.t
+ val parse_event : Y.t -> Basetypes.event_t
end
module Parser (Ext : ParseExt) = struct
exception JSON_parse_error of string
let path_split = String.split_on_char '/'
-
let path_concat = String.concat (String.make 1 '/')
module YU = Y.Util
- let to_list json =
- try
- json |> YU.to_list
- with
- YU.Type_error _ -> [ json ]
+ let to_list json = try json |> YU.to_list with YU.Type_error _ -> [ json ]
let rec parse_prog json : prog_t =
- Logs.info (fun m -> m "parse_prog %s" (json |> YU.member "name" |> YU.to_string));
- Program (
- json |> YU.member "name" |> YU.to_string,
- (json |> YU.member "states" |> to_list |> List.map parse_state) @
- (json |> YU.member "junctions" |> to_list |> List.map parse_junction) @
- (json |> YU.member "sffunctions" |> to_list |> List.map
- (fun res -> SFFunction (parse_prog res))),
- json |> YU.member "data" |> to_list |> List.map parse_variable
- )
+ Logs.info (fun m ->
+ m "parse_prog %s" (json |> YU.member "name" |> YU.to_string));
+ Program
+ ( json |> YU.member "name" |> YU.to_string,
+ (json |> YU.member "states" |> to_list |> List.map parse_state)
+ @ (json |> YU.member "junctions" |> to_list |> List.map parse_junction)
+ @ (json |> YU.member "sffunctions" |> to_list
+ |> List.map (fun res -> SFFunction (parse_prog res))),
+ json |> YU.member "data" |> to_list |> List.map parse_variable )
and parse_state json =
Logs.debug (fun m -> m "parse_state %s" (Y.to_string json));
- State (
- json |> YU.member "path" |> parse_path,
- json |> parse_state_def
- )
+ State (json |> YU.member "path" |> parse_path, json |> parse_state_def)
+
and parse_path json =
Logs.debug (fun m -> m "parse_path %s" (json |> Y.to_string));
json |> YU.to_string |> path_split
-
+
and parse_state_def json =
Logs.debug (fun m -> m "parse_state_def");
{
- state_actions = json |> YU.member "state_actions" |> parse_state_actions;
- outer_trans = json |> YU.member "outer_trans" |> to_list |> List.map parse_transition;
- inner_trans = json |> YU.member "inner_trans" |> to_list |> List.map parse_transition;
- internal_composition = json |> YU.member "internal_composition" |> parse_internal_composition
- }
+ state_actions = json |> YU.member "state_actions" |> parse_state_actions;
+ outer_trans =
+ json |> YU.member "outer_trans" |> to_list |> List.map parse_transition;
+ inner_trans =
+ json |> YU.member "inner_trans" |> to_list |> List.map parse_transition;
+ internal_composition =
+ json |> YU.member "internal_composition" |> parse_internal_composition;
+ }
and parse_state_actions json =
Logs.debug (fun m -> m "parse_state_actions");
{
- entry_act = json |> YU.member "entry_act" |> Ext.parse_action;
+ entry_act = json |> YU.member "entry_act" |> Ext.parse_action;
during_act = json |> YU.member "during_act" |> Ext.parse_action;
- exit_act = json |> YU.member "exit_act" |> Ext.parse_action;
+ exit_act = json |> YU.member "exit_act" |> Ext.parse_action;
}
-
+
and parse_transition json =
Logs.debug (fun m -> m "parse_transition %s" (Y.to_string json));
{
- event = json |> YU.member "event" |> Ext.parse_event;
- condition = json |> YU.member "condition" |> Ext.parse_condition;
- condition_act = json |> YU.member "condition_action" |> Ext.parse_action;
+ event = json |> YU.member "event" |> Ext.parse_event;
+ condition = json |> YU.member "condition" |> Ext.parse_condition;
+ condition_act = json |> YU.member "condition_action" |> Ext.parse_action;
transition_act = json |> YU.member "transition_action" |> Ext.parse_action;
- dest = json |> YU.member "dest" |> parse_dest
- }
+ dest = json |> YU.member "dest" |> parse_dest;
+ }
+
and parse_dest json =
Logs.debug (fun m -> m "parse_dest");
let dest_type = json |> YU.member "type" |> YU.to_string in
- (dest_type |>
- (function
- | "State" -> (fun p -> DPath p)
- | "Junction" -> (fun j -> DJunction (path_concat j))
- | _ -> raise (JSON_parse_error ("Invalid destination type: " ^ dest_type))))
+ (dest_type |> function
+ | "State" ->
+ fun p -> DPath p
+ | "Junction" ->
+ fun j -> DJunction (path_concat j)
+ | _ ->
+ raise (JSON_parse_error ("Invalid destination type: " ^ dest_type)))
(json |> YU.member "name" |> parse_path)
+
and parse_internal_composition json =
Logs.debug (fun m -> m "parse_internal_composition");
let state_type = json |> YU.member "type" |> YU.to_string in
- (state_type |>
- (function
- | "EXCLUSIVE_OR" -> (fun tinit substates -> Or (tinit, substates))
- | "PARALLEL_AND" -> (fun tinit substates -> assert (tinit = []); And (substates))
- | _ -> raise (JSON_parse_error ("Invalid state type: " ^ state_type))))
- (json |> YU.member "tinit" |> parse_tinit)
+ (state_type |> function
+ | "EXCLUSIVE_OR" ->
+ fun tinit substates -> Or (tinit, substates)
+ | "PARALLEL_AND" ->
+ fun tinit substates ->
+ assert (tinit = []);
+ And substates
+ | _ ->
+ raise (JSON_parse_error ("Invalid state type: " ^ state_type)))
+ (json |> YU.member "tinit" |> parse_tinit)
(json |> YU.member "substates" |> to_list |> List.map YU.to_string)
-
+
and parse_tinit json =
Logs.debug (fun m -> m "parse_tinit %s" (Y.to_string json));
- json |> to_list |> List.map parse_transition
-
+ json |> to_list |> List.map parse_transition
+
and parse_junction json =
Logs.debug (fun m -> m "parse_junction");
- Junction (
- json |> YU.member "path" |> YU.to_string,
+ Junction
+ ( json |> YU.member "path" |> YU.to_string,
json |> YU.member "outer_trans" |> to_list |> List.map parse_transition
)
+
and scope_of_string s =
match s with
| "Constant" ->
@@ -122,58 +127,70 @@ module Parser (Ext : ParseExt) = struct
and parse_real_value s =
Logs.debug (fun m -> m "parse_real_value %s" s);
- let real_regexp_simp = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)" in
- let real_regexp_e = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)\\(E\\|e\\)\\(\\(\\+\\|\\-\\)[0-9][0-9]*\\)" in
+ let real_regexp_simp = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)" in
+ let real_regexp_e =
+ regexp
+ "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)\\(E\\|e\\)\\(\\(\\+\\|\\-\\)[0-9][0-9]*\\)"
+ in
if string_match real_regexp_e s 0 then
let l = matched_group 1 s in
let r = matched_group 2 s in
let e = matched_group 4 s in
- Const_real (Real.create (l ^ r)
- (String.length r + (-1 * int_of_string e))
- s)
- else
- if string_match real_regexp_simp s 0 then
+ Const_real
+ (Real.create (l ^ r) (String.length r + (-1 * int_of_string e)) s)
+ else if string_match real_regexp_simp s 0 then
let l = matched_group 1 s in
let r = matched_group 2 s in
- Const_real (Real.create (l ^ r) (String.length r) s)
- else
- raise (JSON_parse_error ("Invalid real constant " ^ s))
+ Const_real (Real.create (l ^ r) (String.length r) s)
+ else raise (JSON_parse_error ("Invalid real constant " ^ s))
-
-and lustre_datatype_of_json json location =
- let datatype = json |> YU.member "datatype" |> YU.to_string in
+ and lustre_datatype_of_json json location =
+ let datatype = json |> YU.member "datatype" |> YU.to_string in
let initial_value = json |> YU.member "initial_value" |> YU.to_string in
match datatype with
- | "bool" -> (Tydec_bool, mkexpr location
- (Expr_const (Const_tag
- ((fun s -> match s with
- | "true" -> tag_true
- | "false" -> tag_false
- | _ ->
- raise (JSON_parse_error ("Invalid constant for
- boolean: " ^ s))) initial_value))))
- | "int" -> (Tydec_int, mkexpr location
- (Expr_const (Const_int (int_of_string
- initial_value))))
- | "real" -> (Tydec_real, mkexpr location
- (Expr_const (parse_real_value initial_value)))
- | _ -> raise (JSON_parse_error ("Invalid datatype " ^ datatype
- ^ " for variable " ^ (json |> YU.member "name"
- |> YU.to_string)))
+ | "bool" ->
+ ( Tydec_bool,
+ mkexpr
+ location
+ (Expr_const
+ (Const_tag
+ ((fun s ->
+ match s with
+ | "true" ->
+ tag_true
+ | "false" ->
+ tag_false
+ | _ ->
+ raise
+ (JSON_parse_error
+ ("Invalid constant for\n boolean: " ^ s)))
+ initial_value))) )
+ | "int" ->
+ ( Tydec_int,
+ mkexpr location (Expr_const (Const_int (int_of_string initial_value))) )
+ | "real" ->
+ Tydec_real, mkexpr location (Expr_const (parse_real_value initial_value))
+ | _ ->
+ raise
+ (JSON_parse_error
+ ("Invalid datatype " ^ datatype ^ " for variable "
+ ^ (json |> YU.member "name" |> YU.to_string)))
+
and parse_variable json =
- Logs.debug (fun m -> m "parse_variable %s" (json |> YU.member "name" |> YU.to_string));
- let location = Location.dummy_loc in
- let (datatype, initial_value) = lustre_datatype_of_json json location in
- let vdecl =
- mkvar_decl location ~orig:true
+ Logs.debug (fun m ->
+ m "parse_variable %s" (json |> YU.member "name" |> YU.to_string));
+ let location = Location.dummy_loc in
+ let datatype, initial_value = lustre_datatype_of_json json location in
+ let vdecl =
+ mkvar_decl
+ location
+ ~orig:true
( json |> YU.member "name" |> YU.to_string,
- {ty_dec_desc = datatype; ty_dec_loc = location},
- {ck_dec_desc = Ckdec_any; ck_dec_loc = location},
+ { ty_dec_desc = datatype; ty_dec_loc = location },
+ { ck_dec_desc = Ckdec_any; ck_dec_loc = location },
true,
Some initial_value,
- None (* no parentid *)
- )
+ None (* no parentid *) )
in
{ variable = vdecl; init_val = initial_value }
-
end
diff --git a/src/tools/stateflow/json-parser/test_json_parser_variables.ml b/src/tools/stateflow/json-parser/test_json_parser_variables.ml
index 534b7421..75f4ae69 100644
--- a/src/tools/stateflow/json-parser/test_json_parser_variables.ml
+++ b/src/tools/stateflow/json-parser/test_json_parser_variables.ml
@@ -7,9 +7,7 @@ open OUnit2
module ParseExt = struct
let parse_condition _ = Condition.tru
-
let parse_action _ = Action.nil
-
let parse_event json = Some Yojson.Basic.(json |> to_string)
end
diff --git a/src/tools/stateflow/models/model_simple.mli b/src/tools/stateflow/models/model_simple.mli
index 62e4c0f5..aec9c87e 100644
--- a/src/tools/stateflow/models/model_simple.mli
+++ b/src/tools/stateflow/models/model_simple.mli
@@ -1,7 +1,5 @@
open Datatype
val name : string
-
val model : prog_t
-
val traces : trace_t list
diff --git a/src/tools/stateflow/models/model_stopwatch.ml b/src/tools/stateflow/models/model_stopwatch.ml
index 0b98cea9..0015cf95 100644
--- a/src/tools/stateflow/models/model_stopwatch.ml
+++ b/src/tools/stateflow/models/model_stopwatch.ml
@@ -292,29 +292,31 @@ let model =
in
let globals =
let int_typ = Corelang.mktyp Location.dummy Lustre_types.Tydec_int in
- List.map (fun k ->
+ List.map
+ (fun k ->
let vdecl =
Corelang.mkvar_decl
- Location.dummy
- (k, (* name *)
- int_typ, (* type *)
- Corelang.dummy_clock_dec, (* clock *)
- false, (* not a constant *)
- None, (* no default value *)
- None (* no parent known *)
- ) in
- let init_val =
+ Location.dummy
+ ( k,
+ (* name *)
+ int_typ,
+ (* type *)
+ Corelang.dummy_clock_dec,
+ (* clock *)
+ false,
+ (* not a constant *)
+ None,
+ (* no default value *)
+ None (* no parent known *) )
+ in
+ let init_val =
(* Default value is zero *)
- Corelang.mkexpr Location.dummy (Lustre_types.Expr_const (Lustre_types.Const_int 0))
+ Corelang.mkexpr
+ Location.dummy
+ (Lustre_types.Expr_const (Lustre_types.Const_int 0))
in
- {GlobalVarDef.variable = vdecl; init_val = init_val; }
-
- )
- ["cent";
- "sec";
- "min";
- "cont"
- ]
+ { GlobalVarDef.variable = vdecl; init_val })
+ [ "cent"; "sec"; "min"; "cont" ]
in
Program (smain, src, globals)
diff --git a/src/tools/stateflow/models/model_stopwatch.mli b/src/tools/stateflow/models/model_stopwatch.mli
index 62e4c0f5..aec9c87e 100644
--- a/src/tools/stateflow/models/model_stopwatch.mli
+++ b/src/tools/stateflow/models/model_stopwatch.mli
@@ -1,7 +1,5 @@
open Datatype
val name : string
-
val model : prog_t
-
val traces : trace_t list
diff --git a/src/tools/stateflow/semantics/cPS.ml b/src/tools/stateflow/semantics/cPS.ml
index ca3ad3b0..b66028a3 100644
--- a/src/tools/stateflow/semantics/cPS.ml
+++ b/src/tools/stateflow/semantics/cPS.ml
@@ -21,7 +21,6 @@ functor
module Interp = CPS_interpreter.Interpreter (T)
module KenvTheta = KenvTheta (T)
-
module Tables = KenvTheta.MemoThetaTables ()
let eval
diff --git a/src/tools/stateflow/semantics/cPS_ccode_generator.ml b/src/tools/stateflow/semantics/cPS_ccode_generator.ml
index bcead07f..ce6a7598 100644
--- a/src/tools/stateflow/semantics/cPS_ccode_generator.ml
+++ b/src/tools/stateflow/semantics/cPS_ccode_generator.ml
@@ -6,7 +6,6 @@ module CodeGenerator : ComparableTransformerType = struct
type t = Bot | Act of act_t | Seq of t list | Ite of cond_t * t * t
let null = Seq []
-
let bot = Bot
let ( >> ) tr1 tr2 =
@@ -57,7 +56,6 @@ module CodeGenerator : ComparableTransformerType = struct
* Format.fprintf fmt "component %a(%a, %a) =@.@[<v 2>begin@ %a@]@.end" pp_call call pp_path p pp_frontier f pp_transformer tr) *)
let mkcomponent _ = assert false
-
let mkprincipal _ = assert false
(* let mktransformer _ = assert false *)
end
diff --git a/src/tools/stateflow/semantics/cPS_evaluator.ml b/src/tools/stateflow/semantics/cPS_evaluator.ml
index 40a997cc..daeace73 100644
--- a/src/tools/stateflow/semantics/cPS_evaluator.ml
+++ b/src/tools/stateflow/semantics/cPS_evaluator.ml
@@ -67,8 +67,8 @@ type truc = A of base_action_t | C of base_condition_t
module Evaluator :
TransformerType
with type t =
- event_t * bool ActiveStates.Env.t * truc list ->
- event_t * bool ActiveStates.Env.t * truc list = struct
+ event_t * bool ActiveStates.Env.t * truc list ->
+ event_t * bool ActiveStates.Env.t * truc list = struct
include TransformerStub
type env_t = event_t * bool ActiveStates.Env.t * truc list
@@ -77,7 +77,6 @@ module Evaluator :
type t = env_t -> env_t
let null rho = rho
-
let add_action a (evt, rho, al) = evt, rho, al @ [ A a ]
(* not very efficient but avoid to keep track of action order *)
@@ -85,13 +84,9 @@ module Evaluator :
(* not very efficient but avoid to keep track of action order *)
let bot _ = assert false
-
let ( >> ) tr1 tr2 rho = rho |> tr1 |> tr2
-
let ( ?? ) b tr = if b then tr else null
-
let eval_open p (evt, rho, al) = evt, ActiveStates.Env.add p true rho, al
-
let eval_close p (evt, rho, al) = evt, ActiveStates.Env.add p false rho, al
let eval_call :
diff --git a/src/tools/stateflow/semantics/cPS_interpreter.ml b/src/tools/stateflow/semantics/cPS_interpreter.ml
index d49161ff..3f5ce5e3 100644
--- a/src/tools/stateflow/semantics/cPS_interpreter.ml
+++ b/src/tools/stateflow/semantics/cPS_interpreter.ml
@@ -333,7 +333,6 @@ module Interpreter (Transformer : TransformerType) = struct
module type ProgType = sig
val init : state_name_t
-
val defs : prog_t src_components_t list
end
@@ -341,7 +340,6 @@ module Interpreter (Transformer : TransformerType) = struct
module Theta : ThetaType with type t = Transformer.t
val eval_prog : Transformer.t
-
val eval_components : 'c call_t -> ('c * Transformer.t) list
end
diff --git a/src/tools/stateflow/semantics/cPS_interpreter.mli b/src/tools/stateflow/semantics/cPS_interpreter.mli
index dedde20b..89756abb 100644
--- a/src/tools/stateflow/semantics/cPS_interpreter.mli
+++ b/src/tools/stateflow/semantics/cPS_interpreter.mli
@@ -8,7 +8,6 @@ module Interpreter (Transformer : TransformerType) : sig
module type ProgType = sig
val init : state_name_t
-
val defs : prog_t src_components_t list
end
@@ -16,7 +15,6 @@ module Interpreter (Transformer : TransformerType) : sig
module Theta : ThetaType with type t = Transformer.t
val eval_prog : Transformer.t
-
val eval_components : 'c call_t -> ('c * Transformer.t) list
end
diff --git a/src/tools/stateflow/semantics/cPS_lustre_generator.ml b/src/tools/stateflow/semantics/cPS_lustre_generator.ml
index e228aae7..5918bd21 100644
--- a/src/tools/stateflow/semantics/cPS_lustre_generator.ml
+++ b/src/tools/stateflow/semantics/cPS_lustre_generator.ml
@@ -4,7 +4,6 @@ open CPS_transformer
module LustrePrinter (Vars : sig
val state_vars : ActiveStates.Vars.t
-
val global_vars : GlobalVarDef.t list
end) : TransformerType = struct
include TransformerStub
@@ -84,9 +83,7 @@ end) : TransformerType = struct
(* TODO: declare global vars *)
let mkeq = Corelang.mkeq Location.dummy
-
let mkexpr = Corelang.mkexpr Location.dummy
-
let mkpredef_call = Corelang.mkpredef_call Location.dummy
let expr_of_bool b =
@@ -138,7 +135,6 @@ end) : TransformerType = struct
}
let event_var = mkvar "event" event_type
-
let const_map : (event_base_t, int) Hashtbl.t = Hashtbl.create 13
let get_event_const e =
diff --git a/src/tools/stateflow/semantics/cPS_lustre_generator.mli b/src/tools/stateflow/semantics/cPS_lustre_generator.mli
index 68bec7ac..b686c0b3 100644
--- a/src/tools/stateflow/semantics/cPS_lustre_generator.mli
+++ b/src/tools/stateflow/semantics/cPS_lustre_generator.mli
@@ -3,6 +3,5 @@ open CPS_transformer
module LustrePrinter (Vars : sig
val state_vars : ActiveStates.Vars.t
-
val global_vars : GlobalVarDef.t list
end) : TransformerType
diff --git a/src/tools/stateflow/semantics/cPS_transformer.ml b/src/tools/stateflow/semantics/cPS_transformer.ml
index cd347e68..a0b0ec87 100644
--- a/src/tools/stateflow/semantics/cPS_transformer.ml
+++ b/src/tools/stateflow/semantics/cPS_transformer.ml
@@ -1,11 +1,8 @@
open Basetypes
type mode_t = Outer | Inner | Enter
-
type 't success_t = path_t -> 't
-
type 't fail_t = { local : 't; global : 't }
-
type 't wrapper_t = path_t -> 't -> 't
type ('a, 'b, 't) tag_t =
@@ -49,60 +46,39 @@ let pp_tag : type a b t. Format.formatter -> (a, b, t) tag_t -> unit =
module TransformerStub = struct
type act_t = Action.t
-
type cond_t = Condition.t
let nil = Action.nil
-
let aquote = Action.aquote
-
let open_path = Action.open_path
-
let close_path = Action.close_path
-
let call = Action.call
-
let pp_act = Action.pp_act
-
let cquote = Condition.cquote
-
let tru = Condition.tru
-
let event = Condition.event
-
let active = Condition.active
-
let ( && ) = Condition.( && )
-
let neg = Condition.neg
-
let pp_cond = Condition.pp_cond
end
module type TransformerType = sig
type act_t = Action.t
-
type cond_t = Condition.t
-
type t
include ActionType with type t := act_t
-
include ConditionType with type t := cond_t
val null : t
-
val bot : t
-
val ( >> ) : t -> t -> t
-
val eval_act : (module ThetaType with type t = t) -> act_t -> t
-
val eval_cond : cond_t -> t -> t -> t
(* val mktransformer : t -> unit *)
val mkprincipal : t -> Lustre_types.program_t
-
val mkcomponent : 'c call_t -> 'c -> t -> Lustre_types.program_t
end
diff --git a/src/tools/stateflow/semantics/cPS_transformer.mli b/src/tools/stateflow/semantics/cPS_transformer.mli
index fe2d2470..cc16db63 100644
--- a/src/tools/stateflow/semantics/cPS_transformer.mli
+++ b/src/tools/stateflow/semantics/cPS_transformer.mli
@@ -1,11 +1,8 @@
open Basetypes
type mode_t = Outer | Inner | Enter
-
type 't success_t = path_t -> 't
-
type 't fail_t = { local : 't; global : 't }
-
type 't wrapper_t = path_t -> 't -> 't
type ('a, 'b, 't) tag_t =
@@ -27,33 +24,24 @@ module type ThetaType = sig
end
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
-
type cond_t = Condition.t
-
type t
include ActionType with type t := act_t
-
include ConditionType with type t := cond_t
val null : t
-
val bot : t
-
val ( >> ) : t -> t -> t
-
val eval_act : (module ThetaType with type t = t) -> act_t -> t
-
val eval_cond : cond_t -> t -> t -> t
(* val mktransformer : t -> unit *)
val mkprincipal : t -> Lustre_types.program_t
-
val mkcomponent : 'c call_t -> 'c -> t -> Lustre_types.program_t
end
@@ -65,10 +53,8 @@ end
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/memo.ml b/src/tools/stateflow/semantics/memo.ml
index d7fd7d25..7104d2f6 100644
--- a/src/tools/stateflow/semantics/memo.ml
+++ b/src/tools/stateflow/semantics/memo.ml
@@ -3,9 +3,7 @@ open Basetypes
type ('a, 'b) t = Memo : ('a, 'b) Hashtbl.t -> ('a, 'b) t
let create () = Memo (Hashtbl.create 97)
-
let reset (Memo hashf) = Hashtbl.reset hashf
-
let fold (Memo hashf) f e = Hashtbl.fold f hashf e
let apply (Memo hashf) f x =
diff --git a/src/tools/stateflow/semantics/memo.mli b/src/tools/stateflow/semantics/memo.mli
index 4327d0e3..c305260b 100644
--- a/src/tools/stateflow/semantics/memo.mli
+++ b/src/tools/stateflow/semantics/memo.mli
@@ -11,7 +11,6 @@ type ('a, 'b) t
(* - une table vide destinée à mémoriser uniquement les appels *)
(* d'une fonction quelconque. *)
val create : unit -> ('a, 'b) t
-
val reset : ('a, 'b) t -> unit
(* Utilisation d'une version "memoizée" d'une fonction à un paramètre. *)
diff --git a/src/tools/stateflow/semantics/theta.ml b/src/tools/stateflow/semantics/theta.ml
index b6ea8ec2..8ec83351 100644
--- a/src/tools/stateflow/semantics/theta.ml
+++ b/src/tools/stateflow/semantics/theta.ml
@@ -63,7 +63,6 @@ module KenvTheta (T : TransformerType) = struct
(Memo.create () : (path_t * path_t * frontier_t, T.t) Memo.t)
let table_theta_d = (Memo.create () : (path_t, T.t) Memo.t)
-
let table_theta_x = (Memo.create () : (path_t * frontier_t, T.t) Memo.t)
let tables : type c. c call_t -> (c, T.t) Memo.t =
@@ -185,7 +184,6 @@ module KenvTheta (T : TransformerType) = struct
assert false)
let theta tag = theta_ify Kenv.kenv tag
-
let components _call = []
end
diff --git a/src/tools/stateflow/sf_sem.ml b/src/tools/stateflow/sf_sem.ml
index 9c43db39..19d621fe 100644
--- a/src/tools/stateflow/sf_sem.ml
+++ b/src/tools/stateflow/sf_sem.ml
@@ -6,8 +6,8 @@ let model_name = ref "simple"
let models =
[
(module Model_simple : Datatype.MODEL_T);
- (module Model_stopwatch : Datatype.MODEL_T);
- (* (module Model_medium : Datatype.MODEL_T)*)
+ (module Model_stopwatch : Datatype.MODEL_T)
+ (* (module Model_medium : Datatype.MODEL_T)*);
]
let get_model_name m =
@@ -24,11 +24,8 @@ let set_model name =
(* Backend selection *)
let modular = ref 0
-
let set_modular i = modular := i
-
let mode = ref GenLus
-
let set_mode m = mode := m
(* Main *)
@@ -77,39 +74,40 @@ let _ =
let _ = Sem.code_gen modularmode in
()
| GenLus ->
- let module Model = (val model) in
- let state_vars = Datatype.SF.states Model.model in
- let global_vars =
- (* List.map (fun (v,e) -> {Basetypes.GlobalVarDef.variable = v; init_val = e;})*)
- (Datatype.SF.global_vars Model.model) in
-
- let module T = CPS_lustre_generator.LustrePrinter (struct
- let state_vars = state_vars
- let global_vars = global_vars
- end) in
- let module Sem = CPS.Semantics (T) (Model) in
- let prog = Sem.code_gen modularmode in
- Options.print_dec_types := true;
- Format.printf "%a@." Printers.pp_prog prog;
-
- let auto_file = "sf_gen_test_auto.lus" in (* Could be changed *)
- let auto_out = open_out auto_file in
- let auto_fmt = Format.formatter_of_out_channel auto_out in
- Format.fprintf auto_fmt "%a@." Printers.pp_prog prog;
-
- let params = Backends.get_normalization_params () in
- let prog, deps = Compiler_stages.stage1 params prog "" "" ".lus" in
-
-
- Options.print_dec_types := false;
- Format.printf "%a@." Printers.pp_prog prog;
- let noauto_file = "sf_gen_test_noauto.lus" in (* Could be changed *)
- let noauto_out = open_out noauto_file in
- let noauto_fmt = Format.formatter_of_out_channel noauto_out in
- Format.fprintf noauto_fmt "%a@." Printers.pp_prog prog
-
+ let module Model = (val model) in
+ let state_vars = Datatype.SF.states Model.model in
+ let global_vars =
+ (* List.map (fun (v,e) -> {Basetypes.GlobalVarDef.variable = v; init_val =
+ e;})*)
+ Datatype.SF.global_vars Model.model
+ in
+
+ let module T = CPS_lustre_generator.LustrePrinter (struct
+ let state_vars = state_vars
+ let global_vars = global_vars
+ end) in
+ let module Sem = CPS.Semantics (T) (Model) in
+ let prog = Sem.code_gen modularmode in
+ Options.print_dec_types := true;
+ Format.printf "%a@." Printers.pp_prog prog;
+
+ let auto_file = "sf_gen_test_auto.lus" in
+ (* Could be changed *)
+ let auto_out = open_out auto_file in
+ let auto_fmt = Format.formatter_of_out_channel auto_out in
+ Format.fprintf auto_fmt "%a@." Printers.pp_prog prog;
+
+ let params = Backends.get_normalization_params () in
+ let prog, deps = Compiler_stages.stage1 params prog "" "" ".lus" in
+
+ Options.print_dec_types := false;
+ Format.printf "%a@." Printers.pp_prog prog;
+ let noauto_file = "sf_gen_test_noauto.lus" in
+ (* Could be changed *)
+ let noauto_out = open_out noauto_file in
+ let noauto_fmt = Format.formatter_of_out_channel noauto_out in
+ Format.fprintf noauto_fmt "%a@." Printers.pp_prog prog
-
(* Local Variables: *)
(* compile-command: "make -C ../.. lustresf" *)
(* End: *)
diff --git a/src/tools/tiny/tiny_tube.ml b/src/tools/tiny/tiny_tube.ml
index 015f728f..81ea8ada 100644
--- a/src/tools/tiny/tiny_tube.ml
+++ b/src/tools/tiny/tiny_tube.ml
@@ -1,194 +1,221 @@
-(*
-TODO:
+(* TODO:
-- export du tube sur la tete de boucle:
- - par exemple un tube par dimension en 2d: temps x valeur
- - en sage ? en gnuplot? en tikz?
- - deux facon de visualiser le partitionnement
- - si on choisi un tube 2d, par exemple la variable x, on doit pouvoir visualiser le split du tube en fonction d'une variable booleenne. Par exemple on choisi b1 et on voit deux couleurs sur le tube de x. Ou on se restreint a b1 true ou b1 false
- - on doit aussi pouvoir afficher globalement pour une variable booleen le split. On choisi par exemple b1 de facon gloable et tous les tubes sont raffines en b1 true / b1 false / b1 both / b1 split enfin pour avoir deux plots separes.
+ - export du tube sur la tete de boucle: - par exemple un tube par dimension
+ en 2d: temps x valeur - en sage ? en gnuplot? en tikz? - deux facon de
+ visualiser le partitionnement - si on choisi un tube 2d, par exemple la
+ variable x, on doit pouvoir visualiser le split du tube en fonction d'une
+ variable booleenne. Par exemple on choisi b1 et on voit deux couleurs sur le
+ tube de x. Ou on se restreint a b1 true ou b1 false - on doit aussi pouvoir
+ afficher globalement pour une variable booleen le split. On choisi par
+ exemple b1 de facon gloable et tous les tubes sont raffines en b1 true / b1
+ false / b1 both / b1 split enfin pour avoir deux plots separes.
- - par exemple un csv
- nb_temps, x_min, x_max, y_min, y_max, b1_true_x_min, b1_true_x_max, b1_true_y_min, b1_true_y_max, ....
+ - par exemple un csv nb_temps, x_min, x_max, y_min, y_max, b1_true_x_min,
+ b1_true_x_max, b1_true_y_min, b1_true_y_max, ....
+ - - export de l'ast en latex avec des instructions tikz puis ensuite
+ l'affichage des elements abstraits a chaque point de programme pour les
+ articles. On peut desactiver ou activer les domaines grace aux options *)
- -
-- export de l'ast en latex avec des instructions tikz puis ensuite l'affichage des elements abstraits a chaque point de programme pour les articles. On peut desactiver ou activer les domaines grace aux options
-
-*)
-
-
-let pp_var fmt ((n,t),ctx) =
+let pp_var fmt ((n, t), ctx) =
(* Tiny.Ast.Var.pp_ fmt v *)
match ctx with
| None ->
- Format.fprintf fmt "%s" n
- | Some ((bv, _),b) ->
- Format.fprintf fmt "%s __ %s = %b" n bv b
+ Format.fprintf fmt "%s" n
+ | Some ((bv, _), b) ->
+ Format.fprintf fmt "%s __ %s = %b" n bv b
-
(*let pp_bound fmt b = Tiny.Scalar.pp fmt b *)
-module type S =
- sig
- module Results: Tiny.Analyze.Results
- val list: (int * Results.Dom.t) list
- val bounds: ((Tiny.Ast.Var.t * (Tiny.Ast.Var.t * bool) option) * (Tiny.Bounds.t)) list
- end
-
+module type S = sig
+ module Results : Tiny.Analyze.Results
+
+ val list : (int * Results.Dom.t) list
+
+ val bounds :
+ ((Tiny.Ast.Var.t * (Tiny.Ast.Var.t * bool) option) * Tiny.Bounds.t) list
+end
+
let process env ast results =
- let module Results = (val results: Tiny.Analyze.Results) in
+ let module Results = (val results : Tiny.Analyze.Results) in
let module Dom = Results.Dom in
let module PrintResults = Tiny.PrintResults.Make (Dom) in
let m = Results.results in
-
+
let while_loc = Tiny.Ast.get_main_while_loc ast in
let list = PrintResults.get_unrolled_info m while_loc in
let join =
match list with
- | [] -> Dom.bottom env
- | (_,hd)::tl -> List.fold_left (fun accu (_,e) -> Dom.join accu e) hd tl
+ | [] ->
+ Dom.bottom env
+ | (_, hd) :: tl ->
+ List.fold_left (fun accu (_, e) -> Dom.join accu e) hd tl
in
let bounds = Dom.to_bounds join in
let module M = struct
- module Results = Results
- module PrintResults = PrintResults
- let list = list
- let bounds = bounds
- end
- in
- (module M: S)
- (*
-let build f_header f_content env ast results =
- let module Results = (val results: Tiny.Analyze.Results) in
- let module Dom = Results.Dom in
- let module PrintResults = Tiny.PrintResults.Make (Dom) in
- let m = Results.results in
-
- let while_loc = Tiny.Ast.get_main_while_loc ast in
- let list = PrintResults.get_unrolled_info m while_loc in
- let join =
- match list with
- | [] -> Dom.bottom env
- | (_,hd)::tl -> List.fold_left (fun accu (_,e) -> Dom.join accu e) hd tl
- in
- let bounds = Dom.to_bounds join in
- f_header bounds;
- f_content list
- *)
+ module Results = Results
+ module PrintResults = PrintResults
+
+ let list = list
+ let bounds = bounds
+ end in
+ (module M : S)
+(* let build f_header f_content env ast results = let module Results = (val
+ results: Tiny.Analyze.Results) in let module Dom = Results.Dom in let module
+ PrintResults = Tiny.PrintResults.Make (Dom) in let m = Results.results in
+
+ let while_loc = Tiny.Ast.get_main_while_loc ast in let list =
+ PrintResults.get_unrolled_info m while_loc in let join = match list with | []
+ -> Dom.bottom env | (_,hd)::tl -> List.fold_left (fun accu (_,e) -> Dom.join
+ accu e) hd tl in let bounds = Dom.to_bounds join in f_header bounds;
+ f_content list *)
let pp_bounds fmt bounds =
- List.iter (fun ((v,ctx) as x, bounds) ->
-
- Format.fprintf fmt
- "%a in %a@."
- pp_var x
- Tiny.Bounds.pp bounds)
+ List.iter
+ (fun (((v, ctx) as x), bounds) ->
+ Format.fprintf fmt "%a in %a@." pp_var x Tiny.Bounds.pp bounds)
bounds
-
+
let pp env ast results fmt =
let m = process env ast results in
- let module M = (val m: S) in
- pp_bounds fmt M.bounds;
+ let module M = (val m : S) in
+ pp_bounds fmt M.bounds;
Format.fprintf fmt "Tube: %i@." (List.length M.list);
- List.iter (fun (idx, elem) ->
- Format.fprintf fmt "%i -> %a@." idx M.Results.Dom.fprint elem) M.list
+ List.iter
+ (fun (idx, elem) ->
+ Format.fprintf fmt "%i -> %a@." idx M.Results.Dom.fprint elem)
+ M.list
let export env ast results fmt =
let m = process env ast results in
- let module M = (val m: S) in
- List.iter (fun (x, bounds) ->
- Format.fprintf fmt
- "%a in %a@."
- pp_var x
- Tiny.Bounds.pp bounds)
+ let module M = (val m : S) in
+ List.iter
+ (fun (x, bounds) ->
+ Format.fprintf fmt "%a in %a@." pp_var x Tiny.Bounds.pp bounds)
M.bounds;
Format.fprintf fmt "Tube: %i@." (List.length M.list);
- List.iter (fun (idx, elem) ->
- Format.fprintf fmt
+ List.iter
+ (fun (idx, elem) ->
+ Format.fprintf
+ fmt
"%i -> %a@."
idx
- pp_bounds (M.Results.Dom.to_bounds elem)
- ) M.list
+ pp_bounds
+ (M.Results.Dom.to_bounds elem))
+ M.list
-let export_to_wide_csv env ast results fmt =
+let export_to_wide_csv env ast results fmt =
let m = process env ast results in
- let module M = (val m: S) in
- let bounds = List.map (fun (idx, elem) -> idx, M.Results.Dom.to_bounds elem) M.list in
- (* Gather all variable ids *)
- let module VarIdSet = Set.Make (
- struct
- type t = Tiny.Ast.Var.t * (Tiny.Ast.Var.t * bool) option
- let compare = compare
- end)
+ let module M = (val m : S) in
+ let bounds =
+ List.map (fun (idx, elem) -> idx, M.Results.Dom.to_bounds elem) M.list
in
- let var_ids = List.fold_left (
- fun accu (_, bounds) ->
- List.fold_left (fun accu (vctx, _) -> VarIdSet.add vctx accu) accu bounds
- ) VarIdSet.empty bounds
+ (* Gather all variable ids *)
+ let module VarIdSet = Set.Make (struct
+ type t = Tiny.Ast.Var.t * (Tiny.Ast.Var.t * bool) option
+
+ let compare = compare
+ end) in
+ let var_ids =
+ List.fold_left
+ (fun accu (_, bounds) ->
+ List.fold_left
+ (fun accu (vctx, _) -> VarIdSet.add vctx accu)
+ accu
+ bounds)
+ VarIdSet.empty
+ bounds
in
let ordered_list = VarIdSet.elements var_ids in
- Format.fprintf fmt "timestep,%a@."
- (Utils.Format.pp_print_list ~pp_sep:Utils.Format.pp_print_comma
- (fun fmt ((n,_),ctx) ->
+ Format.fprintf
+ fmt
+ "timestep,%a@."
+ (Utils.Format.pp_print_list
+ ~pp_sep:Utils.Format.pp_print_comma
+ (fun fmt ((n, _), ctx) ->
let pp fmt =
match ctx with
- None ->
- Format.fprintf fmt "%s" n
- | Some ((bn,_),b) ->
- Format.fprintf fmt "%s_//%s_eq_%b" n bn b
+ | None ->
+ Format.fprintf fmt "%s" n
+ | Some ((bn, _), b) ->
+ Format.fprintf fmt "%s_//%s_eq_%b" n bn b
in
- Format.fprintf fmt "%t_min,%t_max" pp pp
- ))
+ Format.fprintf fmt "%t_min,%t_max" pp pp))
ordered_list;
- Format.fprintf fmt "%a@."
- (Utils.Format.pp_print_list ~pp_sep:(fun fmt() -> Format.fprintf fmt "@.")
- (fun fmt (idx, bounds_idx) ->
- Format.fprintf fmt "@[<h 0>%i, %a@]"
- idx
- (Utils.Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
- (fun fmt bounds_ (* (min_, max_) *) ->
- match bounds_ with
- None -> Format.fprintf fmt ",,,"
- | Some b -> Tiny.Bounds.pp fmt b
- (* let pp_bound fmt b = match b with
- * | None -> Format.fprintf fmt ","
- * | Some b -> Tiny.Bounds.pp fmt b (\* Scalar.pp fmt b *\)
- * in *)
- (* Format.fprintf fmt "%a, %a" pp_bound min_ pp_bound max_ *)))
- (List.map (fun v -> if List.mem_assoc v bounds_idx then
- Some (List.assoc v bounds_idx)
- (* let min_, max_ = List.assoc v bounds_idx in
- * Some min_, Some max_ *)
- else
- None(* , None *)
- ) ordered_list)
- ))
+ Format.fprintf
+ fmt
+ "%a@."
+ (Utils.Format.pp_print_list
+ ~pp_sep:(fun fmt () -> Format.fprintf fmt "@.")
+ (fun fmt (idx, bounds_idx) ->
+ Format.fprintf
+ fmt
+ "@[<h 0>%i, %a@]"
+ idx
+ (Utils.Format.pp_print_list
+ ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
+ (fun fmt bounds_ (* (min_, max_) *) ->
+ match bounds_ with
+ | None ->
+ Format.fprintf fmt ",,,"
+ | Some b ->
+ Tiny.Bounds.pp fmt b
+ (* let pp_bound fmt b = match b with
+ * | None -> Format.fprintf fmt ","
+ * | Some b -> Tiny.Bounds.pp fmt b (\* Scalar.pp fmt b *\)
+ * in *)
+ (* Format.fprintf fmt "%a, %a" pp_bound min_ pp_bound max_ *)))
+ (List.map
+ (fun v ->
+ if List.mem_assoc v bounds_idx then
+ Some (List.assoc v bounds_idx)
+ (* let min_, max_ = List.assoc v bounds_idx in
+ * Some min_, Some max_ *)
+ else None (* , None *))
+ ordered_list)))
bounds;
()
-
-let export_to_csv env ast results fmt =
+let export_to_csv env ast results fmt =
let m = process env ast results in
- let module M = (val m: S) in
- let bounds = List.map (fun (idx, elem) ->
- idx,
- try M.Results.Dom.to_bounds elem with Tiny.Relational.BotEnv -> Format.eprintf "Issues exporting env %a to bounds: bottom!@." M.Results.Dom.fprint elem; assert false
- ) M.list
+ let module M = (val m : S) in
+ let bounds =
+ List.map
+ (fun (idx, elem) ->
+ ( idx,
+ try M.Results.Dom.to_bounds elem
+ with Tiny.Relational.BotEnv ->
+ Format.eprintf
+ "Issues exporting env %a to bounds: bottom!@."
+ M.Results.Dom.fprint
+ elem;
+ assert false ))
+ M.list
in
(* Gather all variable ids *)
- let pp_vctx fmt ((n,t), ctx ) =
+ let pp_vctx fmt ((n, t), ctx) =
match ctx with
- | None -> Format.fprintf fmt "%s,%a,," n (Tiny.Ast.pp_base_type) t
- | Some ((bname,_ (* type should be bool *) ), bval) ->
- Format.fprintf fmt "%s,%a,%s,%b" n (Tiny.Ast.pp_base_type) t bname bval
+ | None ->
+ Format.fprintf fmt "%s,%a,," n Tiny.Ast.pp_base_type t
+ | Some ((bname, _ (* type should be bool *)), bval) ->
+ Format.fprintf fmt "%s,%a,%s,%b" n Tiny.Ast.pp_base_type t bname bval
in
Format.fprintf fmt "timestep,varid,type,boolpart,boolval,min,max@.";
- Utils.Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@.") (
- fun fmt (idx, idx_bounds) ->
- Utils.Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@.") (fun fmt (vctx, vctx_bound) ->
- Format.fprintf fmt "%i,%a,%a" idx pp_vctx vctx Tiny.Bounds.pp vctx_bound
- ) fmt idx_bounds
- ) fmt bounds
-
-
+ Utils.Format.pp_print_list
+ ~pp_sep:(fun fmt () -> Format.fprintf fmt "@.")
+ (fun fmt (idx, idx_bounds) ->
+ Utils.Format.pp_print_list
+ ~pp_sep:(fun fmt () -> Format.fprintf fmt "@.")
+ (fun fmt (vctx, vctx_bound) ->
+ Format.fprintf
+ fmt
+ "%i,%a,%a"
+ idx
+ pp_vctx
+ vctx
+ Tiny.Bounds.pp
+ vctx_bound)
+ fmt
+ idx_bounds)
+ fmt
+ bounds
diff --git a/src/tools/tiny/tiny_utils.ml b/src/tools/tiny/tiny_utils.ml
index 68c5c4d8..055d766d 100644
--- a/src/tools/tiny/tiny_utils.ml
+++ b/src/tools/tiny/tiny_utils.ml
@@ -1,36 +1,33 @@
let report = Log.report ~plugin:"tiny"
-
module Ast = Tiny.Ast
let gen_loc () = Tiny.Location.dummy ()
let lloc_to_tloc loc =
- Tiny.Location.location_of_positions
- (Location.start_ loc)
- (Location.end_ loc)
+ Tiny.Location.location_of_positions (Location.start_ loc) (Location.end_ loc)
let tloc_to_lloc loc = assert false
(*Location.dummy_loc (*TODO*) *)
-
let rec ltyp_to_ttyp t =
- if Types.is_tuple_type t then
+ if Types.is_tuple_type t then (
match Types.type_list_of_type t with
- | [t] -> ltyp_to_ttyp t
- | _ -> (
- Format.eprintf "Issues converting type %a to a Tiny datatype@.@?" Types.pp t;
- assert false (* not covered yet *)
- )
- else
- if Types.is_real_type t then Tiny.Ast.RealT
+ | [ t ] ->
+ ltyp_to_ttyp t
+ | _ ->
+ Format.eprintf
+ "Issues converting type %a to a Tiny datatype@.@?"
+ Types.pp
+ t;
+ assert false (* not covered yet *))
+ else if Types.is_real_type t then Tiny.Ast.RealT
else if Types.is_int_type t then Tiny.Ast.IntT
else if Types.is_bool_type t then Tiny.Ast.BoolT
else (
Format.eprintf "Issues converting type %a to a Tiny datatype@.@?" Types.pp t;
- assert false (* not covered yet *)
- )
-
+ assert false (* not covered yet *))
+
let cst_bool loc b =
{
Ast.expr_desc =
@@ -42,13 +39,11 @@ let cst_bool loc b =
let cst_num loc t q =
let s = Q.to_string q in
- let s = if t = Tiny.Ast.RealT && Z.equal (Q.den q) Z.one then s ^ "."
- else s in
-{ Ast.expr_desc =
- Ast.Cst(q, s);
- expr_loc = loc;
- expr_type = t }
-
+ let s =
+ if t = Tiny.Ast.RealT && Z.equal (Q.den q) Z.one then s ^ "." else s
+ in
+ { Ast.expr_desc = Ast.Cst (q, s); expr_loc = loc; expr_type = t }
+
let rec real_to_q man exp =
if exp = 0 then Q.of_string (Num.string_of_num man)
else if exp > 0 then Q.div (real_to_q man (exp - 1)) (Q.of_int 10)
@@ -57,216 +52,253 @@ let rec real_to_q man exp =
let instr_loc i =
match i.Machine_code_types.lustre_eq with
- | None -> gen_loc ()
- | Some eq -> lloc_to_tloc eq.eq_loc
+ | None ->
+ gen_loc ()
+ | Some eq ->
+ lloc_to_tloc eq.eq_loc
+let build_expr d v = Ast.{ expr_desc = d; expr_loc = gen_loc (); expr_type = v }
+let cst_false = Ast.Cst (Q.zero, "false")
+let cst_true = Ast.Cst (Q.one, "true")
-let build_expr d v =
- Ast.{ expr_desc = d;
- expr_loc = gen_loc ();
- expr_type = v }
-
-let cst_false = Ast.Cst (Q.zero, "false")
-let cst_true = Ast.Cst (Q.one, "true")
-
-
let rec lval_to_texpr m loc _val =
- Format.eprintf "lval_to_texpr %a (type %a)@." (Machine_code_common.pp_val m) _val Types.pp _val.value_type;
- let res =
- let build = build_expr in
- let new_desc =
- match _val.Machine_code_types.value_desc with
- | Machine_code_types.Cst cst -> (
- match cst with
- Lustre_types.Const_int n -> Ast.Cst (Q.of_int n, string_of_int n)
- | Const_real r -> Ast.Cst (Real.to_q r, Real.to_string r)
- | Const_tag "true" -> cst_true
- | Const_tag "false" -> cst_false
- | _ -> Format.eprintf "No tiny translation for constant %a@.@?"
- (Machine_code_common.pp_val m) _val; assert false
- )
-
- | Var v -> Ast.Var (v.var_id)
- | Fun (op, vl) ->
- let t_arg = match vl with (* t_arg denotes the type of first argument. *)
- | hd::_ -> ltyp_to_ttyp hd.value_type
- | _ -> assert false
- in
- (
- match op, List.map (lval_to_texpr m loc) vl with
- | "+", [v1;v2] -> Ast.Binop (Ast.Plus, v1, v2)
- | "-", [v1;v2] -> Ast.Binop (Ast.Minus, v1, v2)
- | "*", [v1;v2] -> Ast.Binop (Ast.Times, v1, v2)
- | "/", [v1;v2] -> Ast.Binop (Ast.Div, v1, v2)
- | "<", [v1;v2] ->
- Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Strict)
- | "<=", [v1;v2] ->
- Ast.Cond (build(Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Loose)
- | ">", [v1;v2] ->
- Ast.Cond (build(Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Strict)
- | ">=", [v1;v2] ->
- Ast.Cond (build (Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Loose)
- | "uminus", [v1] -> Ast.Binop (Ast.Minus, cst_num loc t_arg Q.zero, v1)
- (* | "=", [v1;v2] when v1.xxxtype != BoolT (\* if arguments are numerical then basic comparison *\)
- * Ast.Cond (build (Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Loose)
- * Ast.Binop (Ast.Eq, v1, v2) *)
- | "=", [v1;v2]
- | "equi", [v1;v2] -> Ast.Binop (Ast.Eq, v1, v2)
-
- | "!=", [v1;v2] -> Ast.Unop (Ast.Not, build (Ast.Binop (Ast.Eq, v1, v2)) Ast.BoolT)
- | "not", [v1] -> Ast.Unop (Ast.Not, v1)
- | "&&", [v1;v2] -> Ast.Binop (Ast.And, v1, v2)
- | "||", [v1;v2] -> Ast.Binop (Ast.Or, v1, v2)
- | "impl", [v1;v2] ->
- let neg_v1 = Ast.neg_guard v1 in
- Ast.Binop (Ast.Or, neg_v1, v2)
-
- | _ -> Format.eprintf "No tiny translation for operator %s@.@?" op; assert false
- )
- | _ -> assert false (* no array. access or power *)
- in
- build new_desc (ltyp_to_ttyp _val.value_type)
+ Format.eprintf
+ "lval_to_texpr %a (type %a)@."
+ (Machine_code_common.pp_val m)
+ _val
+ Types.pp
+ _val.value_type;
+ let res =
+ let build = build_expr in
+ let new_desc =
+ match _val.Machine_code_types.value_desc with
+ | Machine_code_types.Cst cst -> (
+ match cst with
+ | Lustre_types.Const_int n ->
+ Ast.Cst (Q.of_int n, string_of_int n)
+ | Const_real r ->
+ Ast.Cst (Real.to_q r, Real.to_string r)
+ | Const_tag "true" ->
+ cst_true
+ | Const_tag "false" ->
+ cst_false
+ | _ ->
+ Format.eprintf
+ "No tiny translation for constant %a@.@?"
+ (Machine_code_common.pp_val m)
+ _val;
+ assert false)
+ | Var v ->
+ Ast.Var v.var_id
+ | Fun (op, vl) -> (
+ let t_arg =
+ match vl with
+ (* t_arg denotes the type of first argument. *)
+ | hd :: _ ->
+ ltyp_to_ttyp hd.value_type
+ | _ ->
+ assert false
+ in
+ match op, List.map (lval_to_texpr m loc) vl with
+ | "+", [ v1; v2 ] ->
+ Ast.Binop (Ast.Plus, v1, v2)
+ | "-", [ v1; v2 ] ->
+ Ast.Binop (Ast.Minus, v1, v2)
+ | "*", [ v1; v2 ] ->
+ Ast.Binop (Ast.Times, v1, v2)
+ | "/", [ v1; v2 ] ->
+ Ast.Binop (Ast.Div, v1, v2)
+ | "<", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Strict)
+ | "<=", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Loose)
+ | ">", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Strict)
+ | ">=", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Loose)
+ | "uminus", [ v1 ] ->
+ Ast.Binop (Ast.Minus, cst_num loc t_arg Q.zero, v1)
+ (* | "=", [v1;v2] when v1.xxxtype != BoolT (\* if arguments are numerical then basic comparison *\)
+ * Ast.Cond (build (Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Loose)
+ * Ast.Binop (Ast.Eq, v1, v2) *)
+ | "=", [ v1; v2 ] | "equi", [ v1; v2 ] ->
+ Ast.Binop (Ast.Eq, v1, v2)
+ | "!=", [ v1; v2 ] ->
+ Ast.Unop (Ast.Not, build (Ast.Binop (Ast.Eq, v1, v2)) Ast.BoolT)
+ | "not", [ v1 ] ->
+ Ast.Unop (Ast.Not, v1)
+ | "&&", [ v1; v2 ] ->
+ Ast.Binop (Ast.And, v1, v2)
+ | "||", [ v1; v2 ] ->
+ Ast.Binop (Ast.Or, v1, v2)
+ | "impl", [ v1; v2 ] ->
+ let neg_v1 = Ast.neg_guard v1 in
+ Ast.Binop (Ast.Or, neg_v1, v2)
+ | _ ->
+ Format.eprintf "No tiny translation for operator %s@.@?" op;
+ assert false)
+ | _ ->
+ assert false
+ (* no array. access or power *)
+ in
+ build new_desc (ltyp_to_ttyp _val.value_type)
in
- Format.eprintf "DONE lval_to_texpr %a = %a@." (Machine_code_common.pp_val m) _val Ast.fprint_expr res;
+ Format.eprintf
+ "DONE lval_to_texpr %a = %a@."
+ (Machine_code_common.pp_val m)
+ _val
+ Ast.fprint_expr
+ res;
res
- (*
-let machine_init_to_ast m =
- let build_reset i =
- match i.Machine_code_types.instr_desc with
- | MReset id ->
-
- | _ -> Format.eprintf "Init instr: %a@." (Machine_code_common.pp_instr m) i; assert false
- in
-build_seq build_reset m.Machine_code_types.minit
- *)
+(* let machine_init_to_ast m = let build_reset i = match
+ i.Machine_code_types.instr_desc with | MReset id ->
+
+ | _ -> Format.eprintf "Init instr: %a@." (Machine_code_common.pp_instr m) i;
+ assert false in build_seq build_reset m.Machine_code_types.minit *)
let rec find_init m il =
- List.fold_left (fun res i ->
+ List.fold_left
+ (fun res i ->
match res with
- | Some _ -> res
+ | Some _ ->
+ res
| _ -> (
match i.Machine_code_types.instr_desc with
- | MLocalAssign _ | MStateAssign _ | MClearReset | MSetReset _| MResetAssign _ | MNoReset _| MComment _|MSpec _
- -> None
+ | MLocalAssign _
+ | MStateAssign _
+ | MClearReset
+ | MSetReset _
+ | MResetAssign _
+ | MNoReset _
+ | MComment _
+ | MSpec _ ->
+ None
| MStep (ol, id, args) ->
- if List.mem_assoc id m.Machine_code_types.minstances then
- let fun_name, _ = List.assoc id m.minstances in
- match Corelang.node_name fun_name, ol with
- | "_arrow", [o] -> Some o.var_id
- | _ -> None
- else
- None
+ if List.mem_assoc id m.Machine_code_types.minstances then
+ let fun_name, _ = List.assoc id m.minstances in
+ match Corelang.node_name fun_name, ol with
+ | "_arrow", [ o ] ->
+ Some o.var_id
+ | _ ->
+ None
+ else None
| MBranch (_, guarded_expr) ->
- List.fold_left (
- fun res (_, il') ->
- match res with Some _ -> res | None -> find_init m il'
- ) res guarded_expr
- )
- )
- None il
-
+ List.fold_left
+ (fun res (_, il') ->
+ match res with Some _ -> res | None -> find_init m il')
+ res
+ guarded_expr))
+ None
+ il
+
let machine_body_to_ast init m =
let init_var = find_init m m.Machine_code_types.mstep.step_instrs in
- let rec instrl_to_stm il =
+ let rec instrl_to_stm il =
match il with
- [] -> assert false
- | [i] -> instr_to_stm i
- | i::il -> Ast.Seq (gen_loc (), instr_to_stm i, instrl_to_stm il)
-
-
+ | [] ->
+ assert false
+ | [ i ] ->
+ instr_to_stm i
+ | i :: il ->
+ Ast.Seq (gen_loc (), instr_to_stm i, instrl_to_stm il)
and guarded_expr_to_stm loc te guarded_instrs =
match guarded_instrs with
- | [] -> assert false
- | [_,il] -> instrl_to_stm il
- | (label, il)::tl ->
- let stmt = instrl_to_stm il in
- let guard= match label with
- "true" -> te
- | "false" -> Ast.neg_guard te
- | _ -> assert false (* TODO: don't deal with non boolean
- guards. Could just treturn true and
- over-approximate behavior *)
- in
- if (match init_var, te.Ast.expr_desc with
- | Some v, Var v2 ->
- (* Format.eprintf "Building init (possibly if %b)@." (v=v2); *)v = v2
- | _ ->
- (* Format.eprintf "Building if init def? %b @." (match init_var with None -> false | _ -> true);
- *)
- false
- )
- then
- instrl_to_stm (
- if init then
- (List.assoc "true" guarded_instrs)
- else
- (List.assoc "false" guarded_instrs)
- )
- else
- Ast.Ite (loc, guard, stmt, guarded_expr_to_stm loc te tl)
+ | [] ->
+ assert false
+ | [ (_, il) ] ->
+ instrl_to_stm il
+ | (label, il) :: tl ->
+ let stmt = instrl_to_stm il in
+ let guard =
+ match label with
+ | "true" ->
+ te
+ | "false" ->
+ Ast.neg_guard te
+ | _ ->
+ assert false
+ (* TODO: don't deal with non boolean guards. Could just treturn true and
+ over-approximate behavior *)
+ in
+ if
+ match init_var, te.Ast.expr_desc with
+ | Some v, Var v2 ->
+ (* Format.eprintf "Building init (possibly if %b)@." (v=v2); *) v = v2
+ | _ ->
+ (* Format.eprintf "Building if init def? %b @." (match init_var with
+ None -> false | _ -> true); *)
+ false
+ then
+ instrl_to_stm
+ (if init then List.assoc "true" guarded_instrs
+ else List.assoc "false" guarded_instrs)
+ else Ast.Ite (loc, guard, stmt, guarded_expr_to_stm loc te tl)
and instr_to_stm i =
let loc = instr_loc i in
match i.instr_desc with
| MLocalAssign (v, e) | MStateAssign (v, e) ->
- Ast.Asn (loc, v.var_id, (lval_to_texpr m loc) e)
- | MBranch (e, guarded_instrs) -> (
+ Ast.Asn (loc, v.var_id, (lval_to_texpr m loc) e)
+ | MBranch (e, guarded_instrs) ->
let te = lval_to_texpr m loc e in
guarded_expr_to_stm loc te guarded_instrs
- )
- | MStep (ol, id, args) ->
- if List.mem_assoc id m.Machine_code_types.minstances then
- let fun_name, _ = List.assoc id m.minstances in
- match Corelang.node_name fun_name, ol with
- | "_arrow", [o] -> (
- (* init_var := Some o.var_id; *)
- (* In Lelio's code: Just produce a Ast.Nop loc. XXX TODO check which version is appropriate *)
- Ast.Asn (loc, o.var_id, build_expr (if init then cst_true else cst_false) Ast.BoolT);
- (* We set the arrow to
- false: we are not anymore
- in init state *)
- (* Format.eprintf "%a = arrow()@." Printers.pp_var o;*)
- (* Ast.Nop (loc); *)
- (* Ast.Asn (loc, o.var_id,
- * { expr_desc = if init then Ast.Cst(Q.of_int 1, "true") else Ast.Cst(Q.of_int 0, "false");
- * expr_loc = loc;
- * expr_type = Ast.BoolT }
- * ) *)
- )
- | name, _ ->
- (
- Format.eprintf "No tiny translation for stateful node call %s@.@?" name;
- assert false
- )
- else (
- (* Converting basic library functions *)
- match id, List.map (lval_to_texpr m loc) args, ol with
- | ("sin"| "cos" | "sqrt" | "exp" | "ln" | "atan" | "tan" | "tanh"), [x], [o] ->
- Ast.Asn (loc, o.var_id, build_expr (Ast.Call (id, [x])) Ast.RealT)
- | _ ->
- Format.eprintf "No tiny translation for function call %s@.@?" id;
- assert false
- )
-
+ | MStep (ol, id, args) -> (
+ if List.mem_assoc id m.Machine_code_types.minstances then (
+ let fun_name, _ = List.assoc id m.minstances in
+ match Corelang.node_name fun_name, ol with
+ | "_arrow", [ o ] ->
+ (* init_var := Some o.var_id; *)
+ (* In Lelio's code: Just produce a Ast.Nop loc. XXX TODO check which
+ version is appropriate *)
+ Ast.Asn
+ ( loc,
+ o.var_id,
+ build_expr (if init then cst_true else cst_false) Ast.BoolT )
+ (* We set the arrow to false: we are not anymore in init state *)
+ (* Format.eprintf "%a = arrow()@." Printers.pp_var o;*)
+ (* Ast.Nop (loc); *)
+ (* Ast.Asn (loc, o.var_id,
+ * { expr_desc = if init then Ast.Cst(Q.of_int 1, "true") else Ast.Cst(Q.of_int 0, "false");
+ * expr_loc = loc;
+ * expr_type = Ast.BoolT }
+ * ) *)
+ | name, _ ->
+ Format.eprintf
+ "No tiny translation for stateful node call %s@.@?"
+ name;
+ assert false)
+ else
+ (* Converting basic library functions *)
+ match id, List.map (lval_to_texpr m loc) args, ol with
+ | ( ("sin" | "cos" | "sqrt" | "exp" | "ln" | "atan" | "tan" | "tanh"),
+ [ x ],
+ [ o ] ) ->
+ Ast.Asn (loc, o.var_id, build_expr (Ast.Call (id, [ x ])) Ast.RealT)
+ | _ ->
+ Format.eprintf "No tiny translation for function call %s@.@?" id;
+ assert false)
| MResetAssign _ | MClearReset | MSetReset _ | MNoReset _ ->
assert false (* no more calls or functions, ie. no reset *)
| MComment s | MSpec s ->
- assert false
- in
+ assert false
+ in
instrl_to_stm m.Machine_code_types.mstep.step_instrs
let read_var bounds_opt v =
let min, max =
match bounds_opt with
- Some (min,max) -> min, max
+ | Some (min, max) ->
+ min, max
| None ->
- let one, minus_one =
- match Types.is_real_type v.Lustre_types.var_type with
- | true -> "1.", "-1."
- | false -> "1", "-1"
-
- in
- (Q.of_int (-1), minus_one), (Q.of_int 1, one)
+ let one, minus_one =
+ match Types.is_real_type v.Lustre_types.var_type with
+ | true ->
+ "1.", "-1."
+ | false ->
+ "1", "-1"
+ in
+
+ (Q.of_int (-1), minus_one), (Q.of_int 1, one)
in
let range =
{
@@ -299,26 +331,26 @@ let rec read_vars bounds_inputs vl =
let machine_to_ast bounds_input m =
let read_vars =
- read_vars bounds_input m.Machine_code_types.mstep.step_inputs in
+ read_vars bounds_input m.Machine_code_types.mstep.step_inputs
+ in
(* let ast_init = machine_init_to_ast m in *)
let ast_loop_first = machine_body_to_ast true m in
let ast_loop_run = machine_body_to_ast false m in
let ast_loop_body = Ast.Seq (gen_loc (), read_vars, ast_loop_run) in
- let loop = Ast.While(gen_loc (), cst_bool (gen_loc ()) true, ast_loop_body) in
+ let loop =
+ Ast.While (gen_loc (), cst_bool (gen_loc ()) true, ast_loop_body)
+ in
(* Ast.Seq (gen_loc(),
* ast_init, *)
- Ast.Seq (gen_loc (), read_vars,
- Ast.Seq (gen_loc (),
- ast_loop_first,
- loop))
- (* ) *)
-
+ Ast.Seq (gen_loc (), read_vars, Ast.Seq (gen_loc (), ast_loop_first, loop))
+(* ) *)
+
let machine_to_env m =
- List.fold_left (fun accu v ->
- report ~level:3 (fun fmt -> Format.fprintf fmt "Adding variable %a to env@." Printers.pp_var v);
- let typ =
- ltyp_to_ttyp (v.Lustre_types.var_type)
- in
+ List.fold_left
+ (fun accu v ->
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "Adding variable %a to env@." Printers.pp_var v);
+ let typ = ltyp_to_ttyp v.Lustre_types.var_type in
Ast.Var.Set.add (v.var_id, typ) accu)
Ast.Var.Set.empty
(Machine_code_common.machine_vars m)
diff --git a/src/tools/tiny/tiny_utils.mli b/src/tools/tiny/tiny_utils.mli
index 8a89515d..8c111f6b 100644
--- a/src/tools/tiny/tiny_utils.mli
+++ b/src/tools/tiny/tiny_utils.mli
@@ -1,6 +1,9 @@
-val report: ?verbose_level:int ->
- level:int -> (Format.formatter -> unit) -> unit
+val report :
+ ?verbose_level:int -> level:int -> (Format.formatter -> unit) -> unit
val machine_to_env : Machine_code_types.machine_t -> Tiny.Ast.Var.Set.t
-val machine_to_ast: (string * ((Q.t * string) * (Q.t * string))) list -> Machine_code_types.machine_t -> Tiny.Ast.stm
-
+
+val machine_to_ast :
+ (string * ((Q.t * string) * (Q.t * string))) list ->
+ Machine_code_types.machine_t ->
+ Tiny.Ast.stm
diff --git a/src/tools/tiny/tiny_verifier.ml b/src/tools/tiny/tiny_verifier.ml
index 4709a8ab..b10405e5 100644
--- a/src/tools/tiny/tiny_verifier.ml
+++ b/src/tools/tiny/tiny_verifier.ml
@@ -1,17 +1,14 @@
let active = ref false
-
let tiny_debug = ref false
-
let tiny_help = ref false
-
let descending = ref 1
let unrolling = ref 0
let output = ref false
let reachtube = ref false (* used to produce a list of set iterates *)
-
+
let quiet () = Tiny.Report.verbosity := 0
let report = Tiny_utils.report
-
+
let print_tiny_help () =
let open Format in
Format.eprintf
@@ -49,8 +46,10 @@ let tiny_run ~basename prog machines =
s)
in
let m = Machine_code_common.get_machine machines node_name in
- let env = (* We add each variables of the node the Tiny env *)
- Tiny_utils.machine_to_env m in
+ let env =
+ (* We add each variables of the node the Tiny env *)
+ Tiny_utils.machine_to_env m
+ in
(*let nd = m.mname in*)
(* Building preamble with some bounds on inputs *)
(* TODO: deal woth contracts, asserts, ... *)
@@ -58,108 +57,120 @@ let tiny_run ~basename prog machines =
let ast = Tiny_utils.machine_to_ast bounds_inputs m in
(* let mems = m.mmemory in *)
if !output then (
- let destname = !Options.dest_dir ^ "/" ^ basename ^ "_" ^ node_name ^ ".tiny" in
- report ~level:2 (fun fmt -> Format.fprintf fmt "Exporting resulting tiny source as %s@ " destname);
+ let destname =
+ !Options.dest_dir ^ "/" ^ basename ^ "_" ^ node_name ^ ".tiny"
+ in
+ report ~level:2 (fun fmt ->
+ Format.fprintf fmt "Exporting resulting tiny source as %s@ " destname);
let out = open_out destname in
let fmt = Format.formatter_of_out_channel out in
- Format.fprintf fmt "%a@." Tiny.Ast.Var.Set.pp env;
- Format.fprintf fmt "%a@." Tiny.Ast.fprint_stm ast;
- close_out out;
-
-
- );
- report ~level:1 (fun fmt -> Format.fprintf fmt "%a@." Tiny.Ast.fprint_stm ast);
-
+ Format.fprintf fmt "%a@." Tiny.Ast.Var.Set.pp env;
+ Format.fprintf fmt "%a@." Tiny.Ast.fprint_stm ast;
+ close_out out);
+ report ~level:1 (fun fmt -> Format.fprintf fmt "%a@." Tiny.Ast.fprint_stm ast);
+
let dom =
let open Tiny.Load_domains in
prepare_domains (List.map get_domain !domains)
in
- let results = Tiny.Analyze.analyze
- dom
- (not !reachtube) (* when this argument is false, a
- simulation is performed*)
- !descending
- !unrolling
- env
- ast
+ let results =
+ Tiny.Analyze.analyze
+ dom
+ (not !reachtube)
+ (* when this argument is false, a simulation is performed*)
+ !descending
+ !unrolling
+ env
+ ast
in
(* if !Tiny.Report.verbosity > 1 then *)
if !reachtube then (
(* Print preamble *)
report ~level:1 (Tiny_tube.export_to_csv env ast results);
(* We produce in a folder: the csv file, the tiny file *)
- let destname = !Options.dest_dir ^ "/" ^ basename ^ "_" ^ node_name ^ ".csv" in
- report ~level:1 (fun fmt -> Format.fprintf fmt "Exporting resulting tube as %s@ " destname);
+ let destname =
+ !Options.dest_dir ^ "/" ^ basename ^ "_" ^ node_name ^ ".csv"
+ in
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "Exporting resulting tube as %s@ " destname);
let out = open_out destname in
let fmt = Format.formatter_of_out_channel out in
- Format.fprintf fmt "%t@." (Tiny_tube.export_to_csv env ast results);
- close_out out;
-
- )
+ Format.fprintf fmt "%t@." (Tiny_tube.export_to_csv env ast results);
+ close_out out)
else
- let module Results = (val results: Tiny.Analyze.Results) in
+ let module Results = (val results : Tiny.Analyze.Results) in
let module Dom = Results.Dom in
let module PrintResults = Tiny.PrintResults.Make (Dom) in
let m = Results.results in
- report ~level:1 (PrintResults.print m env ast)
- (* no !output_file *);
- (* else PrintResults.print_invariants m ast !output_file *)
+ report ~level:1 (PrintResults.print m env ast) (* no !output_file *);
+ (* else PrintResults.print_invariants m ast !output_file *)
()
-
-
-module Verifier =
- (struct
- include VerifierType.Default
- (* Enforce global inline from top node *)
- let get_normalization_params () =
- Options.global_inline := true;
- get_normalization_params ()
-
- let name = "tiny"
- let options =
- [
- "-debug", Arg.Set tiny_debug, "tiny debug";
- ("-abstract-domain", Arg.String Tiny.Load_domains.decl_domain,
- "<domain> Use abstract domain <domain> " ^ Tiny.Domains.available_domains_str);
- (* ("-a", Arg.String Tiny.Load_domains.decl_domain,
- * "<domain> Use abstract domain <domain> " ^ Tiny.Domains.available_domains_str); *)
- ("-param", Arg.String Tiny.Load_domains.set_param,
- "<p> Send <p> to the abstract domain, syntax <dom>:<p> can be used \
- to target the (sub)domain <dom>");
- (* ("-p", Arg.String Tiny.Load_domains.set_param,
- * "<p> Send <p> to the abstract domain, syntax <dom>:<p> can be used \
- * to target the (sub)domain <dom>"); *)
- ("-help-domain", Arg.String Tiny.Load_domains.help_domain,
- "<domain> Print params of <domain>");
- (* ("-h", Arg.String Tiny.Load_domains.help_domain, "<domain> Print params of <domain>"); *)
- (* ("--compile", Arg.Set compile_mode, " Compilation mode: compile to C");
- ("-c", Arg.Set compile_mode, " Compilation mode: compile to C");*)
-
- ("-quiet", Arg.Unit quiet, " Quiet mode");
- (* ("-q", Arg.Unit quiet, " Quiet mode"); *)
- ("-verbose", Arg.Set_int Tiny.Report.verbosity,
- "<n> Verbosity level (default is 1)");
- (* ("-v", Arg.Set_int Tiny.Report.verbosity, "<n> Verbosity level (default is 1)"); *)
- (* ("--output", Arg.String set_output_file,
- "<filename> Output results to file <filename> (default is \
- standard ouput)");
- ("-o", Arg.String set_output_file,
- "<filename> Output results to file <filename> (default is standard ouput)");
- *)
- ("-descending", Arg.Set_int descending,
- "<n> Perform <n> descending iterations after fixpoint of a loop \
- is reached (default is 1)");
- (* ("-d", Arg.Set_int descending,
- * "<n> Perform <n> descending iterations after fixpoint of a loop \
- * is reached (default is 1)"); *)
- ("-unrolling", Arg.Set_int unrolling,
- "<n> Unroll loops <n> times before computing fixpoint (default is 0)");
- ("-reachtube", Arg.Int (fun n -> unrolling :=n; reachtube:=true),
- "<n> Unroll main loop <n> times to compute finite horizon analysis (default is invariant, with 0)");
- ("-output", Arg.Set output,
- "<n> Export resulting tiny file as <name>_<mainnode>.tiny");
+module Verifier = struct
+ include VerifierType.Default
+
+ (* Enforce global inline from top node *)
+ let get_normalization_params () =
+ Options.global_inline := true;
+ get_normalization_params ()
+
+ let name = "tiny"
+
+ let options =
+ [
+ "-debug", Arg.Set tiny_debug, "tiny debug";
+ ( "-abstract-domain",
+ Arg.String Tiny.Load_domains.decl_domain,
+ "<domain> Use abstract domain <domain> "
+ ^ Tiny.Domains.available_domains_str );
+ (* ("-a", Arg.String Tiny.Load_domains.decl_domain,
+ * "<domain> Use abstract domain <domain> " ^ Tiny.Domains.available_domains_str); *)
+ ( "-param",
+ Arg.String Tiny.Load_domains.set_param,
+ "<p> Send <p> to the abstract domain, syntax <dom>:<p> can be used to \
+ target the (sub)domain <dom>" );
+ (* ("-p", Arg.String Tiny.Load_domains.set_param,
+ * "<p> Send <p> to the abstract domain, syntax <dom>:<p> can be used \
+ * to target the (sub)domain <dom>"); *)
+ ( "-help-domain",
+ Arg.String Tiny.Load_domains.help_domain,
+ "<domain> Print params of <domain>" );
+ (* ("-h", Arg.String Tiny.Load_domains.help_domain, "<domain> Print params
+ of <domain>"); *)
+ (* ("--compile", Arg.Set compile_mode, " Compilation mode: compile to C");
+ ("-c", Arg.Set compile_mode, " Compilation mode: compile to C");*)
+ "-quiet", Arg.Unit quiet, " Quiet mode";
+ (* ("-q", Arg.Unit quiet, " Quiet mode"); *)
+ ( "-verbose",
+ Arg.Set_int Tiny.Report.verbosity,
+ "<n> Verbosity level (default is 1)" );
+ (* ("-v", Arg.Set_int Tiny.Report.verbosity, "<n> Verbosity level (default
+ is 1)"); *)
+ (* ("--output", Arg.String set_output_file, "<filename> Output results to
+ file <filename> (default is \ standard ouput)"); ("-o", Arg.String
+ set_output_file, "<filename> Output results to file <filename> (default
+ is standard ouput)"); *)
+ ( "-descending",
+ Arg.Set_int descending,
+ "<n> Perform <n> descending iterations after fixpoint of a loop is \
+ reached (default is 1)" );
+ (* ("-d", Arg.Set_int descending,
+ * "<n> Perform <n> descending iterations after fixpoint of a loop \
+ * is reached (default is 1)"); *)
+ ( "-unrolling",
+ Arg.Set_int unrolling,
+ "<n> Unroll loops <n> times before computing fixpoint (default is 0)" );
+ ( "-reachtube",
+ Arg.Int
+ (fun n ->
+ unrolling := n;
+ reachtube := true),
+ "<n> Unroll main loop <n> times to compute finite horizon analysis \
+ (default is invariant, with 0)" );
+ ( "-output",
+ Arg.Set output,
+ "<n> Export resulting tiny file as <name>_<mainnode>.tiny" );
(* (\* ("-u", Arg.Set_int unrolling,
* * "<n> Unroll loops <n> times before computing fixpoint (default is 0)"); *\) *)
"-help", Arg.Set tiny_help, "tiny help and usage";
@@ -173,11 +184,9 @@ module Verifier =
()
let is_active () = !active
-
let run = tiny_run
- end
- )
-
+end
+
let () =
VerifierList.registered :=
(module Verifier : VerifierType.S) :: !VerifierList.registered
diff --git a/src/tools/zustre/zustre_analyze.ml b/src/tools/zustre/zustre_analyze.ml
index fabd567f..4818f02b 100644
--- a/src/tools/zustre/zustre_analyze.ml
+++ b/src/tools/zustre/zustre_analyze.ml
@@ -10,7 +10,6 @@ open Zustre_common
open Zustre_data
let idx_0 = Z3.Arithmetic.Integer.mk_numeral_i !ctx 0
-
let uid_0 = Z3.Z3List.nil uid_sort
let check machines node =
diff --git a/src/tools/zustre/zustre_analyze.mli b/src/tools/zustre/zustre_analyze.mli
index 4743324d..e7115fa4 100644
--- a/src/tools/zustre/zustre_analyze.mli
+++ b/src/tools/zustre/zustre_analyze.mli
@@ -1 +1 @@
-val check: Machine_code_types.machine_t list -> Utils.ident -> unit
+val check : Machine_code_types.machine_t list -> Utils.ident -> unit
diff --git a/src/tools/zustre/zustre_cex.ml b/src/tools/zustre/zustre_cex.ml
index afd0d66f..8de31786 100644
--- a/src/tools/zustre/zustre_cex.ml
+++ b/src/tools/zustre/zustre_cex.ml
@@ -94,8 +94,9 @@ let build_cex machine machines _decl_err =
Format.eprintf
"Id %i: %a@."
id
- (Utils.Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") (fun fmt e ->
- Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
+ (Utils.Format.pp_print_list
+ ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
+ (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
(fst expr))
main;
diff --git a/src/tools/zustre/zustre_cex.mli b/src/tools/zustre/zustre_cex.mli
index 4a82c164..13088b60 100644
--- a/src/tools/zustre/zustre_cex.mli
+++ b/src/tools/zustre/zustre_cex.mli
@@ -1,5 +1,5 @@
-val build_cex: Machine_code_types.machine_t (* machine *) ->
- Machine_code_types.machine_t list (* machines *) ->
- Z3.FuncDecl.func_decl (* _decl_err *) ->
- unit
-
+val build_cex :
+ Machine_code_types.machine_t (* machine *) ->
+ Machine_code_types.machine_t list (* machines *) ->
+ Z3.FuncDecl.func_decl (* _decl_err *) ->
+ unit
diff --git a/src/tools/zustre/zustre_common.ml b/src/tools/zustre/zustre_common.ml
index b4f073f7..4201a749 100644
--- a/src/tools/zustre/zustre_common.ml
+++ b/src/tools/zustre/zustre_common.ml
@@ -11,45 +11,25 @@ let report = Log.report ~plugin:"z3 interface"
module HBC = Horn_backend_common
let node_name = HBC.node_name
-
let concat = HBC.concat
-
let rename_machine = HBC.rename_machine
-
let rename_machine_list = HBC.rename_machine_list
-
let rename_next = HBC.rename_next
-
let rename_mid = HBC.rename_mid
-
let rename_current = HBC.rename_current
-
let rename_current_list = HBC.rename_current_list
-
let rename_mid_list = HBC.rename_mid_list
-
let rename_next_list = HBC.rename_next_list
-
let full_memory_vars = HBC.full_memory_vars
-
let inout_vars = HBC.inout_vars
-
let reset_vars = HBC.reset_vars
-
let step_vars = HBC.step_vars
-
let local_memory_vars = HBC.local_memory_vars
-
let step_vars_m_x = HBC.step_vars_m_x
-
let step_vars_c_m_x = HBC.step_vars_c_m_x
-
let machine_reset_name = HBC.machine_reset_name
-
let machine_step_name = HBC.machine_step_name
-
let machine_stateless_name = HBC.machine_stateless_name
-
let preprocess = Horn_backend.preprocess
exception UnknownFunction of (string * (Format.formatter -> unit))
@@ -61,13 +41,9 @@ exception UnknownFunction of (string * (Format.formatter -> unit))
with a enumerated type name. *)
let bool_sort = Z3.Boolean.mk_sort !ctx
-
let int_sort = Z3.Arithmetic.Integer.mk_sort !ctx
-
let real_sort = Z3.Arithmetic.Real.mk_sort !ctx
-
let get_const_sort = Hashtbl.find const_sorts
-
let get_sort_elems = Hashtbl.find sort_elems
let get_tag_sort id =
@@ -206,15 +182,10 @@ let decl_rel ?(no_additional_vars = false) name args_sorts =
(* Shared variables to describe counter and uid *)
let idx = Corelang.dummy_var_decl "__idx__" Type_predef.type_int
-
let idx_var = Z3.Expr.mk_const_f !ctx (decl_var idx)
-
let uid = Corelang.dummy_var_decl "__uid__" Type_predef.type_int
-
let uid_fd = Z3.FuncDecl.mk_func_decl_s !ctx "__uid__" [] uid_sort
-
let _ = register_fdecl "__uid__" uid_fd
-
let uid_var = Z3.Expr.mk_const_f !ctx uid_fd
(** Conversion functions
@@ -334,7 +305,9 @@ let horn_basic_app i vl (vltyp, typ) =
(%a) -> %a"
i
i
- (Utils.Format.pp_print_list ~pp_sep:Utils.Format.pp_print_comma Types.pp)
+ (Utils.Format.pp_print_list
+ ~pp_sep:Utils.Format.pp_print_comma
+ Types.pp)
vltyp
Types.pp
typ);
@@ -403,7 +376,9 @@ let rec horn_val_to_expr ?(is_lhs = false) m self v =
n
(List.map (horn_val_to_expr m self) vl)
(List.map (fun v -> v.value_type) vl, v.value_type)
- | ResetFlag -> assert false (* TODO *)
+ | ResetFlag ->
+ assert false
+(* TODO *)
let no_reset_to_exprs machines m i =
let n, _ = List.assoc i m.minstances in
@@ -579,15 +554,16 @@ let rec instr_to_exprs machines reset_instances (m : machine_t) instr :
[], reset_instances
| MNoReset i ->
(* we assign middle_mem with mem_m. And declare i as reset *)
- no_reset_to_exprs machines m i, i :: reset_instances
- | MClearReset -> assert false (* TODO *)
- | MSetReset _ -> assert false (* TODO *)
- | MResetAssign _ -> assert false (* TODO *)
- (* PRevious code was
- | MReset i ->
- (* we assign middle_mem with reset: reset(mem_m) *)
- instance_reset_to_exprs machines m i, i :: reset_instances
- *)
+ no_reset_to_exprs machines m i, i :: reset_instances
+ | MClearReset ->
+ assert false (* TODO *)
+ | MSetReset _ ->
+ assert false (* TODO *)
+ | MResetAssign _ ->
+ assert false (* TODO *)
+ (* PRevious code was | MReset i -> (* we assign middle_mem with reset:
+ reset(mem_m) *) instance_reset_to_exprs machines m i, i ::
+ reset_instances *)
| MLocalAssign (i, v) ->
assign_to_exprs m (mk_val (Var i) i.var_type) v, reset_instances
| MStateAssign (i, v) ->
@@ -717,8 +693,9 @@ let add_rule ?(dont_touch = []) vars expr =
Format.eprintf
"Declaring rule: %s with variables @[<v 0>@ [%a@ ]@]@ @."
(Z3.Expr.to_string expr)
- (Utils.Format.pp_print_list ~pp_sep:Utils.Format.pp_print_comma (fun fmt e ->
- Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
+ (Utils.Format.pp_print_list
+ ~pp_sep:Utils.Format.pp_print_comma
+ (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
(List.map horn_var_to_expr vars);
let expr =
Z3.Quantifier.mk_forall_const
diff --git a/src/tools/zustre/zustre_common.mli b/src/tools/zustre/zustre_common.mli
index 653df984..1381b6b0 100644
--- a/src/tools/zustre/zustre_common.mli
+++ b/src/tools/zustre/zustre_common.mli
@@ -1,38 +1,73 @@
-val bool_sort: Z3.Sort.sort
+val bool_sort : Z3.Sort.sort
val horn_const_to_expr : Lustre_types.constant -> Z3.Expr.expr
val horn_tag_to_expr : Lustre_types.label -> Z3.Expr.expr
-val get_fdecl: Utils.ident -> Z3.FuncDecl.func_decl
-val horn_basic_app: Utils.ident -> Z3.Expr.expr list -> Types.t list * Types.t -> Z3.Expr.expr
-val decl_sorts: unit -> unit
-val type_to_sort: Types.t -> Z3.Sort.sort
-val register_fdecl: Utils.ident -> Z3.FuncDecl.func_decl -> unit
-val uid_sort: Z3.Sort.sort
-val int_sort: Z3.Sort.sort
+val get_fdecl : Utils.ident -> Z3.FuncDecl.func_decl
-val full_memory_vars: ?without_arrow:bool -> Machine_code_types.machine_t list -> Machine_code_types.machine_t -> Lustre_types.var_decl list
+val horn_basic_app :
+ Utils.ident -> Z3.Expr.expr list -> Types.t list * Types.t -> Z3.Expr.expr
+
+val decl_sorts : unit -> unit
+val type_to_sort : Types.t -> Z3.Sort.sort
+val register_fdecl : Utils.ident -> Z3.FuncDecl.func_decl -> unit
+val uid_sort : Z3.Sort.sort
+val int_sort : Z3.Sort.sort
+
+val full_memory_vars :
+ ?without_arrow:bool ->
+ Machine_code_types.machine_t list ->
+ Machine_code_types.machine_t ->
+ Lustre_types.var_decl list
+
+val rename_machine_list :
+ Utils.ident -> Lustre_types.var_decl list -> Lustre_types.var_decl list
-val rename_machine_list : Utils.ident -> Lustre_types.var_decl list -> Lustre_types.var_decl list
val rename_next_list : Lustre_types.var_decl list -> Lustre_types.var_decl list
-val rename_current_list : Lustre_types.var_decl list -> Lustre_types.var_decl list
+
+val rename_current_list :
+ Lustre_types.var_decl list -> Lustre_types.var_decl list
exception UnknownFunction of (string * (Format.formatter -> unit))
-
-val decl_rel: ?no_additional_vars: bool -> Utils.ident (* name *) -> Z3.Sort.sort list (* args_sorts *) -> Z3.FuncDecl.func_decl
-val preprocess: Machine_code_types.machine_t list ->
- Machine_code_types.machine_t list
-
-val decl_machine: Machine_code_types.machine_t list -> Machine_code_types.machine_t -> unit
-val decl_var: Lustre_types.var_decl -> Z3.FuncDecl.func_decl
-
-val horn_var_to_expr: Lustre_types.var_decl -> Z3.Expr.expr
-val step_vars_m_x : Machine_code_types.machine_t list -> Machine_code_types.machine_t -> Lustre_types.var_decl list
-val step_vars_c_m_x : Machine_code_types.machine_t list -> Machine_code_types.machine_t -> Lustre_types.var_decl list
-val machine_reset_name: Utils.ident -> Utils.ident
-
-val machine_step_name: Utils.ident -> Utils.ident
+
+val decl_rel :
+ ?no_additional_vars:bool ->
+ Utils.ident (* name *) ->
+ Z3.Sort.sort list (* args_sorts *) ->
+ Z3.FuncDecl.func_decl
+
+val preprocess :
+ Machine_code_types.machine_t list -> Machine_code_types.machine_t list
+
+val decl_machine :
+ Machine_code_types.machine_t list -> Machine_code_types.machine_t -> unit
+
+val decl_var : Lustre_types.var_decl -> Z3.FuncDecl.func_decl
+val horn_var_to_expr : Lustre_types.var_decl -> Z3.Expr.expr
+
+val step_vars_m_x :
+ Machine_code_types.machine_t list ->
+ Machine_code_types.machine_t ->
+ Lustre_types.var_decl list
+
+val step_vars_c_m_x :
+ Machine_code_types.machine_t list ->
+ Machine_code_types.machine_t ->
+ Lustre_types.var_decl list
+
+val machine_reset_name : Utils.ident -> Utils.ident
+val machine_step_name : Utils.ident -> Utils.ident
+
(*val pp_machine_stateless_name : Format.formatter -> Utils.ident -> unit*)
-val machine_stateless_name: Utils.ident -> Utils.ident
+val machine_stateless_name : Utils.ident -> Utils.ident
+
+val add_rule :
+ ?dont_touch:'a list -> Lustre_types.var_decl list -> Z3.Expr.expr -> unit
+
+val reset_vars :
+ Machine_code_types.machine_t list ->
+ Machine_code_types.machine_t ->
+ Lustre_types.var_decl list
-val add_rule: ?dont_touch: 'a list -> Lustre_types.var_decl list -> Z3.Expr.expr -> unit
-val reset_vars : Machine_code_types.machine_t list -> Machine_code_types.machine_t -> Lustre_types.var_decl list
-val step_vars : Machine_code_types.machine_t list -> Machine_code_types.machine_t -> Lustre_types.var_decl list
+val step_vars :
+ Machine_code_types.machine_t list ->
+ Machine_code_types.machine_t ->
+ Lustre_types.var_decl list
diff --git a/src/tools/zustre/zustre_data.ml b/src/tools/zustre/zustre_data.ml
index a54a1656..c582161d 100644
--- a/src/tools/zustre/zustre_data.ml
+++ b/src/tools/zustre/zustre_data.ml
@@ -1,21 +1,10 @@
let ctx = ref (Z3.mk_context [])
-
let fp = ref (Z3.Fixedpoint.mk_fixedpoint !ctx)
-
-let const_sorts : (Utils.ident, Z3.Sort.sort) Hashtbl.t =
- Hashtbl.create 13
-
-let const_tags : (Utils.ident, Z3.Sort.sort) Hashtbl.t =
- Hashtbl.create 13
-
-let sort_elems : (Z3.Sort.sort, Utils.ident list) Hashtbl.t =
- Hashtbl.create 13
-
-let decls : (Utils.ident, Z3.FuncDecl.func_decl) Hashtbl.t =
- Hashtbl.create 13
-
+let const_sorts : (Utils.ident, Z3.Sort.sort) Hashtbl.t = Hashtbl.create 13
+let const_tags : (Utils.ident, Z3.Sort.sort) Hashtbl.t = Hashtbl.create 13
+let sort_elems : (Z3.Sort.sort, Utils.ident list) Hashtbl.t = Hashtbl.create 13
+let decls : (Utils.ident, Z3.FuncDecl.func_decl) Hashtbl.t = Hashtbl.create 13
let debug = ref false
-
let timeout = ref 10000
(* default : 10 s = 10 000 ms *)
diff --git a/src/tools/zustre/zustre_data.mli b/src/tools/zustre/zustre_data.mli
index edd7eb91..eb27c724 100644
--- a/src/tools/zustre/zustre_data.mli
+++ b/src/tools/zustre/zustre_data.mli
@@ -1,8 +1,8 @@
-val ctx: Z3.context ref
-val fp: Z3.Fixedpoint.fixedpoint ref
-val const_sorts: (Utils.ident, Z3.Sort.sort) Hashtbl.t
-val const_tags: (Utils.ident, Z3.Sort.sort) Hashtbl.t
-val sort_elems: (Z3.Sort.sort, Utils.ident list) Hashtbl.t
+val ctx : Z3.context ref
+val fp : Z3.Fixedpoint.fixedpoint ref
+val const_sorts : (Utils.ident, Z3.Sort.sort) Hashtbl.t
+val const_tags : (Utils.ident, Z3.Sort.sort) Hashtbl.t
+val sort_elems : (Z3.Sort.sort, Utils.ident list) Hashtbl.t
val decls : (Utils.ident, Z3.FuncDecl.func_decl) Hashtbl.t
-val debug: bool ref
-val timeout: int ref
+val debug : bool ref
+val timeout : int ref
diff --git a/src/tools/zustre/zustre_test.ml b/src/tools/zustre/zustre_test.ml
index 16da5ae3..5be8d611 100644
--- a/src/tools/zustre/zustre_test.ml
+++ b/src/tools/zustre/zustre_test.ml
@@ -24,15 +24,12 @@ let rec fprintf_list ~sep f fmt = function
(* Global references to declare Z3 context and Fixedpoint engine *)
let ctx = ref (Z3.mk_context [])
-
let fp = ref (Z3.Fixedpoint.mk_fixedpoint !ctx)
(* Shortcuts to basic sorts *)
let bool_sort = Z3.Boolean.mk_sort !ctx
-
let int_sort = Z3.Arithmetic.Integer.mk_sort !ctx
-
let real_sort = Z3.Arithmetic.Real.mk_sort !ctx
let _ =
diff --git a/src/type_predef.ml b/src/type_predef.ml
index f9fc72a2..10412933 100644
--- a/src/type_predef.ml
+++ b/src/type_predef.ml
@@ -19,29 +19,17 @@ module Make (T : Types.S) = struct
include T
let type_int = new_ty type_int
-
let type_real = new_ty type_real
-
let type_bool = new_ty type_bool
-
let type_string = new_ty type_string
-
let type_clock ty = new_ty (Tclock ty)
-
let type_const tname = new_ty (Tconst tname)
-
let type_enum taglist = new_ty (Tenum taglist)
-
let type_struct fieldlist = new_ty (Tstruct fieldlist)
-
let type_tuple tl = new_ty (Ttuple tl)
-
let type_arrow ty1 ty2 = new_ty (Tarrow (ty1, ty2))
-
let type_array d ty = new_ty (Tarray (d, ty))
-
let type_static d ty = new_ty (Tstatic (d, ty))
-
let type_unary_bool_op = new_ty (Tarrow (type_bool, type_bool))
let type_unary_poly_op =
diff --git a/src/type_predef.mli b/src/type_predef.mli
index 658689b1..e15bfadb 100644
--- a/src/type_predef.mli
+++ b/src/type_predef.mli
@@ -8,53 +8,30 @@ module Make (T : Types.S) : sig
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
diff --git a/src/types.ml b/src/types.ml
index 3536e562..45c98e25 100644
--- a/src/types.ml
+++ b/src/types.ml
@@ -18,31 +18,18 @@ module type BASIC_TYPES = sig
type t
val pp : Format.formatter -> t -> unit
-
val pp_c : Format.formatter -> t -> unit
-
val is_scalar_type : t -> bool
-
val is_numeric_type : t -> bool
-
val is_int_type : t -> bool
-
val is_real_type : t -> bool
-
val is_bool_type : t -> bool
-
val is_dimension_type : t -> bool
-
val type_int_builder : t
-
val type_real_builder : t
-
val type_bool_builder : t
-
val type_string_builder : t
-
val unify : t -> t -> unit
-
val is_unifiable : t -> t -> bool
end
@@ -90,81 +77,44 @@ module type S = sig
| Poly_imported_node of ident
exception Unify of t * t
-
exception Error of Location.t * error
val is_real_type : t -> bool
-
val is_int_type : t -> bool
-
val is_bool_type : t -> bool
-
val is_const_type : t -> ident -> bool
-
val is_static_type : t -> bool
-
val is_array_type : t -> bool
-
val is_dimension_type : t -> bool
-
val is_address_type : t -> bool
-
val is_generic_type : t -> bool
-
val pp : Format.formatter -> t -> unit
-
val repr : t -> t
-
val dynamic_type : t -> t
-
val type_desc : t -> type_desc
-
val new_var : unit -> t
-
val new_univar : unit -> t
-
val new_ty : type_desc -> t
-
val type_int : type_desc
-
val type_real : type_desc
-
val type_bool : type_desc
-
val type_string : type_desc
-
val array_element_type : t -> t
-
val type_list_of_type : t -> t list
-
val pp_node_ty : Format.formatter -> t -> unit
-
val get_clock_base_type : t -> t option
-
val get_static_value : t -> Dimension.t option
-
val types_of_tuple_type : t -> t list
-
val is_tuple_type : t -> bool
-
val type_of_type_list : t list -> t
-
val split_arrow : t -> t * t
-
val unclock_type : t -> t
-
val bottom : t
-
val map_tuple_type : (t -> t) -> t -> t
-
val array_base_type : t -> t
-
val array_type_dimension : t -> Dimension.t
-
val pp_error : Format.formatter -> error -> unit
-
val struct_field_type : t -> ident -> t
-
val array_type_multi_dimension : t -> Dimension.t list
end
@@ -174,11 +124,8 @@ module Basic : BASIC_TYPES = struct
declaration *)
let type_string_builder = Tstring
-
let type_int_builder = Tint
-
let type_real_builder = Treal
-
let type_bool_builder = Tbool
open Format
@@ -202,17 +149,11 @@ module Basic : BASIC_TYPES = struct
match t with Tbool | Tint | Treal -> true | _ -> false
let is_numeric_type t = match t with Tint | Treal -> true | _ -> false
-
let is_int_type t = t = Tint
-
let is_real_type t = t = Treal
-
let is_bool_type t = t = Tbool
-
let is_dimension_type t = match t with Tint | Tbool -> true | _ -> false
-
let is_unifiable b1 b2 = b1 == b2
-
let unify _ _ = ()
end
@@ -260,7 +201,6 @@ module Make (BasicT : BASIC_TYPES) = struct
| Poly_imported_node of ident
exception Unify of t * t
-
exception Error of Location.t * error
let mk_basic t = Tbasic t
@@ -396,7 +336,6 @@ module Make (BasicT : BASIC_TYPES) = struct
fprintf fmt "Imported nodes cannot have a polymorphic type@."
let new_id = ref (-1)
-
let rec bottom : t = { tdesc = Tlink bottom; tid = -666 }
let new_ty desc =
@@ -404,9 +343,7 @@ module Make (BasicT : BASIC_TYPES) = struct
{ tdesc = desc; tid = !new_id }
let new_var () = new_ty Tvar
-
let new_univar () = new_ty Tunivar
-
let rec repr = function { tdesc = Tlink t'; _ } -> repr t' | t -> t
let get_static_value ty =
@@ -632,13 +569,9 @@ module Make (BasicT : BASIC_TYPES) = struct
* Ttuple (Array.to_list array) *)
let type_desc t = t.tdesc
-
let type_int = mk_basic BasicT.type_int_builder
-
let type_real = mk_basic BasicT.type_real_builder
-
let type_bool = mk_basic BasicT.type_bool_builder
-
let type_string = mk_basic BasicT.type_string_builder
end
diff --git a/src/types.mli b/src/types.mli
index ec806eec..e04634cd 100644
--- a/src/types.mli
+++ b/src/types.mli
@@ -4,31 +4,18 @@ module type BASIC_TYPES = sig
type t
val pp : Format.formatter -> t -> unit
-
val pp_c : Format.formatter -> t -> unit
-
val is_scalar_type : t -> bool
-
val is_numeric_type : t -> bool
-
val is_int_type : t -> bool
-
val is_real_type : t -> bool
-
val is_bool_type : t -> bool
-
val is_dimension_type : t -> bool
-
val type_int_builder : t
-
val type_real_builder : t
-
val type_bool_builder : t
-
val type_string_builder : t
-
val unify : t -> t -> unit
-
val is_unifiable : t -> t -> bool
end
@@ -76,81 +63,44 @@ module type S = sig
| Poly_imported_node of ident
exception Unify of t * t
-
exception Error of Location.t * error
val is_real_type : t -> bool
-
val is_int_type : t -> bool
-
val is_bool_type : t -> bool
-
val is_const_type : t -> ident -> bool
-
val is_static_type : t -> bool
-
val is_array_type : t -> bool
-
val is_dimension_type : t -> bool
-
val is_address_type : t -> bool
-
val is_generic_type : t -> bool
-
val pp : Format.formatter -> t -> unit
-
val repr : t -> t
-
val dynamic_type : t -> t
-
val type_desc : t -> type_desc
-
val new_var : unit -> t
-
val new_univar : unit -> t
-
val new_ty : type_desc -> t
-
val type_int : type_desc
-
val type_real : type_desc
-
val type_bool : type_desc
-
val type_string : type_desc
-
val array_element_type : t -> t
-
val type_list_of_type : t -> t list
-
val pp_node_ty : Format.formatter -> t -> unit
-
val get_clock_base_type : t -> t option
-
val get_static_value : t -> Dimension.t option
-
val types_of_tuple_type : t -> t list
-
val is_tuple_type : t -> bool
-
val type_of_type_list : t list -> t
-
val split_arrow : t -> t * t
-
val unclock_type : t -> t
-
val bottom : t
-
val map_tuple_type : (t -> t) -> t -> t
-
val array_base_type : t -> t
-
val array_type_dimension : t -> Dimension.t
-
val pp_error : Format.formatter -> error -> unit
-
val struct_field_type : t -> ident -> t
-
val array_type_multi_dimension : t -> Dimension.t list
end
diff --git a/src/typing.ml b/src/typing.ml
index 96605223..5baf65c8 100644
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -33,7 +33,6 @@ module type EXPR_TYPE_HUB = sig
type type_expr
val import : Types.t -> type_expr
-
val export : type_expr -> Types.t
end
@@ -918,8 +917,7 @@ struct
(* In contracts, outputs are considered as input values *)
let locals_vars = List.map fst nd.node_locals in
let vd_env_ol =
- if nd.node_iscontract then locals_vars
- else nd.node_outputs @ locals_vars
+ if nd.node_iscontract then locals_vars else nd.node_outputs @ locals_vars
in
let vd_env = nd.node_inputs @ nd.node_outputs @ locals_vars in
check_vd_env vd_env;
@@ -1170,7 +1168,6 @@ 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
diff --git a/src/typing.mli b/src/typing.mli
index d5422dd2..cf11257e 100644
--- a/src/typing.mli
+++ b/src/typing.mli
@@ -1,14 +1,12 @@
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
module type EXPR_TYPE_HUB = sig
type type_expr
val import : Types.t -> type_expr
-
val export : type_expr -> Types.t
end
@@ -25,13 +23,9 @@ 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_prog : Types.t Env.t -> program_t -> Types.t Env.t
-
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 uneval_prog_generics : program_t -> unit
(* Equality on ground types only *)
diff --git a/src/utils/dimension.ml b/src/utils/dimension.ml
index 32b0f423..83d30108 100644
--- a/src/utils/dimension.ml
+++ b/src/utils/dimension.ml
@@ -25,17 +25,22 @@ and dim_desc =
| Dunivar
exception Unify of t * t
-
exception InvalidDimension
let fv d =
let open ISet in
- let rec fv s d = match d.dim_desc with
- | Dident x -> add x s
- | Dappl (_, ds) -> List.fold_left fv s ds
- | Dite (d1, d2, d3) -> fv (fv (fv s d1) d2) d3
- | Dlink d -> fv s d
- | _ -> s
+ let rec fv s d =
+ match d.dim_desc with
+ | Dident x ->
+ add x s
+ | Dappl (_, ds) ->
+ List.fold_left fv s ds
+ | Dite (d1, d2, d3) ->
+ fv (fv (fv s d1) d2) d3
+ | Dlink d ->
+ fv s d
+ | _ ->
+ s
in
fv ISet.empty d
diff --git a/src/utils/dimension.mli b/src/utils/dimension.mli
index a8419e14..43fa1ec6 100644
--- a/src/utils/dimension.mli
+++ b/src/utils/dimension.mli
@@ -13,53 +13,29 @@ and dim_desc =
| Dunivar
exception Unify of t * t
-
exception InvalidDimension
val fv : t -> ISet.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 uneval : ident -> t -> unit
-
val expr_replace_expr : (ident -> t) -> t -> t
-
val rename : (ident -> ident) -> (ident -> ident) -> t -> t
-
val size_const : t -> int
-
val check_bound : Location.t -> t -> t
-
val check_access : Location.t -> t -> t -> t
-
val multi_product : Location.t -> t list -> t
diff --git a/src/utils/env.ml b/src/utils/env.ml
index c9a860d9..cfeb3714 100644
--- a/src/utils/env.ml
+++ b/src/utils/env.ml
@@ -16,15 +16,10 @@ type 'a t = 'a IMap.t
(* Same namespace for nodes, variables and constants *)
let initial = IMap.empty
-
let add_value env ident ty = IMap.add ident ty env
-
let lookup_value env ident = IMap.find ident env
-
let exists_value env ident = IMap.mem ident env
-
let iter env f = IMap.iter f env
-
let fold = IMap.fold
(* Merges x and y. In case of conflicting definitions, overwrites definitions in
diff --git a/src/utils/env.mli b/src/utils/env.mli
index 9f100310..5b230fcb 100644
--- a/src/utils/env.mli
+++ b/src/utils/env.mli
@@ -3,17 +3,10 @@ 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
diff --git a/src/utils/location.ml b/src/utils/location.ml
index 8807ac7d..6b5c287d 100644
--- a/src/utils/location.ml
+++ b/src/utils/location.ml
@@ -13,7 +13,6 @@ open Lexing
module Lex = MenhirLib.LexerUtil
type t = position * position
-
type filename = string
let dummy = dummy_pos, dummy_pos
@@ -27,7 +26,6 @@ let set_input, get_module =
fun () -> !module_name )
let curr lexbuf = lexbuf.lex_start_p, lexbuf.lex_curr_p
-
let filename_of (s, _) = s.pos_fname
let shift_pos pos1 pos2 =
@@ -47,7 +45,6 @@ let shift_pos pos1 pos2 =
}
let line_of (s, _e) = s.pos_lnum
-
let pp fmt loc = Format.fprintf fmt "%s" (Lex.range loc)
let pp_c fmt (s, _e) =
@@ -56,10 +53,9 @@ let pp_c fmt (s, _e) =
Format.fprintf fmt "#line %i \"%s\"" line filename
let shift (_s1, e1) (s2, e2) = shift_pos e1 s2, shift_pos e1 e2
-
let start_ l = fst l
let end_ l = snd l
-
+
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/utils/location.mli b/src/utils/location.mli
index 89c9eca0..337d2f1a 100644
--- a/src/utils/location.mli
+++ b/src/utils/location.mli
@@ -1,24 +1,14 @@
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 start_: t -> Lexing.position
-val end_: t -> Lexing.position
+val start_ : t -> Lexing.position
+val end_ : t -> Lexing.position
diff --git a/src/utils/utils.ml b/src/utils/utils.ml
index 30c2e779..dc115880 100644
--- a/src/utils/utils.ml
+++ b/src/utils/utils.ml
@@ -15,7 +15,6 @@ open Graph
(* type rat = int * int *)
type ident = string
-
type tag = int
(* XXX: UNUSED *)
@@ -34,9 +33,7 @@ module IdentModule = struct
type t = ident
let compare = compare
-
let hash n = Hashtbl.hash n
-
let equal n1 n2 = n1 = n2
end
@@ -82,9 +79,7 @@ module Bfs = Traverse.Bfs (IdentDepGraph)
exception DeSome
let desome x = match x with Some x -> x | None -> raise DeSome
-
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 =
@@ -104,9 +99,7 @@ let rec remove_duplicates l =
(* TODO: Lélio: why n+1? cf former def below *)
(* if n < 0 then [] else x :: duplicate x (n - 1) *)
let duplicate x n = List.init (n + 1) (fun _ -> x)
-
let enumerate n = List.init n (fun i -> i)
-
let rec repeat n f x = if n <= 0 then x else repeat (n - 1) f (f x)
let transpose_list ll =
@@ -211,17 +204,14 @@ let tname_counter = ref 0
(* Same for carriers *)
let crnames = ref ([] : (int * string) list)
-
let crname_counter = ref 0
(* Same for dimension *)
let dnames = ref ([] : (int * string) list)
-
let dname_counter = ref 0
(* Same for delays *)
let inames = ref ([] : (int * string) list)
-
let iname_counter = ref 0
let reset_names () =
@@ -307,35 +297,20 @@ module Format = struct
close_out oc
let pp_print_nothing _fmt _ = ()
-
let pp_print_cutcut fmt () = fprintf fmt "@,@,"
-
let pp_print_endcut s fmt () = fprintf fmt "%s@," s
-
let pp_print_opar fmt () = pp_print_string fmt "("
-
let pp_print_cpar fmt () = pp_print_string fmt ")"
-
let pp_print_obracket fmt () = pp_print_string fmt "["
-
let pp_print_cbracket fmt () = pp_print_string fmt "]"
-
let pp_print_obrace fmt () = pp_print_string fmt "{"
-
let pp_print_cbrace fmt () = pp_print_string fmt "}"
-
let pp_print_obrace' fmt () = pp_print_string fmt "{ "
-
let pp_print_cbrace' fmt () = pp_print_string fmt " }"
-
let pp_print_comma fmt () = fprintf fmt ",@ "
-
let pp_print_semicolon fmt () = fprintf fmt ";@ "
-
let pp_print_comma' fmt () = fprintf fmt ","
-
let pp_print_semicolon' fmt () = fprintf fmt ";"
-
let pp_open_vbox0 fmt () = pp_open_vbox fmt 0
let pp_print_list ?(pp_prologue = pp_print_nothing)
diff --git a/src/utils/utils.mli b/src/utils/utils.mli
index 1e628e77..43c6c705 100644
--- a/src/utils/utils.mli
+++ b/src/utils/utils.mli
@@ -1,5 +1,4 @@
type ident = string
-
type tag = int
module IMap : sig
@@ -13,7 +12,6 @@ module IMap : sig
unit
val diff : 'a t -> 'a t -> 'a t
-
val of_list : (key * 'a) list -> 'a t
end
@@ -27,23 +25,14 @@ 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 :
@@ -154,7 +143,6 @@ 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
@@ -172,48 +160,35 @@ module Bfs : sig
end
val name_of_dimension : tag -> ident
-
val name_of_carrier : tag -> ident
-
val name_of_type : tag -> ident
-
val name_of_delay : tag -> ident
-
val reset_names : unit -> unit
-
val pp_date : Format.formatter -> Unix.tm -> unit
exception TransposeError of int * int
val transpose_list : 'a list list -> 'a list list
-
val new_tag : unit -> tag
exception DeSome
val desome : 'a option -> 'a
-
val create_hashtable : int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
-
val option_map : ('a -> 'b) -> 'a option -> 'b option
-
val repeat : int -> ('a -> 'a) -> 'a -> 'a
-
val add_cons : 'a -> 'a list -> 'a list
-
val enumerate : int -> int list
-
val duplicate : 'a -> int -> 'a list
-
val list_union : 'a list -> 'a list -> 'a list
-
val remove_duplicates : 'a list -> 'a list
- module List: sig
- include module type of Stdlib.List
- val extract: 'a list -> int -> int -> 'a list
- end
+module List : sig
+ include module type of Stdlib.List
+
+ val extract : 'a list -> int -> int -> 'a list
+end
(* end *)
-val get_date: unit -> string
+val get_date : unit -> string
diff --git a/src/verifierList.ml b/src/verifierList.ml
index e38063e5..5c77a0da 100644
--- a/src/verifierList.ml
+++ b/src/verifierList.ml
@@ -1,5 +1,4 @@
let registered : (module VerifierType.S) list ref = ref []
-
let verifiers () = !registered
(* [
* @LUSTREV_SEAL@
diff --git a/src/verifierList.mli b/src/verifierList.mli
index aed6b654..1d2c9baa 100644
--- a/src/verifierList.mli
+++ b/src/verifierList.mli
@@ -1,2 +1,2 @@
-val registered: (module VerifierType.S) list ref
+val registered : (module VerifierType.S) list ref
val verifiers : unit -> (module VerifierType.S) list
diff --git a/src/verifierType.ml b/src/verifierType.ml
index 9ed16bea..d64fb74d 100644
--- a/src/verifierType.ml
+++ b/src/verifierType.ml
@@ -1,20 +1,22 @@
-module type S =
-sig
- val name: string
- val activate: unit -> unit
- val is_active: unit -> bool
- val options: (string * Arg.spec * string) list
- 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
+module type S = sig
+ val name : string
+ val activate : unit -> unit
+ val is_active : unit -> bool
+ val options : (string * Arg.spec * string) list
+ val get_normalization_params : unit -> Normalization.param_t
- let get_normalization_params () = {
- Normalization.unfold_arrow_active = true;
- force_alias_ite = false;
- force_alias_internal_fun = false;
- }
+ val run :
+ basename:string ->
+ Lustre_types.program_t ->
+ Machine_code_types.machine_t list ->
+ unit
+end
- 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/verifierType.mli b/src/verifierType.mli
index eab0167b..ff43a35b 100644
--- a/src/verifierType.mli
+++ b/src/verifierType.mli
@@ -1,12 +1,8 @@
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 :
@@ -16,7 +12,6 @@ module type S = sig
unit
end
-module Default :
- sig
- val get_normalization_params : unit -> Normalization.param_t
- end
+module Default : sig
+ val get_normalization_params : unit -> Normalization.param_t
+end
diff --git a/src/verifiers.ml b/src/verifiers.ml
index f02ee2f5..89983855 100644
--- a/src/verifiers.ml
+++ b/src/verifiers.ml
@@ -1,7 +1,6 @@
open VerifierList
let () = Sites.Plugins.Verifiers.load_all ()
-
let active = ref None
let options () =
diff --git a/src/verifiers.mli b/src/verifiers.mli
index 856b77f8..a047ac06 100644
--- a/src/verifiers.mli
+++ b/src/verifiers.mli
@@ -1,3 +1,2 @@
val get_active : unit -> (module VerifierType.S)
-
val options : unit -> Options_management.options_spec
diff --git a/src/version.ml b/src/version.ml
index 6d82c096..de05425e 100644
--- a/src/version.ml
+++ b/src/version.ml
@@ -1,7 +1,4 @@
let number = "@PACKAGE_VERSION@-@GITBRANCH@"
-
let codename = "@VERSION_CODENAME@"
-
let include_path = Sites.Sites.include_ |> List.hd
-
let testgen_path = Sites.Sites.testgen |> List.hd
diff --git a/src/version.mli b/src/version.mli
index 503772d0..58fc63e4 100644
--- a/src/version.mli
+++ b/src/version.mli
@@ -1,7 +1,4 @@
val number : string
-
val codename : string
-
val include_path : string
-
val testgen_path : string
diff --git a/strategy.ml b/strategy.ml
index af11dedc..feec6326 100644
--- a/strategy.ml
+++ b/strategy.ml
@@ -1,7 +1,7 @@
open Wp
(* check that a given predicate name is a transition and return its index *)
-let is_transition (f: Lang.lfun) : int option =
+let is_transition (f : Lang.lfun) : int option =
let open Str in
let r = regexp "_transition\\([0-9]+\\)$" in
let s = Repr.lfun f in
@@ -11,13 +11,16 @@ let is_transition (f: Lang.lfun) : int option =
with Not_found -> None
(* check that a given predicate name is a transition with given index *)
-let is_transition_n (n: int) (f: Lang.lfun) : bool =
+let is_transition_n (n : int) (f : Lang.lfun) : bool =
let open Str in
let r = regexp ("_transition" ^ string_of_int n ^ "$") in
- try ignore (search_forward r (Repr.lfun f) 0); true with Not_found -> false
+ try
+ ignore (search_forward r (Repr.lfun f) 0);
+ true
+ with Not_found -> false
(* check that a given predicate name is a memory pack simulation *)
-let is_pack (f: Lang.lfun) : bool =
+let is_pack (f : Lang.lfun) : bool =
let open Str in
let r = regexp "_pack\\(\\|[0-9]+\\|_base\\)$" in
let s = Repr.lfun f in
@@ -27,7 +30,7 @@ let is_pack (f: Lang.lfun) : bool =
with Not_found -> false
(* check that a given predicate name is a reset_cleared relation *)
-let is_reset_cleared (f: Lang.lfun) : bool =
+let is_reset_cleared (f : Lang.lfun) : bool =
let open Str in
let r = regexp "_reset_cleared$" in
let s = Repr.lfun f in
@@ -37,17 +40,17 @@ let is_reset_cleared (f: Lang.lfun) : bool =
with Not_found -> false
(* tactical selection of the goal *)
-let select_g (g: Lang.F.pred) : Tactical.selection =
+let select_g (g : Lang.F.pred) : Tactical.selection =
let open Tactical in
Clause (Goal g)
(* tactical selection of an hypothesis *)
-let select_h (h: Conditions.step) : Tactical.selection =
+let select_h (h : Conditions.step) : Tactical.selection =
let open Tactical in
Clause (Step h)
(* get variables and predicate under existential binder *)
-let existential_vars_g (g: Lang.F.pred) : Lang.F.var list * Lang.F.term =
+let existential_vars_g (g : Lang.F.pred) : Lang.F.var list * Lang.F.term =
let open Lang.F in
let copy = pool () in
let pool = pool ~copy () in
@@ -58,63 +61,67 @@ let existential_vars_g (g: Lang.F.pred) : Lang.F.var list * Lang.F.term =
(* find the index of the first element that verifies p in l *)
let find_index p l =
let rec aux i = function
- | [] -> raise Not_found
- | x :: l -> if p x then i else aux (i + 1) l
+ | [] ->
+ raise Not_found
+ | x :: l ->
+ if p x then i else aux (i + 1) l
in
aux 0 l
(* check if the term t is the variable v *)
-let is_var (v: Lang.F.var) (t: Lang.F.term) : bool =
- match Repr.term t with
- | Var w -> v = w
- | _ -> false
+let is_var (v : Lang.F.var) (t : Lang.F.term) : bool =
+ match Repr.term t with Var w -> v = w | _ -> false
exception Found of Tactical.selection list
(* a function to search a transition call in the hypotheses *)
(* that can be unified with a term *)
-let rec unify
- (push: Strategy.strategy -> unit)
- (sequent: Conditions.sequent)
- (vars: Lang.F.var list)
- (term: Lang.F.term) : unit =
+let rec unify (push : Strategy.strategy -> unit) (sequent : Conditions.sequent)
+ (vars : Lang.F.var list) (term : Lang.F.term) : unit =
let hyps = fst sequent in
match Repr.term term with
- | Call (p, ts) ->
+ | Call (p, ts) -> (
(* get the index of the transition under the binder *)
- begin match is_transition p with
- | Some n ->
- (* find the indexes of the existential variables *)
- let idxs = List.map (fun v -> find_index (is_var v) ts) vars in
- (* we search the hypotheses to find the corresponding terms *)
- Conditions.iter (fun step -> match step.condition with
- | Have p ->
- (* in case of footprint lemma : unfold the hypothesis *)
- begin match Repr.pred p with
- | Call (p, _) when is_transition_n (n + 1) p ->
- push (Auto.definition (select_h step))
- | _ -> ()
- end;
- (* a function to find an hypothesis *)
- let find_hyp term =
- match Repr.term term with
- | Call (p, ts) when is_transition_n n p ->
- let witnesses = List.map (fun i ->
+ match is_transition p with
+ | Some n ->
+ (* find the indexes of the existential variables *)
+ let idxs = List.map (fun v -> find_index (is_var v) ts) vars in
+ (* we search the hypotheses to find the corresponding terms *)
+ Conditions.iter
+ (fun step ->
+ match step.condition with
+ | Have p ->
+ (* in case of footprint lemma : unfold the hypothesis *)
+ (match Repr.pred p with
+ | Call (p, _) when is_transition_n (n + 1) p ->
+ push (Auto.definition (select_h step))
+ | _ ->
+ ());
+ (* a function to find an hypothesis *)
+ let find_hyp term =
+ match Repr.term term with
+ | Call (p, ts) when is_transition_n n p ->
+ let witnesses =
+ List.map
+ (fun i ->
let t = List.nth ts i in
- Strategy.select_e sequent t) idxs
- in
- raise (Found witnesses)
- | _ -> ()
- in
- let p = Lang.F.e_prop p in
- (* is the whole hypothesis the transition call? *)
- find_hyp p;
- (* otherwise, explore sub-terms to find it *)
- Lang.F.lc_iter find_hyp p
- | _ -> ()) hyps
- | None -> ()
- end
-
+ Strategy.select_e sequent t)
+ idxs
+ in
+ raise (Found witnesses)
+ | _ ->
+ ()
+ in
+ let p = Lang.F.e_prop p in
+ (* is the whole hypothesis the transition call? *)
+ find_hyp p;
+ (* otherwise, explore sub-terms to find it *)
+ Lang.F.lc_iter find_hyp p
+ | _ ->
+ ())
+ hyps
+ | None ->
+ ())
| HigherOrder ->
let copy = Lang.F.pool () in
let pool = Lang.F.pool ~copy () in
@@ -122,7 +129,6 @@ let rec unify
List.iter (Lang.F.add_var pool) fv;
let _, term = Lang.F.e_open ~forall:false ~lambda:false ~pool term in
unify push sequent vars term
-
| _ ->
Lang.F.lc_iter (unify push sequent vars) term
@@ -130,54 +136,54 @@ let rec unify
class lustrec_transitions : Strategy.heuristic =
object
method id = "LustreC:Transitions" (* required, must be unique *)
+
method title = "LustreC Transitions"
method descr = "Custom goal transformations for transition relations"
- method search (push: Strategy.strategy -> unit) (sequent: Conditions.sequent)
- : unit =
+ method search (push : Strategy.strategy -> unit)
+ (sequent : Conditions.sequent) : unit =
let goal = snd sequent in
match Repr.pred goal with
(* if the goal is only a transition relation, unfold it *)
| Call (p, _) when is_transition p <> None ->
push (Auto.definition (select_g goal))
-
(* if the goal is existential *)
- | HigherOrder ->
+ | HigherOrder -> (
(* get the existential variables *)
let vars, g = existential_vars_g goal in
(* find the transition call under binders *)
- begin try unify push sequent vars g with
- | Found witnesses ->
- (* instantiate the variables with found (rev ??) witnesses *)
- push (Auto.instance (select_g goal) (List.rev witnesses));
- | _ -> ()
- end
-
- | _ -> ()
+ try unify push sequent vars g with
+ | Found witnesses ->
+ (* instantiate the variables with found (rev ??) witnesses *)
+ push (Auto.instance (select_g goal) (List.rev witnesses))
+ | _ ->
+ ())
+ | _ ->
+ ()
end
(* Reset Cleared heuristic *)
class lustrec_reset_cleared : Strategy.heuristic =
object
method id = "LustreC:ResetCleared" (* required, must be unique *)
+
method title = "LustreC ResetCleared"
method descr = "Custom goal transformations for reset_cleared relations"
- method search (push: Strategy.strategy -> unit) (sequent: Conditions.sequent)
- : unit =
+ method search (push : Strategy.strategy -> unit)
+ (sequent : Conditions.sequent) : unit =
let goal = snd sequent in
match Repr.pred goal with
(* if the goal is only a reset_cleared relation, unfold it *)
| Call (p, _) when is_reset_cleared p ->
push (Auto.definition (select_g goal))
-
- | _ -> ()
+ | _ ->
+ ()
end
(* unfold f(es) in the given context (context is handled with side-effects) *)
-let definition
- (context: WpContext.context) (f: Lang.lfun) (es: Lang.F.term list)
- : Lang.F.term =
+let definition (context : WpContext.context) (f : Lang.lfun)
+ (es : Lang.F.term list) : Lang.F.term =
let on_ctx f = WpContext.on_context context f in
let d = on_ctx Definitions.find_symbol f in
match d.d_definition with
@@ -188,36 +194,36 @@ let definition
assert false
(* rewrite a sequent by unfolding a top-level memory pack relation *)
-let unfold_process
- (context: WpContext.context) (t: Lang.F.term) (sequent: Conditions.sequent)
- : Conditions.sequent option =
+let unfold_process (context : WpContext.context) (t : Lang.F.term)
+ (sequent : Conditions.sequent) : Conditions.sequent option =
match Repr.term t with
| Call (p, es) when is_pack p ->
let v = definition context p es in
Some (Conditions.subst (fun t' -> if t == t' then v else t') sequent)
- | _ -> None
+ | _ ->
+ None
(* sequent equality *)
-let eq_sequent s1 s2 =
- Lang.F.eqp (snd s1) (snd s2)
+let eq_sequent s1 s2 = Lang.F.eqp (snd s1) (snd s2)
(* rewrite a sequent by recursively unfolding memory pack relations, by *)
(* iterating over sub-terms *)
-let rec rewrite_process
- (context: WpContext.context) (sequent: Conditions.sequent)
- : Conditions.sequent =
+let rec rewrite_process (context : WpContext.context)
+ (sequent : Conditions.sequent) : Conditions.sequent =
let goal = Lang.F.e_prop (snd sequent) in
(* first try to unfold the whole term *)
match unfold_process context goal sequent with
| Some sequent' ->
- if eq_sequent sequent' sequent
- then sequent
+ if eq_sequent sequent' sequent then sequent
else rewrite_process context sequent'
- | None ->
- (* otherwise try to unfold the first matching sub-term *)
- let exception Found of Conditions.sequent in
- (try
- Lang.F.lc_iter (fun t ->
+ | None -> (
+ let exception
+ (* otherwise try to unfold the first matching sub-term *)
+ Found of Conditions.sequent
+ in
+ try
+ Lang.F.lc_iter
+ (fun t ->
match unfold_process context t sequent with
| Some sequent' ->
if not (eq_sequent sequent' sequent) then raise (Found sequent')
@@ -230,15 +236,17 @@ let rec rewrite_process
(* Memory Packs tactical *)
class unfold_rec =
object
- inherit Tactical.make ~id:"LustreC.unfold"
+ inherit
+ Tactical.make
+ ~id:"LustreC.unfold"
~title:"Unfold rec MemoryPacks"
~descr:"Unfold recursively MemoryPacks relations"
~params:[]
- method select _feedback (_s: Tactical.selection) =
+ method select _feedback (_s : Tactical.selection) =
let context = WpContext.get_context () in
- Tactical.Applicable (fun sequent -> [ "", rewrite_process context sequent ])
-
+ Tactical.Applicable
+ (fun sequent -> [ "", rewrite_process context sequent ])
end
(* Memory Packs strategy *)
@@ -248,23 +256,22 @@ let unfold_rec_strategy = Strategy.make (new unfold_rec) ~arguments:[]
class lustrec_memory_packs : Strategy.heuristic =
object
method id = "LustreC:MemoryPacks" (* required, must be unique *)
+
method title = "LustreC MemoryPacks"
method descr = "Custom goal transformations for memory_pack relations"
- method search (push: Strategy.strategy -> unit) (sequent: Conditions.sequent)
- : unit =
+ method search (push : Strategy.strategy -> unit)
+ (sequent : Conditions.sequent) : unit =
let goal = snd sequent in
match Repr.pred goal with
(* if the goal is only a memory_pack relation, unfold it recursively *)
| Call (p, _) when is_pack p ->
push (unfold_rec_strategy (select_g goal))
-
(* split conjunctions and conditionnals *)
- | And _
- | If _ ->
+ | And _ | If _ ->
push (Auto.split (select_g goal))
-
- | _ -> ()
+ | _ ->
+ ()
end
(* Register the strategies *)
diff --git a/unused/mmap.ml b/unused/mmap.ml
index 9abcb67d..1d1c7d68 100644
--- a/unused/mmap.ml
+++ b/unused/mmap.ml
@@ -19,62 +19,39 @@ end
module type S = sig
type key
-
type +'a t
val empty : 'a t
-
val is_empty : 'a t -> bool
-
val mem : key -> 'a t -> bool
-
val add : key -> 'a -> 'a t -> 'a t
-
val singleton : key -> 'a -> 'a t
-
val remove : key -> 'a t -> 'a t
val merge :
(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
-
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
-
val iter : (key -> 'a -> unit) -> 'a t -> unit
-
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
-
val for_all : (key -> 'a -> bool) -> 'a t -> bool
-
val exists : (key -> 'a -> bool) -> 'a t -> bool
-
val filter : (key -> 'a -> bool) -> 'a t -> 'a t
-
val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
-
val cardinal : 'a t -> int
-
val bindings : 'a t -> (key * 'a) list
-
val min_binding : 'a t -> key * 'a
-
val max_binding : 'a t -> key * 'a
-
val choose : 'a t -> key * 'a
-
val split : key -> 'a t -> 'a t * 'a option * 'a t
-
val find : key -> 'a t -> 'a
-
val map : ('a -> 'b) -> 'a t -> 'b t
-
val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
end
module Make (Ord : OrderedType) = struct
type key = Ord.t
-
type 'a t = Empty | Node of 'a t * key * 'a * 'a t * int
let height = function Empty -> 0 | Node (_, _, _, _, h) -> h
@@ -115,7 +92,6 @@ module Make (Ord : OrderedType) = struct
else Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1)
let empty = Empty
-
let is_empty = function Empty -> true | _ -> false
let rec add x data = function
@@ -380,6 +356,5 @@ module Make (Ord : OrderedType) = struct
bindings_aux ((v, d) :: bindings_aux accu r) l
let bindings s = bindings_aux [] s
-
let choose = min_binding
end
--
GitLab