diff --git a/.ocamlformat b/.ocamlformat
index dbb4a3874a9c74f82f2ccf905418fcfc415661b9..c4a2f22e4cf14bba9323d058dfdd368cdeb6201e 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 69515632152ce091768231fec48bd4fdf343bdec..2ecaccdda82c9c60e6dc845847525c083e24438d 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 b7d17be4ed0c6d621c32a90e68dd9f92d1274e5b..8af53d090b68ee195f3f4d29098cade72d3a4ebe 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 c2d55db550520fca5ae76420f954ec963ffc4a3c..700baa8a90f045803645d97671d092007797daed 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 a82bf1858fceb13a356da142049d6fcbfb4f10dc..2b178f7a0f1b1223288e147d965d91e2cea1c76e 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 83426bbfd276928dd08d46c73e4955f04ef6598e..903754294060fe1313a7a9edd4c11afb06fb041c 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 a5b57e96133999a66436338ef5bc59a6f41d20a2..ef0a1f3cddb42e395935f5e33aa42b3065a6cd9f 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 87062c351136bf47900f6a44e5bb6a9d20944bda..f944948c2a5f4e3c4ce1319d25d6d086c4b6839c 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 79b10ce7482bb84cb405160112f8758cffc7ee54..46df4d261251c09d6896e342a4baef9a1b2b4c4b 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 506b2d7d3dc199d1ee86c2fce1926ef9466dda8c..1e3f48c36ec5d27f31d533fdefcdbb46fb37f2e5 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 fa72518f07e70dcab84f9402fefb35237a9593e0..6d4a3d3da35909efd4663b0ad969b9616193231c 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 2b35098b353ffd10170933caad13bf32c9a2b02c..1241e9725d383607103b095c51e6ad85cc126437 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 6ecf0e1c8c619f208d536e2cbb898121889b0790..d4c3d8201d8a0473e17036a7433ec183647146bd 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 2e5c322d5c22fb9789e309e337c52d3da5d3f71c..e124a9d81849a543899ffa62ed06a48f8f012902 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 c1df895cf0c07b117f22aa9a310d58d632a76f0f..f856dd8909dadf2f5f31255fb241bd86775a89dd 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 54edca86a1847e01818d4534360fb2924994cf6e..ec1c96e5927ca221ff63fcc53c58c9a558d19386 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 b2686b2178b4585bb77ad244e9a761bfef3cee1a..e585fbbee474553acb78a2117799125c62630919 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 a2a54e009a98f39fc43d3af9ba01de5582abc5a4..762c1c90217f26431ec8d2ef30e87bd07476650f 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 64f95f4ef4f73023ccac372050bf0cd3bf5942c7..5e524feef94dc4b34e3c583076f071d4a2a99d3a 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 4707881d581db69d0664d49214b17c6887a0ccd6..b74c6d9594c99b1da327e81777bff5993c8f7ee7 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 6b677bda4ca04b13b60bd5241a5c811af3eb2a65..a0a5c28a037efe961fc5334b887f508a3feb1c9c 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 9608bc4d4a5c874cde936b63285e62fdd56683cf..3d8400eaa0f276b2a282fdd5d8b39e4420bae1a1 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 abe9e9a522adcc91e353d70cc59f43194b58a3b2..4f4aa965262051e3ce428a98bb39cbbbf498bfa7 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 ba36c690d6d77b7323f9970a8a8d1479a099869c..876ab82fffd88f0598d2cc1dfd5d7d6094dc2f27 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 32cd587c64b9b3b5fbb71ddb95bdb915bc4a96a5..e8135e8d311ca4646badfa02a866cba3ed1a2504 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 ee088fa73edfe674c92266de3c17a78cd051b0eb..38f7c80a1d9a59010d5b4c10349d33b6670c37f3 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 1d63a72faad7033a24be0e2ea13aa8b3b3ce8641..65add707ad9b7e9909c7cbee0d1329cf62dc7b33 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 6762862b4cbc8f1ad24fc36138441e6116c305dc..0a21b869e8b8e001d036f87641b516ea683dbbdf 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 fc04dfc8cf1e6341406c5d3db1d6f41b7db86290..feb64dad9d86514db26c21cc7cc2b45c22fcf04c 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 024068f45ef2f85634ae49c2c1f0f5466c857baf..0dd2bfab9ba112eddb4295db90cf71fe7d0eeaf9 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 b9a5178694fbf53cd868184b1e05060594d8defe..5529317b8f3b7673997263dbd307f5a3831e0c36 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 2f94de5a2f03f1ac9e35d0f66873e44de4811c57..15f7da4c87de31012468d51f82c154a6771a01d6 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 30e674dc78e4bc780541d619dee7dd95e01b0904..47a5665099636ed26da3f35e8e4e47b2d00bf11c 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 f03f5bb2dc2b47f8d0410b56546096338a4cff01..2c5c8c61dab5b3270e4827e9bd3cea2a4b636f8f 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 e8ecbb75ada69f227058bef92837afcf834d73a9..78c6143415db95a1f313f4f06a72064cbcc9c153 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 a89ee90e926b871044e9f2936f67e6aba78970c2..32c742966b88e2d180f819bdb58c0189323b1f79 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 af9f787ffdd16a1a4c28e7b492646feeae87f749..1b42ce160b7ddb7d439d8771ff8140c297d41083 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 15d3c95acd5634c738f27346f79330e85c0ada4b..e6fedcbbb845ed40eba6a4807a4a6063d3502d90 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 fc176afce3e3e1cdcffb107f8a77e91f2aa5671a..1fa5c20686639a6248fc7ecca68a61af48406066 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 466453301f9c1e1b72c76ff61297b40db83951f9..a6e175b2ad36acf8d959ed20b53ac00d5d3d9962 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 a64e55436ea0645844de860a3af6f55ad74c8948..98f4973dcda885125ae5db395b09c6113d0f5d36 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 08da000ceea545bf0e7762d57395fb14dc7e7939..e1a85bd5def5b4454bd1c03762b0bc7f99080de9 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 303d93c7028bc70f05365e500996e2c3b20d3e05..bcc213542e9344760c9877a510a7a7ceaa062d91 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 2253e1610868059dd5d94dd3d0b95d1a3ea4b5c5..f9bfb0b2454809f264a2f126d80546954ab26e77 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 b422f21943bd9e56a7022e74482f7c6a99d9adc2..a4e9d74c77c91e10e17eff464aeb2ff7215938ea 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 92f060d64ccc836daf527b9c3ad015f6997a54fd..8b389b1b083de7c1fdc1dfe6f36d9366d55b0331 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 0788393807c9ab607d25066b654058b4a3392271..4e187c7a67547cf13db9d3fc4c1fdbbe045ba291 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 4927fa24b5293386dd44aafb70caa6ea68e58d8c..4f0a3278b1c4fc37134074b29069d46f71a9b4ce 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 082c83ed6fd384efbb67987fda1a3a102330812a..5e0e563c377f2645af793fa7fc58cb462dbdf21d 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 41d4d96cec00384c3e9e2336a79a7670c933ec1c..6f6b131e7e2530436842a05e91c182dcb8ad49d0 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 ab5bfcea24d0ead8523f4da1e1bd772a09998046..c3ae212523abad517a8353a4ca56c35d0aec2e4a 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 5af4f6fcff3aad3867fa82984e475b86254f862c..63a1f7d27c88a21019481f4f7a4c7ba6bd703a90 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 6f6ce618fc1bc2e9fa08b5f04e0c94647bf3b2bd..74209dc1637b2321e7400ccedc7f9c8e1aafc581 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 083443c445399996893695c00c20507341d19e8b..3b5868b1f550e088cb8f07cbe597998ab29313f5 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 69502461c5628611727e95fb20ab4ecbb48a3ac6..586ec869f3b124d979a92efc22391afcc18c99d6 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 ba31aefd2a9b24261c059f7fd53234bf1e194d3b..98c66ef80b7ef44cd84ce8a242a4e1d432712ee0 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 5b686c315d8033bc647e77487112253a4b4e0629..44bdafea09effcb1cc849d3a8bce4fbd322582af 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 069b3ac20d2dd3e17b8f1ca59c559a49dc83ae34..528ff69af61b2cc4f60d1283227d831e655a146c 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 13b98ff3be8235e45b30e04dd0693ad705256047..e24cd4299715bcd37b4560cd3384f746c67fc94b 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 114267d65d1f07f7a51309bb908ff9956b5b55f5..ff8d31549cd450784dc60b2c48756e6772b93994 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 57e4739b6367d0d159cc3a1182443c4b54a8d2b0..ed78acd4814206065ea8efb86b555b360a869b10 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 d9dd4ec991fbfa63f1896741ac1bc323c5672767..da0b589e697179a3013720b46ff16452bd0343c2 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 0dffec457deb9c6c78568ddbacbd9ab3d278cb94..34848d13b1b0882dc32b10519d258452a48469ce 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 5076587389391d1a8a54466da3d9c06e41dfcc15..ffd57311aad7532429d6becb8e2a38252d757e18 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 3301a70b874afea657843d667ca89e8ad0f6a798..e0033267d8412782abe7bbd9e91890285c4b9b28 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 3228633fb0fb4a526528a98415054e02666a0cbd..752237dc0e45d2fde8057ed341c7d4cefb773711 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 e1b1539755d9579c5ef3d38ef1c65af08ff0b85f..e5d964b61d250d3265d334b123af365ee584e0de 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 a257d5050d84ec92f24111aa77702b30547e317a..252545e8534b160bd2434f1e7b2b77a5c6ac0975 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 bbf1a31acf850216bee870566aed72e9c76d44f4..522802fd3a6f05faafcb55f0039e3afb668d2aa9 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 a81db2a54f70da1c551091b692f301abe7953822..9a9dfe84917bc173da5e4df8f663f1b91afcbdda 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 1d3eeccfd22eb69dee41a004a6694c46e924b279..9cc8e925e9b22fff96113e88b82b5eadb1312ad5 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 79b384087d2b709c75f1b26de38313d764c36def..4d8bdbb4a811b9ec1fd07ed49363b2049f43b780 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 d533bbfe32a03ff36f8d168d8af048a60dc8c3f3..54fa586815cf1f7c2eb26d47520c8dd9fd110f77 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 c267fc4d4ea1a528b4eeaf164ff7180639d5d94e..d4f3ab86afc1b14faa40f3dd74599a26b2058e5a 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 c1ff4951881a1afeaa61cd8c6b88313a128e7762..cfa62b31d24032ce4ffb74bfb443243e0b294806 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 17f91d2f6a8ad6db45821b0958b8082285e1e741..29a73c8e30b6275793635f24d3a7c4256af79bb1 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 50326f19205ae07820e94a31cb945daf843b402d..c0110d9ec34e98ef40d2558fc1eea4c99812088e 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 e6e07d35233f08fe6dc9e60ee318a6b3339a451a..84a7e4aed6b74297f294512b6f9af41433b94708 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 b93760fb1772707c15e6154e87e9e54c3a4085e4..5e14a0f8fa1cf9442083c4b640af633500845fe3 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 4c4c8ed46f7446bd014a3055788d0e92384b130c..eff5d73d685140f877db566e3600f73bb5f68e84 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 0c6ce419e5f7ea768f88970695caf158de0b815d..a89dfb9ec4f22a39dfdd2e902c1cebac59330aa4 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 75c1af089ea4406888738fac116de6f624979255..8f15747c693158f073e267a1fa98202b35a11e73 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 8d490b5679f604f8627ea37ee9d21c942812d381..0f9402023181ac6ff565b029f081c9ed321cd09c 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 651cfc1adbb4c75df9056ab665242d801d869c36..9e77b6c2ae30d6d3a3296cc2584df9b2d7cecb54 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 09dcb289916ee86b69dcfd74d597079182565ff2..2cc414945e1efb2203b2b34598016a1a809df09f 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 9171eb51a4e8c6136e4d39107bb1ab9be63d44f2..e00aea1f7e7bbba58d2d2054b4bbeaacbeaeabbe 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 82fcd9585d2ea8f9c6bfef32d78ba56f9a135dba..e2925dc584bb10538e702c0f05bbde7546c23c2a 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 04c91085eeb7504a1783d0dd2e98242d2c375906..4acde1367a6fe5dbc78c62787a8e0f9741aed5a0 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 ebfa7ce74582a2581cbabfed85e3c286f5901975..c7f00109c98faa6b91e96e4b687eeb9e2f414ab4 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 6aa7d50ceb8219a4a03865cad6256b606d6bd92b..5ede5cb10d08df5f1d84cd14ffb70ee882a1932b 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 9720da97cd1dc1bfd5074877437069b895a23f8a..12cff24e5d53d8a520fb3bfa4ac3fa00dc1a9bd4 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 ccb2c6d012cfcd4e0f135173f746cdcaa061756d..e93f7fe2755b40e6cd388e9778e031ef19176d35 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 dea715c1c89bd16defc743dd39bb069be13ad462..c3179eccfe8c0ea1a34192e17589aa1ce5dfc063 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 06d8de15efb2efdf451929a55c086da2f74b544e..179a5e77314ace48335808401a61b7b97a1597a2 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 5be008f2659661bae09cac8609ae6865496a19a0..de6d96f363e88708991e374e8958e0fcb55166a8 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 e58bc92f8ff7c233195a9bdd7146831a5ca7d24d..c9a083ecf77dbf274e3acb45c3ecbfc5b6081913 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 f127f7b624de63786aa5b02217a9a4ec378bd73c..8ec315728a4a4b3a2fbca5870ed69f71513ac807 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 17dad3f6ff4c7dce450efa8cf0c1aac057617e4e..9a875d08238d748a987d88f26d97886456f140d7 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 887b570ec9cf267743440f84786dc2e94d73ded1..624e47ab5b95991f5b481138050e7233dda08c2f 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 be6743f84fb2f8fd9e43ff1276d791407d69616d..3c8785a65e7c15723fd858af1a5fc26628842327 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 4fac288ae9d416b835302a505c55874dd1d007e8..b62815109922224074405290ff68406c9c484e2c 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 73ba93b39344b8064070b2446131bc4ed8439d25..52e6ddd5e67337f20cb9dde0ad2036ca44b8f427 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 5df6ee537215466013a3e351647e166c8540d87d..b6a9f8bc65e224330aa005efa4e2b3d08b649015 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 653ea6210ffa408817b2a0007376c1d9c0e79d18..c63465ec2acd191ed087c6a9b083b2f772618b2d 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 62a88c8ea23f540500ef5bba96c0a5bef184b53d..87ee50991007b21ca357426457184cf7576bc759 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 b23704cad7b4ab8f204b43e5b530f5c424598946..a8efd9350f1d8be1efb668d3f9101a78e1b9b01f 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 e048264d968ea9c42414215cb639430fa22abad9..29e66c7690b4ae59614f7edcbba156b20de2ec86 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 6b10cd42a65ce9e6ec54adc8960aa624f72c46f8..830e9db030739b77ca5bc616a4afcbec3a69c9c1 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 c6e07d4f865bad994d9093e185fa04c733aa5213..342fca6b894ccc02554daf9375988901f9e5b4d1 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 20022895132b4555500cab24fde908355cc15644..695f870f2234b349c0226adc22fbfc9d58b757f3 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 10986aa2229f5cd4753ab17a2713786050a5d379..34254e4b0c224d28424881ccc8972814232c2eda 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 ce97ba36b399cc655aba7d9798d1435db6180d64..05da678c095e2e0b486eec23fbd714418c622015 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 243d0f05d87d0cef58ac3d0ea4179323c5bc8eb7..fac7c8471e5479ea56e8d89ad541f397faafeafc 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 5a80caad0b50b5f8ee92eb85f632f12474018da2..259fd98cb9bb9ae0dba2f6674631999b66d656bd 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 c7ac0bf3eb7c351c1d0c405209e34775a6adc20a..8de57f92cbe5ca34a36888268a928fd2a59f994c 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 8115fe917983021b6682b6438ea4173a441560c8..d7275fb96ba0fd23da6d41a7bace38ebd61a0a8a 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 177197800b6b59f75a934ea1aabe0001f197dade..e17bed4d969c44c05c544e48d89edbe81ec1865c 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 e3493f6eac1e0b44735eda5a4dea9958a09ef6ab..b43f97f57490a0271c66460f1b94752228989b75 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 3dd46941f8fb93ae31d5a63feb3e8a4d70dfad5f..04ac28f5714541e91bb590a9aef3219117ede1e8 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 68646fcf5e7c4c8c1721f5fb72554bb9b66a9914..d73d29d1dd1b594f432933a109ac0f0cec9719e8 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 29afab0bc9ffff262bfcf74406c3c4b5a3a90a73..f8088a15c4f80b9eb46bf21b662237b690318dfd 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 38c77135d51e946bde731edb0f98b4e692f2f997..9667b22566aab975d12fea2bc72b67b6cfb0026a 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 9769c9162ac52f608c5a62babe0fa47b80a59c5f..3ef05e91bf08d7bef083a1a42ab9459e07bcc8ce 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 fb54ab3b6d1a875fbe05e9002dd7a4a224efb5b2..0cf6c610290cc917e477fa9717915e2d5b4b6046 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 332db20eb244c34e76b2934582f0a532d66882a1..ab8985985930635d9cff7699336216e847f6a89b 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 f17833b45e260b1b73d012f65e53c1172f4a29dc..bd00696c7093c876c71a02c9b63e38d38d84fdfb 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 7f6b9daba79156936033e1e8db041d61493f400e..4337b84deecc38226abfcd63cba9944e796483dd 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 534b742138a917c8c81daadaf94b80533d791c9c..75f4ae692993dc831fbab126cbfb3c8509c5ffe1 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 62e4c0f5e0dda5b396a81fa0fb5ad27396082e9e..aec9c87ea9b4e0d74e74cb87b65d958ebfbe823a 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 0b98cea916f7ecf64332aa075a823ba91b5bdcdc..0015cf956430ffc693d8bbdf9b220c0f866e2e0d 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 62e4c0f5e0dda5b396a81fa0fb5ad27396082e9e..aec9c87ea9b4e0d74e74cb87b65d958ebfbe823a 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 ca3ad3b04a7dc76409fa581e1f7ae5fd08099743..b66028a3ef5d896d0851932e0150cd8e7f130b14 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 bcead07f8bec78dde66e28f2c4a06cf58817fe10..ce6a759890eece4c24fcf2bf5b3867fb5a58d2bf 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 40a997ccad0c126db016abcd166fc8e8da77328a..daeace7306b9cded105ebd05e37ea67a011687ac 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 d49161ffc16cddf22f47c9c335c9c321f68a38f8..3f5ce5e371c9628f16ee5c45dd75c483b800dade 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 dedde20b8868fee98f0977984beaa1754d2354fb..89756abbf44c185923c9247ff662a45643101ee2 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 e228aae760870a7a7462bf730570cb54de7821b9..5918bd21def965c707fddf09c14a45f65991e575 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 68bec7ace8c8caa10cf0921953eef7c2a9466850..b686c0b32923648cb9a03429c2615ac63344d25a 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 cd347e681d5d65eb791638b293ef08442c0afab3..a0b0ec879dcb3badc611848b16b52ca750bbb69a 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 fe2d2470d6a6f2c9ae4b1cc15b3f68bffa7606ea..cc16db63f4e13d84861a4b17c55ca746fac52c3c 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 d7fd7d25531a44c6d5e7359a6cb43c1675323e7b..7104d2f6608267c7c6d241dc1a3ea5d9575c244d 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 4327d0e3b8f0b064161d204e5e7caf0c18ebbd40..c305260be4481bc5104ce6fa1fe11e16afdfd489 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 b6ea8ec2fa2e817a2f4f176b9f9c58b527726ee8..8ec833515460b4ebac12230b0b1160969a7ef3c1 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 9c43db390281d38421789d410b5c7f3986b00203..19d621fef8b02bbed32f44a684fbd466bf50fbaf 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 015f728f13bba1066de34c5c941ddbb5c1c7922c..81ea8ada9bb1900ab69241223bcae90774db6c97 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 68c5c4d89e65269415fde44756fd21a9530d30f2..055d766d2f58cc0d8434408f08095c5514cd2b3d 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 8a89515d52b67cce440026cec4e286a31a1f88f9..8c111f6b2b776ea34a4ffcdf1b8daef1213a8ffd 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 4709a8ab55f07cb7b1ccb8df7ca847cd775abbc9..b10405e57efc9418d3152aa52ded8241a233203c 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 fabd567fb15041a015accaa42927e56de14abae2..4818f02b3bad7021201d751305aeebd25ff3a524 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 4743324dc2dfc04dd6d468806d3bba055374b1c0..e7115fa4a0a26f656eb7c8ad70ab826268c809a5 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 afd0d66ff8c2e10dbb03f9ff565f5371da59867b..8de317865cbc0b91d62530143894e76ed441d764 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 4a82c164e5c1031fb3bc4b46b832a6f39112e9fa..13088b60be2c65a0805c943587805e8fe5e7b011 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 b4f073f7ebc6d57cda674b7a5e8317e4b503af03..4201a749dc0f1dac0b1e6dc2523ff4b26415b112 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 653df984c325aa10e8c6ecaf9dfd222f750716db..1381b6b01b630d054b947c657a519b0a75f217fd 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 a54a165695f962be90dfb1591a1bfb3f50e4bbbf..c582161d832e625effea1feaf9e0e885e8990410 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 edd7eb91bab69d2e9aa287648daf2716ce657b76..eb27c72493e1935d24543405a7affecbc8281599 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 16da5ae384682dab411e3be2e1112e1676640915..5be8d611f525d9f9ef23d5af16c49d701f77bc69 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 f9fc72a242585d9a2735498c78a02f41df377b28..10412933a95a703e8d3bb9415387868bf246f5f6 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 658689b1fcc0047da7d4cbf861427f94055efed8..e15bfadb350f1cf5d018b91642e9328936a5d8a5 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 3536e562e2429b1ddc141827e3eac0c53c70bae2..45c98e25913c4eea6eba14ce33cfb8af47581fcd 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 ec806eec46ec593dea23e55d7c8141f31c84bc8d..e04634cd508542be0e280eed9dfffefe4853b870 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 9660522311071e18e8f8405c34d1da0b9ee59688..5baf65c894be7df318ef96e2bad152ba8d6af4a0 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 d5422dd2b94e7f0d496fc03f56226f3fdf97b912..cf11257e40dc60c524772c4bb0b7c874b9bd8d2a 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 32b0f423d0e3bf6b25c9b2c1ea189a6552c2c515..83d30108f6f8009c76e33a06a11d5591a7531be1 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 a8419e141d68f5f220175baea615cbf1e4bdc1b9..43fa1ec61b87d38ded11a7e600884b5cba011272 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 c9a860d9aa0c29f8813641eb33ab0894ebb10e01..cfeb3714fff3f1eb701d17430f397f4d7b058b25 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 9f10031056ae690139301131df9b6d7779b19c1a..5b230fcb815c30afcb8667237fcda9c019493e8a 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 8807ac7de236117062f552b8b37b0be27042c919..6b5c287d1da51bc93e7fb64324e8258fea9be9af 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 89c9eca08bf6e03bf99e1d7a28ea603abb843740..337d2f1ac6d30db9d61821fac4ab8f329597d9e4 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 30c2e779027d54f35b3cd0f72d37c86343d1d9fa..dc11588056670dc36cf8c469cd5ab2a725776d09 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 1e628e77516c37d2fdc6f4e149eb252000d9a13a..43c6c70534991223fbe7421e7435adf5a8059423 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 e38063e5c5ef7089604fc5dc26eec5febac7d96a..5c77a0dacc53367953c70c18a426f19d79660e37 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 aed6b65499d3d0c5d8b14779d5c6361ae8c5f4e9..1d2c9baaadba187c399ba7b3310c2de8888a4eb1 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 9ed16beadef01bc98021569d842460027e070a0d..d64fb74d3ff72c1d02f6e39bf700fa18dd371f25 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 eab0167b89b7a423bc2bc378aa29aac62a5558eb..ff43a35b1b05e5c87028c2adc94d66aa987d5632 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 f02ee2f5454c983d982ed3cfbce8be0a376f5a0d..89983855c1134a0eba61194e7dff574cc700281b 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 856b77f86150af6f560f6ff5b094bd8064dab046..a047ac068f7223adf840e17de46d2dbbd709b127 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 6d82c096d985a049837ee9aaeaecbf14825a4ead..de05425ea4e648489077d422d0c971a58b7122a8 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 503772d05184a23e2d8d0b0417ae935cd289410d..58fc63e453a2c84f2ed6946ab2c959eae953b185 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 af11dedc30247c0b3d353eba81122e5ea83a8b15..feec632624112ddeceb2e0d91411c24fc998239f 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 9abcb67d0456a4623a7b6300ea9bbc0eba6cf052..1d1c7d689bb9e166a6e438c1aeffec58553bd318 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