diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs
index 6aca11c92ef3ef23b0c5ea59c548d603dde2c5be..a1161e1901c453d769242119a85f4382a9c30000 100644
--- a/.git-blame-ignore-revs
+++ b/.git-blame-ignore-revs
@@ -28,3 +28,5 @@ dda0510ea1384860c002b26bc4986eae1dc60cc8
e1b60790e0e28fbbd63f20413da3833a1870cc6e
51657544aea02e55761c6e12b0ec315f9047d5d5
dc99367c8f4a95d53ec7ce6187892b91fbfd4c1f
+0e05285bd47c752f57c190683608527599fa5afb
+a767fdcb7adda81a5ef192733ef7c62fd56b30e2
diff --git a/Changelog b/Changelog
index 03c0876f36c37f6fcafc6c2e2aa9697d777ef149..548eeb625b16af96e1bc72f5b455f8b5ea7cbc44 100644
--- a/Changelog
+++ b/Changelog
@@ -18,9 +18,11 @@
Open Source Release <next-release>
##################################
+* Kernel [2022-02-17] Reject programs using unsupported
+ vector_size attribute (fixes ##2573)
* Kernel [2022-02-08] Reject array whose size is too big with a proper
error message instead of a crash (fixes ##2590)
-o! Kernel [2022-02-19] Removed obsolete AST nodes IndexPI and Info
+o! Kernel [2022-01-19] Removed obsolete AST nodes IndexPI and Info
o! Kernel [2021-12-03] Remove unused AST node Dcustom_annot and field
fpadding_in_bits. Do not cache size of types in the AST but in
a dedicated table.
diff --git a/Makefile b/Makefile
index 0dd665f826204332ab4022ab8055f520d83ff2a7..1f7e8aa1b65e8dd91349cd63274047522d8a186a 100644
--- a/Makefile
+++ b/Makefile
@@ -257,6 +257,7 @@ DISTRIB_FILES:=\
$(LIBC_FILES) \
share/analysis-scripts/analysis.mk \
share/analysis-scripts/benchmark_database.py \
+ share/analysis-scripts/build.py \
share/analysis-scripts/build_callgraph.py \
share/analysis-scripts/cmd-dep.sh \
share/analysis-scripts/concat-csv.sh \
@@ -274,7 +275,6 @@ DISTRIB_FILES:=\
share/analysis-scripts/heuristic_list_functions.py \
share/analysis-scripts/list_files.py \
share/analysis-scripts/list_functions.ml \
- share/analysis-scripts/make_template.py \
share/analysis-scripts/make_wrapper.py \
share/analysis-scripts/normalize_jcdb.py \
share/analysis-scripts/parse-coverage.sh \
@@ -284,6 +284,7 @@ DISTRIB_FILES:=\
share/analysis-scripts/results_display.py \
share/analysis-scripts/script_for_creduce_fatal.sh \
share/analysis-scripts/script_for_creduce_non_fatal.sh \
+ share/analysis-scripts/source_filter.py \
share/analysis-scripts/summary.py \
share/analysis-scripts/template.mk \
$(wildcard share/emacs/*.el) share/autocomplete_frama-c \
@@ -784,7 +785,7 @@ PLUGIN_NAME:=Metrics
PLUGIN_DISTRIBUTED:=yes
PLUGIN_DIR:=src/plugins/metrics
PLUGIN_CMO:= metrics_parameters css_html metrics_base metrics_acsl \
- metrics_cabs metrics_cilast metrics_coverage \
+ metrics_cabs metrics_cilast metrics_coverage metrics_pivot \
register
PLUGIN_GUI_CMO:= metrics_gui register_gui
PLUGIN_DEPENDENCIES:=Eva
@@ -811,8 +812,9 @@ PLUGIN_CMI:= callgraph_api
PLUGIN_INTERNAL_TEST:=yes
PLUGIN_TESTS_DIRS:=callgraph
PLUGIN_TESTS_LIB:=tests/callgraph/function_pointer.ml
-$(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME)))
+PLUGIN_DEPENDENCIES:=Eva
+$(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME)))
##################
# Evolved Value Analysis #
@@ -825,6 +827,8 @@ PLUGIN_EXTRA_DIRS:=engine values domains api domains/cvalue domains/apron \
domains/gauges domains/equality legacy partitioning utils gui_files \
api values/numerors domains/numerors
PLUGIN_TESTS_DIRS+=value/traces
+PLUGIN_GENERATED:=$(PLUGIN_DIR)/Eva.mli
+PLUGIN_DISTRIB_EXTERNAL+=gen-api.sh
# Files for the binding to Apron domains. Only available if Apron is available.
ifeq ($(HAS_APRON),yes)
@@ -855,9 +859,9 @@ endif
# General rules for ordering files within PLUGIN_CMO:
# - try to keep the legacy Value before Eva
-PLUGIN_CMO:= partitioning/split_strategy domains/domain_mode value_parameters \
- utils/eva_audit utils/value_perf utils/eva_annotations \
- utils/eva_dynamic utils/value_util utils/red_statuses \
+PLUGIN_CMO:= partitioning/split_strategy domains/domain_mode self parameters \
+ utils/eva_audit utils/eva_perf utils/eva_annotations \
+ utils/eva_dynamic utils/eva_utils utils/red_statuses \
utils/mark_noresults \
utils/widen_hints_ext utils/widen \
partitioning/split_return \
@@ -885,7 +889,7 @@ PLUGIN_CMO:= partitioning/split_strategy domains/domain_mode value_parameters \
domains/sign_domain \
domains/cvalue/warn domains/cvalue/locals_scoping \
domains/cvalue/cvalue_offsetmap \
- utils/value_results \
+ utils/eva_results \
utils/summary \
domains/cvalue/builtins domains/cvalue/builtins_malloc \
domains/cvalue/builtins_string domains/cvalue/builtins_misc \
@@ -908,7 +912,7 @@ PLUGIN_CMO:= partitioning/split_strategy domains/domain_mode value_parameters \
domains/taint_domain \
$(APRON_CMO) $(NUMERORS_CMO) \
api/general_requests api/values_request \
- utils/unit_tests
+ utils/unit_tests utils/results
PLUGIN_CMI:= values/abstract_value values/abstract_location \
domains/abstract_domain domains/simpler_domains
PLUGIN_DEPENDENCIES:=Server
@@ -927,8 +931,26 @@ VALUE_TYPES:=$(addprefix src/plugins/value_types/,\
PLUGIN_TYPES_CMO:=$(VALUE_TYPES)
PLUGIN_TYPES_TODOC:=$(addsuffix .mli,$(VALUE_TYPES))
+# Eva API.
+API_MLI := $(addprefix $(PLUGIN_DIR)/, \
+ engine/analysis.mli utils/results.mli \
+ parameters.mli utils/eva_annotations.mli \
+ eval.mli domains/cvalue/builtins.mli \
+ legacy/eval_terms.mli utils/eva_results.mli utils/unit_tests.mli)
+
+$(PLUGIN_DIR)/Eva.mli: $(PLUGIN_DIR)/gen-api.sh Makefile $(API_MLI)
+ $(PRINT_MAKING) $@
+ $(RM) $@ $@.tmp
+ $< $(API_MLI) > $@.tmp
+ $(CHMOD_RO) $@.tmp
+ $(MV) $@.tmp $@
+
+clean::
+ $(RM) $(PLUGIN_DIR)/Eva.mli
+
$(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME)))
+
#########
# Reduc #
#########
@@ -1037,6 +1059,8 @@ PLUGIN_CMO:= postdominators_parameters print compute
PLUGIN_NO_TEST:=yes
PLUGIN_DISTRIBUTED:=yes
PLUGIN_INTERNAL_TEST:=yes
+PLUGIN_DEPENDENCIES:=Eva
+
$(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME)))
#########
@@ -1953,6 +1977,8 @@ install:: install-lib-$(OCAMLBEST)
$(CP) \
share/analysis-scripts/analysis.mk \
share/analysis-scripts/benchmark_database.py \
+ share/analysis-scripts/build.py \
+ share/analysis-scripts/build_callgraph.py \
share/analysis-scripts/cmd-dep.sh \
share/analysis-scripts/concat-csv.sh \
share/analysis-scripts/clone.sh \
@@ -1966,7 +1992,6 @@ install:: install-lib-$(OCAMLBEST)
share/analysis-scripts/git_utils.py \
share/analysis-scripts/list_files.py \
share/analysis-scripts/list_functions.ml \
- share/analysis-scripts/make_template.py \
share/analysis-scripts/make_wrapper.py \
share/analysis-scripts/normalize_jcdb.py \
share/analysis-scripts/parse-coverage.sh \
@@ -1975,6 +2000,7 @@ install:: install-lib-$(OCAMLBEST)
share/analysis-scripts/results_display.py \
share/analysis-scripts/script_for_creduce_fatal.sh \
share/analysis-scripts/script_for_creduce_non_fatal.sh \
+ share/analysis-scripts/source_filter.py \
share/analysis-scripts/summary.py \
share/analysis-scripts/template.mk \
$(FRAMAC_DATADIR)/analysis-scripts
diff --git a/bin/frama-c-script b/bin/frama-c-script
index 4a4c1d16e9c420bf663462df85fcfaa27dd044d7..014772a4d0b9acd3bd1918dcaa00670f64dea5b9 100755
--- a/bin/frama-c-script
+++ b/bin/frama-c-script
@@ -36,6 +36,10 @@ usage() {
echo ""
echo " where cmd is:"
echo ""
+ echo " - build [--jbdb build_commands.json] [--sources file...]"
+ echo " Produces a GNUmakefile for Frama-C analyses."
+ echo " Uses a build_commands.json if available."
+ echo ""
echo " - configure machdep"
echo " Runs an existing configure script to only consider files"
echo " in Frama-C's libc; this will hopefully disable non-essential"
@@ -91,10 +95,6 @@ usage() {
echo " definitions, with source location and number of statements."
echo " Accepts Frama-C options (e.g. -cpp-extra-args for parsing)."
echo ""
- echo " - make-template [dir]"
- echo " Interactively prepares a template for analyses,"
- echo " writing it to dir/GNUmakefile [default: .frama-c]."
- echo ""
echo " - make-wrapper target arg..."
echo " Runs 'make target arg...', parsing the output to suggest"
echo " useful commands in case of failure."
@@ -217,9 +217,9 @@ case "$command" in
"help" | "-help" | "--help" | "-h")
usage 0;
;;
- "make-template")
+ "build")
shift;
- "${FRAMAC_SHARE}"/analysis-scripts/make_template.py "$@";
+ ${FRAMAC_SHARE}/analysis-scripts/build.py "$@";
;;
"list-files")
shift;
diff --git a/configure.in b/configure.in
index 54d56f2f332a02e82021d094e5031ac2a9be11d3..faaf96d4eca57a97b791b6d0c7ceeb19c930740c 100644
--- a/configure.in
+++ b/configure.in
@@ -783,6 +783,7 @@ plugin_require(inout,callgraph)
#########
check_plugin(metrics,src/plugins/metrics,[support for metrics analysis],yes)
+plugin_require(metrics,server)
plugin_require(metrics,eva)
plugin_use(metrics,gui)
diff --git a/doc/developer/advance.tex b/doc/developer/advance.tex
index 508230d7c8c933b49215876099e358da74ff20ed..906403ec31d7d23a95bc4be30992c333c53901f1 100644
--- a/doc/developer/advance.tex
+++ b/doc/developer/advance.tex
@@ -2487,10 +2487,10 @@ following.
~
\begin{ocamlcode}
-!Db.Value.compute();
-Kernel.feedback "%B" (Db.Value.is_computed ()); (* true *)
+Eva.Analysis.compute();
+Kernel.feedback "%B" (Eva.Analysis.is_computed ()); (* true *)
Globals.set_entry_point "f" true;
-Kernel.feedback "%B" (Db.Value.is_computed ()); (* false *)
+Kernel.feedback "%B" (Eva.Analysis.is_computed ()); (* false *)
\end{ocamlcode}
As the value analysis has been automatically reset when setting the entry point,
the above code outputs
@@ -2548,7 +2548,7 @@ let compute_info (kf,vi) = ...
let memoize s =
try Stmt.Hashtbl.find state s
with Not_found -> Stmt.Hashtbl.add state s (compute_info s)
-let run () = ... !Db.Value.compute (); ... memoize some_stmt ...
+let run () = ... Eva.Analysis.compute (); ... memoize some_stmt ...
\end{ocamlcode}
However, if one puts this code inside \framac, it does not work because this
@@ -2570,7 +2570,7 @@ module State =
end)
let compute_info (kf,vi) = ...
let memoize = State.memo compute_info
-let run () = ... !Db.Value.compute (); ... memoize some_stmt ...
+let run () = ... Eva.Analysis.compute (); ... memoize some_stmt ...
\end{ocamlcode}
A quick look on this code shows that the declaration of the state itself is more
complicated (it uses a functor application) but its use is
@@ -2870,14 +2870,14 @@ value analysis has never been computed previously)
\scodeidx{Project}{IOError}
\begin{ocamlcode}
let print_computed () =
- Kernel.feedback "%B" (Db.Value.is_computed ())
+ Kernel.feedback "%B" (Eva.Analysis.is_computed ())
in
print_computed (); (* false *)
let old = Project.current () in
try
let foo = Project.load ~name:"foo" "foo.sav" in
Project.set_current foo;
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
print_computed (); (* true *)
Project.set_current old;
print_computed () (* false *)
@@ -2913,13 +2913,13 @@ The following code is equivalent to the one given in
Example~\ref{ex:set_current}.
\begin{ocamlcode}
let print_computed () =
- Value_parameters.feedback "%B" (Db.Value.is_computed ())
+ Value_parameters.feedback "%B" (Eva.Analysis.is_computed ())
in
print_computed (); (* false *)
try
let foo = Project.load ~name:"foo" "foo.sav" in
Project.on foo
- (fun () -> !Db.Value.compute (); print_computed () (* true *)) ();
+ (fun () -> Eva.Analysis.compute (); print_computed () (* true *)) ();
print_computed () (* false *)
with Project.IOError _ ->
exit 1
diff --git a/doc/developer/check_api/run.oracle b/doc/developer/check_api/run.oracle
index 769847618c69cf2f9ca6f482711374dd559b3953..c5b9bea960a39741875927a46cfaee4c321bb3ec 100644
--- a/doc/developer/check_api/run.oracle
+++ b/doc/developer/check_api/run.oracle
@@ -96,7 +96,7 @@ Logic_utils.expr_to_term/cast:bool -> Cil_types.exp -> Cil_types.term/translates
Journal/(string -> string) Pervasives.refend /Journalization of functions./
Cil.cilVisitor.vstmt/Cil_types.stmt -> Cil_types.stmt Cil.visitAction/Control-flow statement. The default DoChildren action does not create a new statement when the components change. Instead it updates the contents of the original statement. This is done to preserve the sharing with Goto and Case statements that point to the original statement. If you use the ChangeTo action then you should take care of preserving that sharing yourself./
Cil.get_varinfo/Cil.visitor_behavior -> Cil_types.varinfo -> Cil_types.varinfo/retrieve the representative of a given varinfo in the current state of the visitor/
-Db.Value.is_computed/unit -> bool/Return true iff the value analysis has been done./
+Eva.Analysis.is_computed/unit -> bool/Return true iff the value analysis has been done./
Kernel.Unicode/('a -> 'b) -> 'a -> 'bend /Behavior of option "-unicode"./
Design.register_extension/(Design.main_window_extension_points -> unit) -> unit/Register an extension to the main GUI. It will be invoked at initialization time./
Cil_types.global/ | GType of Cil_types.typeinfo * Cil_types.location | GCompTag of Cil_types.compinfo * Cil_types.location | GCompTagDecl of Cil_types.compinfo * Cil_types.location | GEnumTag of Cil_types.enuminfo * Cil_types.location | GEnumTagDecl of Cil_types.enuminfo * Cil_types.location | GVarDecl of Cil_types.varinfo * Cil_types.location | GFunDecl of Cil_types.funspec * Cil_types.varinfo * Cil_types.location | GVar of Cil_types.varinfo * Cil_types.initinfo * Cil_types.location | GFun of Cil_types.fundec * Cil_types.location | GAsm of string * Cil_types.location | GPragma of Cil_types.attribute * Cil_types.location | GText of string | GAnnot of Cil_types.global_annotation * Cil_types.location/The main type for representing global declarations and definitions. A list of these form a CIL file. The order of globals in the file is generally important./
diff --git a/doc/developer/tutorial/viewcfg/src/dump_function_memo_clear_cache.ml b/doc/developer/tutorial/viewcfg/src/dump_function_memo_clear_cache.ml
index 3a83c607bb9f1075517684d443f10c25305c122f..36eb30f11660c19bc89f3524067d71382e014733 100644
--- a/doc/developer/tutorial/viewcfg/src/dump_function_memo_clear_cache.ml
+++ b/doc/developer/tutorial/viewcfg/src/dump_function_memo_clear_cache.ml
@@ -1,5 +1,5 @@
let dump_function fundec fmt =
- if not (Value_is_computed.get ()) && Db.Value.is_computed () then begin
+ if not (Value_is_computed.get ()) && Eva.Analysis.is_computed () then begin
Value_is_computed.set true;
let selection = State_selection.with_dependencies Cfg_graph_state.self in
Project.clear ~selection ();
diff --git a/doc/developer/tutorial/viewcfg/src/print_cfg_vstmt_aux_value.ml b/doc/developer/tutorial/viewcfg/src/print_cfg_vstmt_aux_value.ml
index 04446722a1f84abc19e1553058e7cc6f4ad2a5f8..67038d53098490e5c6d7b14991dac834b5b9e9a9 100644
--- a/doc/developer/tutorial/viewcfg/src/print_cfg_vstmt_aux_value.ml
+++ b/doc/developer/tutorial/viewcfg/src/print_cfg_vstmt_aux_value.ml
@@ -1,6 +1,6 @@
method! vstmt_aux s =
let color =
- if Db.Value.is_computed () then
+ if Eva.Analysis.is_computed () then
let state = Db.Value.get_stmt_state s in
let reachable = Db.Value.is_reachable state in
if reachable then "fillcolor=\"#ccffcc\" style=filled"
diff --git a/doc/training/developer/project.tex b/doc/training/developer/project.tex
index 98e08c503c07304da355bff6274bb29fbcde8398..8af2d2bceb399a059fc13eeb0438d6119316513c 100644
--- a/doc/training/developer/project.tex
+++ b/doc/training/developer/project.tex
@@ -175,7 +175,7 @@ let main () =
~select_annot:false
~select_slice_pragma:false
in
- Project.on p !Db.Value.compute ()
+ Project.on p Eva.Analysis.compute ()
\end{ocamlcode}
\end{itemize}
diff --git a/doc/training/developer/sources/basic_script.ml b/doc/training/developer/sources/basic_script.ml
index a9160149a1cbdab32d79dd1d34a89a53c04ff4b1..fd83c661bb190de5faf19f44fb978f59641aa548 100644
--- a/doc/training/developer/sources/basic_script.ml
+++ b/doc/training/developer/sources/basic_script.ml
@@ -10,7 +10,7 @@ let run f () =
incr nb_entry_points;
Kernel.MainFunction.set f;
Kernel.LibEntry.on ();
- !Db.Value.compute ()
+ Eva.Analysis.compute ()
(*# Main driver function*)
let all_entry_points () =
diff --git a/doc/training/developer/sources/const_violation.ml b/doc/training/developer/sources/const_violation.ml
index e057b7fbf7701f7492ff6aebc14db153cfec0c57..2eadb5524debd6e35c3ca20913df90252636c07a 100644
--- a/doc/training/developer/sources/const_violation.ml
+++ b/doc/training/developer/sources/const_violation.ml
@@ -3,7 +3,7 @@ let run () =
let glob = Globals.Vars.find_from_astinfo "Glob" Cil_types.VGlobal in
let glob_expr = Cil.evar ~loc:Cil_datatype.Location.unknown glob in
let main = Globals.Functions.find_by_name "main" in
- let () = !Db.Value.compute () in
+ let () = Eva.Analysis.compute () in
let init_stmt = Kernel_function.find_first_stmt main in
let init_state = Db.Value.get_stmt_state init_stmt in
let end_stmt = Kernel_function.find_return main in
diff --git a/doc/userman/analysis-scripts.graphml b/doc/userman/analysis-scripts.graphml
index 2c798633e54136b20090b02b064c625b8167cfdc..1a5c42041381b8a2a670fda6d7817782016047f3 100644
--- a/doc/userman/analysis-scripts.graphml
+++ b/doc/userman/analysis-scripts.graphml
@@ -1,6 +1,6 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<graphml xmlns="http://graphml.graphdrawing.org/xmlns" xmlns:java="http://www.yworks.com/xml/yfiles-common/1.0/java" xmlns:sys="http://www.yworks.com/xml/yfiles-common/markup/primitives/2.0" xmlns:x="http://www.yworks.com/xml/yfiles-common/markup/2.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:y="http://www.yworks.com/xml/graphml" xmlns:yed="http://www.yworks.com/xml/yed/3" xsi:schemaLocation="http://graphml.graphdrawing.org/xmlns http://www.yworks.com/xml/schema/graphml/1.1/ygraphml.xsd">
- <!--Created by yEd 3.19-->
+ <!--Created by yEd 3.21.1-->
<key attr.name="Description" attr.type="string" for="graph" id="d0"/>
<key for="port" id="d1" yfiles.type="portgraphics"/>
<key for="port" id="d2" yfiles.type="portgeometry"/>
@@ -13,7 +13,7 @@
<key attr.name="description" attr.type="string" for="edge" id="d9"/>
<key for="edge" id="d10" yfiles.type="edgegraphics"/>
<graph edgedefault="directed" id="G">
- <data key="d0"/>
+ <data key="d0" xml:space="preserve"/>
<node id="n0">
<data key="d6">
<y:ShapeNode>
@@ -64,7 +64,6 @@ OS)<y:LabelModel><y:SmartNodeLabelModel distance="4.0"/></y:LabelModel><y:ModelP
</node>
<node id="n4" yfiles.foldertype="group">
<data key="d4" xml:space="preserve"/>
- <data key="d5"/>
<data key="d6">
<y:ProxyAutoBoundsNode>
<y:Realizers active="0">
@@ -142,12 +141,11 @@ metrics.log<y:LabelModel><y:SmartNodeLabelModel distance="4.0"/></y:LabelModel><
</node>
<node id="n5" yfiles.foldertype="group">
<data key="d4" xml:space="preserve"/>
- <data key="d5"/>
<data key="d6">
<y:ProxyAutoBoundsNode>
<y:Realizers active="0">
<y:GroupNode>
- <y:Geometry height="254.93886947631842" width="159.0" x="909.7975425720215" y="426.6656832358396"/>
+ <y:Geometry height="254.9388694763183" width="159.0" x="909.7975425720215" y="426.6656832358397"/>
<y:Fill color="#F5F5F5" transparent="false"/>
<y:BorderStyle color="#000000" type="dashed" width="1.0"/>
<y:NodeLabel alignment="right" autoSizePolicy="node_width" backgroundColor="#EBEBEB" borderDistance="0.0" fontFamily="Noto Sans" fontSize="20" fontStyle="plain" hasLineColor="false" height="31.239974975585938" horizontalTextPosition="center" iconTextGap="4" modelName="internal" modelPosition="t" textColor="#000000" verticalTextPosition="bottom" visible="true" width="159.0" x="0.0" xml:space="preserve" y="0.0"><target>.eva </y:NodeLabel>
@@ -176,7 +174,7 @@ metrics.log<y:LabelModel><y:SmartNodeLabelModel distance="4.0"/></y:LabelModel><
<y:Geometry height="123.69433229296885" width="149.0" x="914.7975425720215" y="465.51937416674775"/>
<y:Fill color="#99CCFF" transparent="false"/>
<y:BorderStyle hasColor="false" raised="false" type="line" width="1.0"/>
- <y:NodeLabel alignment="left" autoSizePolicy="node_size" fontFamily="Noto Sans" fontSize="18" fontStyle="plain" hasBackgroundColor="false" hasLineColor="false" height="126.57923126220703" horizontalTextPosition="center" iconTextGap="4" modelName="custom" textColor="#000000" verticalTextPosition="bottom" visible="true" width="149.0" x="0.0" xml:space="preserve" y="-1.4424494846191465">alarms.csv
+ <y:NodeLabel alignment="left" autoSizePolicy="node_size" fontFamily="Noto Sans" fontSize="18" fontStyle="plain" hasBackgroundColor="false" hasLineColor="false" height="126.57923126220703" horizontalTextPosition="center" iconTextGap="4" modelName="custom" textColor="#000000" verticalTextPosition="bottom" visible="true" width="149.0" x="0.0" xml:space="preserve" y="-1.4424494846190328">alarms.csv
eva.log
warnings.log
metrics.log
@@ -273,7 +271,7 @@ Results<y:LabelModel><y:SmartNodeLabelModel distance="4.0"/></y:LabelModel><y:Mo
<node id="n11">
<data key="d6">
<y:ShapeNode>
- <y:Geometry height="93.0" width="284.0" x="178.625" y="601.8519359999999"/>
+ <y:Geometry height="93.0" width="284.0" x="178.625" y="595.6158232777708"/>
<y:Fill color="#C0C0C0" transparent="false"/>
<y:BorderStyle hasColor="false" raised="false" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Noto Sans" fontSize="20" fontStyle="plain" hasBackgroundColor="false" hasLineColor="false" height="85.71992492675781" horizontalTextPosition="center" iconTextGap="4" modelName="custom" textColor="#000000" verticalTextPosition="bottom" visible="true" width="264.419677734375" x="9.7901611328125" xml:space="preserve" y="3.6400375366210938">(Optional)
@@ -283,6 +281,19 @@ JSON Compilation Database
</y:ShapeNode>
</data>
</node>
+ <node id="n12">
+ <data key="d6">
+ <y:ShapeNode>
+ <y:Geometry height="93.0" width="284.0" x="209.625" y="700.8797105555417"/>
+ <y:Fill color="#C0C0C0" transparent="false"/>
+ <y:BorderStyle hasColor="false" raised="false" type="line" width="1.0"/>
+ <y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Noto Sans" fontSize="20" fontStyle="plain" hasBackgroundColor="false" hasLineColor="false" height="85.71992492675781" horizontalTextPosition="center" iconTextGap="4" modelName="custom" textColor="#000000" verticalTextPosition="bottom" visible="true" width="221.27976989746094" x="31.36011505126953" xml:space="preserve" y="3.6400375366210938">(Optional)
+JSON Build Database
+(build_commands.json)<y:LabelModel><y:SmartNodeLabelModel distance="4.0"/></y:LabelModel><y:ModelParameter><y:SmartNodeLabelModelParameter labelRatioX="0.0" labelRatioY="0.0" nodeRatioX="0.0" nodeRatioY="0.0" offsetX="0.0" offsetY="0.0" upX="0.0" upY="-1.0"/></y:ModelParameter></y:NodeLabel>
+ <y:Shape type="rectangle"/>
+ </y:ShapeNode>
+ </data>
+ </node>
<edge id="e0" source="n0" target="n1">
<data key="d10">
<y:PolyLineEdge>
@@ -373,7 +384,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e5" source="n5::n1" target="n6">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="74.5" sy="0.0" tx="-79.0" ty="0.0"/>
@@ -384,7 +394,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e6" source="n4::n2" target="n6">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="75.21875" sy="0.0" tx="-79.0" ty="0.0"/>
@@ -395,7 +404,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e7" source="n4::n0" target="n8">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="74.859375" sy="0.0" tx="-79.0" ty="0.0"/>
@@ -406,7 +414,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e8" source="n5::n0" target="n8">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="74.5" sy="0.0" tx="-79.0" ty="0.0"/>
@@ -417,7 +424,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e9" source="n4::n1" target="n7">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
@@ -428,7 +434,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e10" source="n4" target="n5">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
@@ -439,7 +444,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e11" source="n5" target="n9">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.7024574279785156" sy="-15.095404432332202" tx="-71.29754257202148" ty="-7.339997013875063"/>
@@ -450,7 +454,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e12" source="n1" target="n9">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="58.97499999999991" sy="2.6637775416665477" tx="0.0" ty="0.0">
@@ -465,7 +468,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e13" source="n4::n3" target="n10">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="75.21875" sy="0.0" tx="-88.5" ty="0.0"/>
@@ -476,7 +478,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e14" source="n5::n2" target="n10">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="74.5" sy="0.0" tx="-88.5" ty="0.0"/>
@@ -496,7 +497,6 @@ JSON Compilation Database
</data>
</edge>
<edge id="e15" source="n11" target="n1">
- <data key="d9"/>
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="43.375" sy="-37.35619205833348" tx="7.111959999999954" ty="1.600377541666603">
@@ -504,7 +504,22 @@ JSON Compilation Database
</y:Path>
<y:LineStyle color="#000000" type="line" width="1.0"/>
<y:Arrows source="none" target="standard"/>
- <y:EdgeLabel alignment="center" backgroundColor="#FFFFFF" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Noto Sans" fontSize="20" fontStyle="plain" hasLineColor="false" height="31.239974975585938" horizontalTextPosition="center" iconTextGap="4" modelName="custom" preferredPlacement="anywhere" ratio="0.5" textColor="#000000" verticalTextPosition="bottom" visible="true" width="146.69981384277344" x="7.325258240567905" xml:space="preserve" y="-209.49274718831396">make-template<y:LabelModel><y:SmartEdgeLabelModel autoRotationEnabled="false" defaultAngle="0.0" defaultDistance="10.0"/></y:LabelModel><y:ModelParameter><y:SmartEdgeLabelModelParameter angle="0.0" distance="30.0" distanceToCenter="true" position="center" ratio="0.8467602870289302" segment="-1"/></y:ModelParameter><y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/></y:EdgeLabel>
+ <y:EdgeLabel alignment="center" backgroundColor="#FFFFFF" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Noto Sans" fontSize="20" fontStyle="plain" hasLineColor="false" height="31.239974975585938" horizontalTextPosition="center" iconTextGap="4" modelName="custom" preferredPlacement="anywhere" ratio="0.5" textColor="#000000" verticalTextPosition="bottom" visible="true" width="51.279937744140625" x="95.43407712665595" xml:space="preserve" y="-203.2500103719077">build<y:LabelModel><y:SmartEdgeLabelModel autoRotationEnabled="false" defaultAngle="0.0" defaultDistance="10.0"/></y:LabelModel><y:ModelParameter><y:SmartEdgeLabelModelParameter angle="0.0" distance="30.0" distanceToCenter="true" position="center" ratio="0.8467602870289302" segment="-1"/></y:ModelParameter><y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/></y:EdgeLabel>
+ <y:BendStyle smoothed="false"/>
+ </y:PolyLineEdge>
+ </data>
+ </edge>
+ <edge id="e16" source="n12" target="n0">
+ <data key="d10">
+ <y:PolyLineEdge>
+ <y:Path sx="124.53899999999999" sy="-14.479710555541715" tx="79.0" ty="0.0">
+ <y:Point x="476.164" y="556.9"/>
+ <y:Point x="364.0" y="556.9"/>
+ <y:Point x="364.0" y="407.9523135416665"/>
+ <y:Point x="364.0" y="314.8519359999999"/>
+ </y:Path>
+ <y:LineStyle color="#000000" type="line" width="1.0"/>
+ <y:Arrows source="none" target="none"/>
<y:BendStyle smoothed="false"/>
</y:PolyLineEdge>
</data>
diff --git a/doc/userman/analysis-scripts.pdf b/doc/userman/analysis-scripts.pdf
index 853e0e687779bd694aa87a1786e28038948769d2..1f8ade25fb74ecba20ff4dccf9bbe7ea9efdfd4e 100644
Binary files a/doc/userman/analysis-scripts.pdf and b/doc/userman/analysis-scripts.pdf differ
diff --git a/doc/userman/user-analysis-scripts.tex b/doc/userman/user-analysis-scripts.tex
index 459e17d0d4ef48f152bd9f82ff72ca7bc046e258..05a4b6b60d39eb91a24d6043e0bd7db42fde673a 100644
--- a/doc/userman/user-analysis-scripts.tex
+++ b/doc/userman/user-analysis-scripts.tex
@@ -77,9 +77,11 @@ and presents an illustrative diagram.
\subsection{Necessary Build Information}
\label{sec:necessary-build-information}
-The command \texttt{frama-c-script make-template} can be used to generate the
-Makefile from a template. The user must fill in the following information,
-required for running an \Value analysis:
+The command \texttt{frama-c-script build} can be used to generate the
+Makefile from a template. To run an analysis with \Value, the following
+information is necessary\footnote{If a \texttt{build\_commands.json} file is
+available, \texttt{frama-c-script build} will try to fill in some of the data
+automatically.}:
\begin{description}
\item[machdep]: architectural information about the system where the code will
@@ -164,9 +166,9 @@ in section~\ref{sec:preprocessing}). This leads to a different workflow:
In both cases, you will obtain a \texttt{compile\_commands.json} file.
\item Run \texttt{frama-c-script list-files}. A list of the compiled files,
along with files defining a \texttt{main} function, will be presented.
-\item Run \texttt{frama-c-script make-template} to create a template for
- \FramaC/\Value. Answer ``yes'' when asked about using the
- \texttt{compile\_commands.json} file.
+\item Run \texttt{frama-c-script build} to create a template for
+ \FramaC/\Value. It should detect the \texttt{compile\_commands.json} file
+ and add the option to enable it.
\end{enumerate}
Ideally, the above approach should result in a working template. In practice,
@@ -382,10 +384,11 @@ The most useful commands are described below.
Run \texttt{frama-c-script help} for more details and optional arguments.
\begin{description}
-\item[make-template]: creates the initial Makefile, based on a template.
+\item[build]: creates the initial Makefile, based on a template.
This command creates a file named \texttt{.frama-c/GNUmakefile} with some
- hardcoded sections, some sections filled in interactively by the user,
- and comments indicating which parts may need change.
+ hardcoded sections, some sections filled in according to command-line
+ options, and some sections filled automatically with build information
+ (via a \texttt{build\_commands.json} file), if available.
Once created, it enables the general workflow mentioned earlier.
\item[make-wrapper <target> <args>]: calls \texttt{make <target> <args>} with
a special wrapper: when running \Value, upon encountering one of a few known
@@ -421,8 +424,7 @@ Other commands, only useful in a few cases, are described below.
The following commands require a JSON Compilation Database.
\begin{description}
-\item[list-files]: lists all files in the given JCDB. Useful for filling
- out the Makefile template when running \texttt{make-template}.
+\item[list-files]: lists all files in the given JCDB.
\item[normalize-jcdb]: converts absolute paths inside a
\texttt{compile\_commands.json} file into relative paths (w.r.t. PWD)
when possible. Used to allow moving/versioning the directory containing
diff --git a/headers/header_spec.txt b/headers/header_spec.txt
index cb21c86bf52c61ebfa4df23d3f566ad493728ae0..3c013f74b22470bbbd8b35de055ce034a8b8f281 100644
--- a/headers/header_spec.txt
+++ b/headers/header_spec.txt
@@ -116,6 +116,7 @@ ptests/ptests.ml: CEA_LGPL
share/_frama-c: CEA_LGPL
share/analysis-scripts/analysis.mk: CEA_LGPL
share/analysis-scripts/benchmark_database.py: CEA_LGPL
+share/analysis-scripts/build.py: CEA_LGPL
share/analysis-scripts/build_callgraph.py: CEA_LGPL
share/analysis-scripts/clone.sh: .ignore
share/analysis-scripts/creduce.sh: CEA_LGPL
@@ -133,7 +134,6 @@ share/analysis-scripts/git_utils.py: CEA_LGPL
share/analysis-scripts/heuristic_list_functions.py: CEA_LGPL
share/analysis-scripts/list_files.py: CEA_LGPL
share/analysis-scripts/list_functions.ml: CEA_LGPL
-share/analysis-scripts/make_template.py: CEA_LGPL
share/analysis-scripts/make_wrapper.py: CEA_LGPL
share/analysis-scripts/normalize_jcdb.py: CEA_LGPL
share/analysis-scripts/parse-coverage.sh: .ignore
@@ -143,6 +143,7 @@ share/analysis-scripts/README.md: .ignore
share/analysis-scripts/results_display.py: CEA_LGPL
share/analysis-scripts/script_for_creduce_fatal.sh: .ignore
share/analysis-scripts/script_for_creduce_non_fatal.sh: .ignore
+share/analysis-scripts/source_filter.py: CEA_LGPL
share/analysis-scripts/summary.py: CEA_LGPL
share/analysis-scripts/template.mk: .ignore
share/compliance/c11_functions.json: .ignore
@@ -223,6 +224,7 @@ share/libc/__fc_machdep_linux_shared.h: CEA_LGPL
share/libc/__fc_runtime.c: CEA_LGPL
share/libc/__fc_select.h: CEA_LGPL
share/libc/__fc_string_axiomatic.h: CEA_LGPL
+share/libc/aio.h: CEA_LGPL
share/libc/alloca.h: CEA_LGPL
share/libc/argz.c: CEA_FSF_LGPL
share/libc/argz.h: CEA_FSF_LGPL
@@ -231,11 +233,13 @@ share/libc/assert.c: CEA_LGPL
share/libc/assert.h: CEA_LGPL
share/libc/byteswap.h: CEA_LGPL
share/libc/complex.h: CEA_LGPL
+share/libc/cpio.h: CEA_LGPL
share/libc/ctype.c: CEA_LGPL
share/libc/ctype.h: CEA_LGPL
share/libc/dirent.h: CEA_LGPL
share/libc/dlfcn.h: CEA_LGPL
share/libc/endian.h: CEA_LGPL
+share/libc/err.h: CEA_LGPL
share/libc/errno.c: CEA_LGPL
share/libc/errno.h: CEA_LGPL
share/libc/fcntl.h: CEA_LGPL
@@ -243,6 +247,7 @@ share/libc/features.h: CEA_LGPL
share/libc/fenv.h: CEA_LGPL
share/libc/fenv.c: CEA_LGPL
share/libc/float.h: CEA_LGPL
+share/libc/fmtmsg.h: CEA_LGPL
share/libc/fnmatch.h: CEA_LGPL
share/libc/ftw.h: CEA_LGPL
share/libc/getopt.c: CEA_LGPL
@@ -264,8 +269,11 @@ share/libc/malloc.h: CEA_LGPL
share/libc/math.c: CEA_LGPL
share/libc/math.h: CEA_LGPL
share/libc/memory.h: CEA_LGPL
+share/libc/monetary.h: CEA_LGPL
+share/libc/mqueue.h: CEA_LGPL
share/libc/n1336.pdf: .ignore
share/libc/n1362.pdf: .ignore
+share/libc/ndbm.h: CEA_LGPL
share/libc/net/if.h: CEA_LGPL
share/libc/netdb.c: CEA_LGPL
share/libc/netdb.h: CEA_LGPL
@@ -280,10 +288,12 @@ share/libc/pwd.h: CEA_LGPL
share/libc/regex.h: CEA_LGPL
share/libc/resolv.h: CEA_LGPL
share/libc/sched.h: CEA_LGPL
+share/libc/search.h: CEA_LGPL
share/libc/semaphore.h: CEA_LGPL
share/libc/setjmp.h: CEA_LGPL
share/libc/signal.c: CEA_LGPL
share/libc/signal.h: CEA_LGPL
+share/libc/spawn.h: CEA_LGPL
share/libc/stdalign.h: CEA_LGPL
share/libc/stdarg.h: CEA_LGPL
share/libc/stdatomic.c: CEA_LGPL
@@ -304,11 +314,13 @@ share/libc/sys/file.h: CEA_LGPL
share/libc/sys/ioctl.h: CEA_LGPL
share/libc/sys/ipc.h: CEA_LGPL
share/libc/sys/mman.h: CEA_LGPL
+share/libc/sys/msg.h: CEA_LGPL
share/libc/sys/param.h: CEA_LGPL
share/libc/sys/random.h: CEA_LGPL
share/libc/sys/resource.h: CEA_LGPL
share/libc/sys/select.h: CEA_LGPL
share/libc/sys/sendfile.h: CEA_LGPL
+share/libc/sys/sem.h: CEA_LGPL
share/libc/sys/shm.h: CEA_LGPL
share/libc/sys/signal.h: CEA_LGPL
share/libc/sys/socket.h: CEA_LGPL
@@ -324,18 +336,23 @@ share/libc/sys/utsname.h: CEA_LGPL
share/libc/sys/vfs.h: CEA_LGPL
share/libc/sys/wait.h: CEA_LGPL
share/libc/syslog.h: CEA_LGPL
+share/libc/tar.h: CEA_LGPL
share/libc/termios.h: CEA_LGPL
share/libc/tgmath.h: CEA_LGPL
share/libc/time.c: CEA_LGPL
share/libc/time.h: CEA_LGPL
+share/libc/trace.h: CEA_LGPL
+share/libc/ulimit.h: CEA_LGPL
share/libc/unistd.c: CEA_LGPL
share/libc/unistd.h: CEA_LGPL
share/libc/utime.h: CEA_LGPL
share/libc/utmp.h: CEA_LGPL
share/libc/utmpx.h: CEA_LGPL
+share/libc/wait.h: CEA_LGPL
share/libc/wchar.c: CEA_LGPL
share/libc/wchar.h: CEA_LGPL
share/libc/wctype.h: CEA_LGPL
+share/libc/wordexp.h: CEA_LGPL
share/machdep.c: CIL
share/switch-off.png: .ignore
share/switch-on.png: .ignore
@@ -1009,6 +1026,8 @@ src/plugins/metrics/metrics_gui.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/metrics/metrics_gui.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/metrics/metrics_parameters.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/metrics/metrics_parameters.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/metrics/metrics_pivot.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/metrics/metrics_pivot.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/metrics/register.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/metrics/register.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/metrics/register_gui.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1113,7 +1132,6 @@ src/plugins/print_api/lexer.mli: CEA_LGPL
src/plugins/print_api/print_interface.ml: CEA_LGPL
src/plugins/print_api/print_interface.mli: CEA_LGPL
src/plugins/qed/.gitignore: .ignore
-src/plugins/qed/.ocp-indent: .ignore
src/plugins/qed/Makefile: CEA_WP
src/plugins/qed/bvars.ml: CEA_WP
src/plugins/qed/bvars.mli: CEA_WP
@@ -1316,9 +1334,20 @@ src/plugins/users/users_register.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/users/users_register.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/.merlin: .ignore
src/plugins/value/Changelog_non_free: .ignore
-src/plugins/value/Eva.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/Eva.mli: .ignore
src/plugins/value/alarmset.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/alarmset.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/eval.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/eval.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/gen-api.sh: .ignore
+src/plugins/value/parameters.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/parameters.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/register.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/register.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/self.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/self.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/test.assert.sh: .ignore
+src/plugins/value/test.sh: .ignore
src/plugins/value/api/general_requests.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/api/general_requests.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/api/values_request.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1427,8 +1456,6 @@ src/plugins/value/engine/transfer_specification.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/engine/transfer_specification.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/engine/transfer_stmt.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/engine/transfer_stmt.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/eval.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/eval.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/gui_files/gui_callstacks_filters.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/gui_files/gui_callstacks_filters.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/gui_files/gui_callstacks_manager.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1449,8 +1476,6 @@ src/plugins/value/legacy/eval_terms.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/legacy/eval_terms.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/legacy/function_args.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/legacy/function_args.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/register.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/register.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/partitioning/auto_loop_unroll.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/partitioning/auto_loop_unroll.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/partitioning/partition.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1467,12 +1492,22 @@ src/plugins/value/partitioning/split_strategy.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/partitioning/split_strategy.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/partitioning/trace_partitioning.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/partitioning/trace_partitioning.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/test.assert.sh: .ignore
-src/plugins/value/test.sh: .ignore
src/plugins/value/utils/abstract.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/abstract.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/backward_formals.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/backward_formals.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_annotations.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_annotations.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_audit.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_audit.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_dynamic.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_dynamic.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_perf.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_perf.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_results.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_results.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_utils.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/eva_utils.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/eval_typ.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/eval_typ.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/red_statuses.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1481,30 +1516,18 @@ src/plugins/value/utils/library_functions.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/library_functions.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/mark_noresults.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/mark_noresults.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/eva_annotations.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/eva_annotations.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/eva_audit.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/eva_audit.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/eva_dynamic.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/eva_dynamic.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/results.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/utils/results.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/structure.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/structure.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/summary.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/summary.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/unit_tests.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/unit_tests.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/value_perf.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/value_perf.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/value_results.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/value_results.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/value_util.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/utils/value_util.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/widen.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/widen.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/widen_hints_ext.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/utils/widen_hints_ext.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/value_parameters.ml: CEA_LGPL_OR_PROPRIETARY
-src/plugins/value/value_parameters.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/values/abstract_location.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/values/abstract_value.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/values/cvalue_backward.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1580,7 +1603,6 @@ src/plugins/variadic/translate.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/variadic/translate.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/variadic/va_types.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/wp/.gitignore: .ignore
-src/plugins/wp/.ocp-indent: .ignore
src/plugins/wp/AssignsCompleteness.ml: CEA_WP
src/plugins/wp/AssignsCompleteness.mli: CEA_WP
src/plugins/wp/Auto.ml: CEA_WP
diff --git a/ivette/Makefile b/ivette/Makefile
index c2b5abe73d4cd5d71758a12dac33a7f3a68d1310..26c16c144605f2a0918df6d2506d513551b2d188 100644
--- a/ivette/Makefile
+++ b/ivette/Makefile
@@ -72,6 +72,8 @@ $(LOADER): $(PACKAGES) ./configure.js ./Makefile
# --- Frama-C Source Distrib
# --------------------------------------------------------------------------
+.PHONY: update-distrib-files update-distrib-plugins
+
SRC_DISTRIB=Makefile.distrib
SRC_HEADERS=headers/header_spec.txt
@@ -81,8 +83,23 @@ update-distrib-files:
@rm -f $(SRC_HEADERS)
@for f in `git ls-files .` ;\
do \
- echo "DISTRIB_FILES += ivette/$$f" >> $(SRC_DISTRIB) ;\
- headers/register.sh "$$f" >> $(SRC_HEADERS) ; \
+ echo "DISTRIB_FILES += ivette/$$f" >> $(SRC_DISTRIB) ;\
+ headers/register.sh "$$f" >> $(SRC_HEADERS) ; \
+ done
+ @chmod a-w $(SRC_DISTRIB)
+ @chmod a-w $(SRC_HEADERS)
+
+update-distrib-plugins: update-distrib-files
+ @chmod a+w $(SRC_DISTRIB)
+ @chmod a+w $(SRC_HEADERS)
+ @for repo in `find . -type d -name ".git"` ;\
+ do \
+ echo "Distributing $$repo" ;\
+ for f in `git -C $$repo ls-files .` ;\
+ do \
+ echo "DISTRIB_FILES += ivette/$$f" >> $(SRC_DISTRIB) ;\
+ headers/register.sh "$$f" >> $(SRC_HEADERS) ; \
+ done \
done
@chmod a-w $(SRC_DISTRIB)
@chmod a-w $(SRC_HEADERS)
@@ -95,9 +112,11 @@ update-distrib-files:
api:
@echo "[Ivette] Generating TypeScript API"
- @rm -fr src/frama-c/api/generated
- ../bin/frama-c.byte -load-module src/frama-c/api/generator.ml -server-tsc
- @find src/frama-c/api/generated -name "*.ts" \
+ @find src/frama-c -path "*/api/*" -name "*.ts" -exec rm -f {} \;
+ ../bin/frama-c.byte \
+ -load-module src/frama-c/api_generator.ml \
+ -server-tsc
+ @find src/frama-c -path "*/api/*" -name "*.ts" \
-exec headache \
-h ../headers/open-source/CEA_LGPL \
-c ../headers/headache_config.txt {} \;\
diff --git a/ivette/Makefile.distrib b/ivette/Makefile.distrib
index b6773e8d65d31dead54e2e1d96a427e3edee939d..d4eeff9d4e3f8d69a886b74a1997bcfe70d8feb5 100644
--- a/ivette/Makefile.distrib
+++ b/ivette/Makefile.distrib
@@ -139,16 +139,7 @@ DISTRIB_FILES += ivette/src/dome/template/typescript.el
DISTRIB_FILES += ivette/src/dome/template/update.sh
DISTRIB_FILES += ivette/src/dome/template/webpack.main.js
DISTRIB_FILES += ivette/src/dome/template/webpack.renderer.js
-DISTRIB_FILES += ivette/src/frama-c/api/generated/kernel/ast/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generated/kernel/data/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generated/kernel/project/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generated/kernel/properties/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generated/kernel/services/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generated/plugins/dive/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generated/plugins/eva/general/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generated/plugins/eva/values/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generated/plugins/studia/studia/index.ts
-DISTRIB_FILES += ivette/src/frama-c/api/generator.ml
+DISTRIB_FILES += ivette/src/frama-c/api_generator.ml
DISTRIB_FILES += ivette/src/frama-c/client.ts
DISTRIB_FILES += ivette/src/frama-c/client_socket.ts
DISTRIB_FILES += ivette/src/frama-c/client_zmq.ts
@@ -159,12 +150,19 @@ DISTRIB_FILES += ivette/src/frama-c/kernel/Globals.tsx
DISTRIB_FILES += ivette/src/frama-c/kernel/History.tsx
DISTRIB_FILES += ivette/src/frama-c/kernel/Locations.tsx
DISTRIB_FILES += ivette/src/frama-c/kernel/Messages.tsx
+DISTRIB_FILES += ivette/src/frama-c/kernel/PivotTable.tsx
DISTRIB_FILES += ivette/src/frama-c/kernel/Properties.tsx
DISTRIB_FILES += ivette/src/frama-c/kernel/SourceCode.tsx
DISTRIB_FILES += ivette/src/frama-c/kernel/Status.tsx
+DISTRIB_FILES += ivette/src/frama-c/kernel/api/ast/index.ts
+DISTRIB_FILES += ivette/src/frama-c/kernel/api/data/index.ts
+DISTRIB_FILES += ivette/src/frama-c/kernel/api/project/index.ts
+DISTRIB_FILES += ivette/src/frama-c/kernel/api/properties/index.ts
+DISTRIB_FILES += ivette/src/frama-c/kernel/api/services/index.ts
DISTRIB_FILES += ivette/src/frama-c/kernel/style.css
DISTRIB_FILES += ivette/src/frama-c/menu.ts
DISTRIB_FILES += ivette/src/frama-c/pkg.json
+DISTRIB_FILES += ivette/src/frama-c/plugins/dive/api/index.ts
DISTRIB_FILES += ivette/src/frama-c/plugins/dive/cytoscape_libs.js
DISTRIB_FILES += ivette/src/frama-c/plugins/dive/index.tsx
DISTRIB_FILES += ivette/src/frama-c/plugins/dive/layouts.json
@@ -175,6 +173,8 @@ DISTRIB_FILES += ivette/src/frama-c/plugins/dive/tippy.css
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/Coverage.tsx
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/CoverageMeter.tsx
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/Summary.tsx
+DISTRIB_FILES += ivette/src/frama-c/plugins/eva/api/general/index.ts
+DISTRIB_FILES += ivette/src/frama-c/plugins/eva/api/values/index.ts
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/cells.ts
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/diffed.tsx
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/index.tsx
@@ -189,6 +189,9 @@ DISTRIB_FILES += ivette/src/frama-c/plugins/eva/style.css
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/summary.css
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/valueinfos.tsx
DISTRIB_FILES += ivette/src/frama-c/plugins/eva/valuetable.tsx
+DISTRIB_FILES += ivette/src/frama-c/plugins/pivot/api/general/index.ts
+DISTRIB_FILES += ivette/src/frama-c/plugins/studia/api/studia/index.ts
+DISTRIB_FILES += ivette/src/frama-c/react-pivottable.d.ts
DISTRIB_FILES += ivette/src/frama-c/server.ts
DISTRIB_FILES += ivette/src/frama-c/states.ts
DISTRIB_FILES += ivette/src/frama-c/utils.ts
diff --git a/ivette/headers/header_spec.txt b/ivette/headers/header_spec.txt
index c89734b28035fc538a00d3b922ea4237fefe1aea..0ae1cb1ccfd134dbf5a645bfcf912bd25a7d6f36 100644
--- a/ivette/headers/header_spec.txt
+++ b/ivette/headers/header_spec.txt
@@ -139,16 +139,7 @@ src/dome/template/typescript.el: .ignore
src/dome/template/update.sh: .ignore
src/dome/template/webpack.main.js: CEA_LGPL
src/dome/template/webpack.renderer.js: CEA_LGPL
-src/frama-c/api/generated/kernel/ast/index.ts: CEA_LGPL
-src/frama-c/api/generated/kernel/data/index.ts: CEA_LGPL
-src/frama-c/api/generated/kernel/project/index.ts: CEA_LGPL
-src/frama-c/api/generated/kernel/properties/index.ts: CEA_LGPL
-src/frama-c/api/generated/kernel/services/index.ts: CEA_LGPL
-src/frama-c/api/generated/plugins/dive/index.ts: CEA_LGPL
-src/frama-c/api/generated/plugins/eva/general/index.ts: CEA_LGPL
-src/frama-c/api/generated/plugins/eva/values/index.ts: CEA_LGPL
-src/frama-c/api/generated/plugins/studia/studia/index.ts: CEA_LGPL
-src/frama-c/api/generator.ml: .ignore
+src/frama-c/api_generator.ml: .ignore
src/frama-c/client.ts: CEA_LGPL
src/frama-c/client_socket.ts: CEA_LGPL
src/frama-c/client_zmq.ts: CEA_LGPL
@@ -159,12 +150,19 @@ src/frama-c/kernel/Globals.tsx: CEA_LGPL
src/frama-c/kernel/History.tsx: CEA_LGPL
src/frama-c/kernel/Locations.tsx: CEA_LGPL
src/frama-c/kernel/Messages.tsx: CEA_LGPL
+src/frama-c/kernel/PivotTable.tsx: CEA_LGPL
src/frama-c/kernel/Properties.tsx: CEA_LGPL
src/frama-c/kernel/SourceCode.tsx: CEA_LGPL
src/frama-c/kernel/Status.tsx: CEA_LGPL
+src/frama-c/kernel/api/ast/index.ts: CEA_LGPL
+src/frama-c/kernel/api/data/index.ts: CEA_LGPL
+src/frama-c/kernel/api/project/index.ts: CEA_LGPL
+src/frama-c/kernel/api/properties/index.ts: CEA_LGPL
+src/frama-c/kernel/api/services/index.ts: CEA_LGPL
src/frama-c/kernel/style.css: .ignore
src/frama-c/menu.ts: CEA_LGPL
src/frama-c/pkg.json: .ignore
+src/frama-c/plugins/dive/api/index.ts: CEA_LGPL
src/frama-c/plugins/dive/cytoscape_libs.js: CEA_LGPL
src/frama-c/plugins/dive/index.tsx: CEA_LGPL
src/frama-c/plugins/dive/layouts.json: .ignore
@@ -175,6 +173,8 @@ src/frama-c/plugins/dive/tippy.css: .ignore
src/frama-c/plugins/eva/Coverage.tsx: CEA_LGPL
src/frama-c/plugins/eva/CoverageMeter.tsx: CEA_LGPL
src/frama-c/plugins/eva/Summary.tsx: CEA_LGPL
+src/frama-c/plugins/eva/api/general/index.ts: CEA_LGPL
+src/frama-c/plugins/eva/api/values/index.ts: CEA_LGPL
src/frama-c/plugins/eva/cells.ts: CEA_LGPL
src/frama-c/plugins/eva/diffed.tsx: CEA_LGPL
src/frama-c/plugins/eva/index.tsx: CEA_LGPL
@@ -189,6 +189,9 @@ src/frama-c/plugins/eva/style.css: .ignore
src/frama-c/plugins/eva/summary.css: .ignore
src/frama-c/plugins/eva/valueinfos.tsx: CEA_LGPL
src/frama-c/plugins/eva/valuetable.tsx: CEA_LGPL
+src/frama-c/plugins/pivot/api/general/index.ts: CEA_LGPL
+src/frama-c/plugins/studia/api/studia/index.ts: CEA_LGPL
+src/frama-c/react-pivottable.d.ts: CEA_LGPL
src/frama-c/server.ts: CEA_LGPL
src/frama-c/states.ts: CEA_LGPL
src/frama-c/utils.ts: CEA_LGPL
diff --git a/ivette/package.json b/ivette/package.json
index 52655b7d59c4bec9f1c4207977f1c0733d76dad1..33b452fc4f9efd8d3f9bd8f481787e3c1b8b66af 100644
--- a/ivette/package.json
+++ b/ivette/package.json
@@ -75,6 +75,7 @@
"react-dom": "^16",
"react-draggable": "^4.4.4",
"react-fast-compare": "^3.2.0",
+ "react-pivottable": "^0.11.0",
"react-virtualized": "^9.22.3",
"react-window": "",
"source-map-support": "^0.5.21",
diff --git a/ivette/src/frama-c/api/generator.ml b/ivette/src/frama-c/api_generator.ml
similarity index 94%
rename from ivette/src/frama-c/api/generator.ml
rename to ivette/src/frama-c/api_generator.ml
index 849e21155077a6710eaa289f44027feaa951bc95..10b7aec4914ff0d36d26c905d697cdb5d0d28e2c 100644
--- a/ivette/src/frama-c/api/generator.ml
+++ b/ivette/src/frama-c/api_generator.ml
@@ -15,19 +15,11 @@ module TSC = Self.Action
let help = "Generate TypeScript API"
end)
-module API = Self.String
- (struct
- let option_name = "-server-tsc-pkg"
- let arg_name = "dir"
- let default = "frama-c/api"
- let help = Printf.sprintf "Output package (default is '%s')" default
- end)
-
module OUT = Self.String
(struct
let option_name = "-server-tsc-out"
- let arg_name = "dir"
- let default = "src/frama-c/api/generated"
+ let arg_name = "path"
+ let default = "src"
let help = Printf.sprintf "Output directory (default is '%s')" default
end)
@@ -491,20 +483,28 @@ let ranking ds =
(* --- Package Generator --- *)
(* -------------------------------------------------------------------------- *)
+let pkg_path ~plugin ~package =
+ String.concat "/" @@
+ let pkg = "api" :: package in
+ "frama-c" ::
+ match plugin with
+ | Pkg.Kernel -> "kernel" :: pkg
+ | Pkg.Plugin p -> "plugins" :: p :: pkg
+
let makeIgnore fmt msg =
Format.fprintf fmt "//@ts-ignore@\n" ;
Format.fprintf fmt msg
-let makePackage pkg name fmt =
+(* path shall be [pkg_path] of [pkg] *)
+let makePackage pkg path fmt =
begin
let open Pkg in
- let framac = API.get () in
Format.fprintf fmt "/* --- Generated Frama-C Server API --- */@\n@\n" ;
Format.fprintf fmt "/**@\n %s@\n" pkg.p_title ;
if pkg.p_descr <> [] then
Format.fprintf fmt "@\n @[<hov 0>%a@]@\n@\n" pp_descr pkg.p_descr ;
Format.fprintf fmt " @@packageDocumentation@\n" ;
- Format.fprintf fmt " @@module %s/%s@\n" framac name ;
+ Format.fprintf fmt " @@module %s@\n" path ;
Format.fprintf fmt "*/@\n@." ;
let names = Pkg.resolve ~keywords pkg in
makeIgnore fmt "import * as Json from 'dome/data/json';@\n" ;
@@ -513,17 +513,16 @@ let makePackage pkg name fmt =
makeIgnore fmt "import * as State from 'frama-c/states';@\n" ;
Format.pp_print_newline fmt () ;
Pkg.IdMap.iter
- (fun id name ->
- if id.plugin <> pkg.p_plugin ||
- id.package <> pkg.p_package
+ (fun { name = iname ; plugin ; package } name ->
+ if plugin <> pkg.p_plugin || package <> pkg.p_package
then
- let pkg = Pkg.name_of_pkg ~sep:"/" id.plugin id.package in
- if id.name = name then
- makeIgnore fmt "import { %s } from '%s/%s';@\n"
- name framac pkg
+ let path = pkg_path ~plugin ~package in
+ if iname = name then
+ makeIgnore fmt "import { %s } from '%s';@\n"
+ name path
else
- makeIgnore fmt "import { %s: %s } from '%s/%s';@\n"
- id.name name framac pkg
+ makeIgnore fmt "import { %s: %s } from '%s';@\n"
+ iname name path
) names ;
List.iter
(makeDeclaration fmt names)
@@ -540,13 +539,14 @@ let generate () =
begin
Pkg.iter
begin fun pkg ->
- Self.feedback "Package %a" Pkg.pp_pkgname pkg ;
- let name = Pkg.name_of_pkginfo ~sep:"/" pkg in
- let file = Printf.sprintf "%s/%s/index.ts" (OUT.get ()) name in
+ let path = pkg_path ~plugin:pkg.p_plugin ~package:pkg.p_package in
+ Self.feedback "Package %s" path ;
+ let out = OUT.get () in
+ let file = Printf.sprintf "%s/%s/index.ts" out path in
let dir = Filename.dirname file in
if not (Sys.file_exists dir && Sys.is_directory dir) then
Extlib.mkdir ~parents:true dir 0o755 ;
- Command.print_file file (makePackage pkg name) ;
+ Command.print_file file (makePackage pkg path) ;
end
end
diff --git a/ivette/src/frama-c/index.tsx b/ivette/src/frama-c/index.tsx
index ecdd4f2fd82278d3e7e1e09a2aa92189dc0518c9..cbd203691f69193bd4f1eb1e0dc2002be378c02c 100644
--- a/ivette/src/frama-c/index.tsx
+++ b/ivette/src/frama-c/index.tsx
@@ -33,6 +33,7 @@ import Status from 'frama-c/kernel/Status';
import ASTview from 'frama-c/kernel/ASTview';
import ASTinfo from 'frama-c/kernel/ASTinfo';
import SourceCode from 'frama-c/kernel/SourceCode';
+import PivotTable from 'frama-c/kernel/PivotTable';
import Locations from 'frama-c/kernel/Locations';
import Properties from 'frama-c/kernel/Properties';
import Messages from 'frama-c/kernel/Messages';
@@ -90,6 +91,12 @@ Ivette.registerGroup({
title: 'Messages emitted by Frama-C',
children: <Messages />,
});
+ Ivette.registerComponent({
+ id: 'frama-c.pivottable',
+ label: 'Pivot Table',
+ title: 'Pivot Table',
+ children: <PivotTable />,
+ });
});
/* --------------------------------------------------------------------------*/
@@ -115,4 +122,13 @@ Ivette.registerView({
],
});
+Ivette.registerView({
+ id: 'pivot-table',
+ rank: 2,
+ label: 'Pivot Table',
+ layout: [
+ ['frama-c.pivottable'],
+ ],
+});
+
/* --------------------------------------------------------------------------*/
diff --git a/ivette/src/frama-c/kernel/ASTinfo.tsx b/ivette/src/frama-c/kernel/ASTinfo.tsx
index ab3f97412b49ec2d17d6a60337a608c21a208d27..755473ea00fb706af7b879734fc9f60571d9c815 100644
--- a/ivette/src/frama-c/kernel/ASTinfo.tsx
+++ b/ivette/src/frama-c/kernel/ASTinfo.tsx
@@ -31,7 +31,7 @@ import * as Utils from 'frama-c/utils';
import { Vfill } from 'dome/layout/boxes';
import { RichTextBuffer } from 'dome/text/buffers';
import { Text } from 'dome/text/editors';
-import { getInfo } from 'frama-c/api/kernel/ast';
+import { getInfo } from 'frama-c/kernel/api/ast';
// --------------------------------------------------------------------------
// --- Information Panel
diff --git a/ivette/src/frama-c/kernel/ASTview.tsx b/ivette/src/frama-c/kernel/ASTview.tsx
index c79c3a487efdc0a4492e3f3468a2196c5cb7f25a..e5f28dc8c675ef80f3a177bf1219229be6f03ad9 100644
--- a/ivette/src/frama-c/kernel/ASTview.tsx
+++ b/ivette/src/frama-c/kernel/ASTview.tsx
@@ -38,10 +38,10 @@ import { Text } from 'dome/text/editors';
import { TitleBar } from 'ivette';
import * as Preferences from 'ivette/prefs';
-import * as Ast from 'frama-c/api/kernel/ast';
-import * as Properties from 'frama-c/api/kernel/properties';
-import { getCallers, getDeadCode } from 'frama-c/api/plugins/eva/general';
-import { getWritesLval, getReadsLval } from 'frama-c/api/plugins/studia/studia';
+import * as Ast from 'frama-c/kernel/api/ast';
+import * as Properties from 'frama-c/kernel/api/properties';
+import { getCallers, getDeadCode } from 'frama-c/plugins/eva/api/general';
+import { getWritesLval, getReadsLval } from 'frama-c/plugins/studia/api/studia';
// --------------------------------------------------------------------------
// --- Pretty Printing (Browser Console)
diff --git a/ivette/src/frama-c/kernel/Globals.tsx b/ivette/src/frama-c/kernel/Globals.tsx
index b0866f019fca18c4784ecba8e19c4d4b80036fdf..afa8fed84a47ad404868ef6c578aed79f9ccb599 100644
--- a/ivette/src/frama-c/kernel/Globals.tsx
+++ b/ivette/src/frama-c/kernel/Globals.tsx
@@ -32,8 +32,8 @@ import { Section, Item } from 'dome/frame/sidebars';
import * as Ivette from 'ivette';
import * as States from 'frama-c/states';
-import { functions, functionsData } from 'frama-c/api/kernel/ast';
-import { computationState } from 'frama-c/api/plugins/eva/general';
+import { functions, functionsData } from 'frama-c/kernel/api/ast';
+import { computationState } from 'frama-c/plugins/eva/api/general';
// --------------------------------------------------------------------------
// --- Global Search Hints
diff --git a/ivette/src/frama-c/kernel/Locations.tsx b/ivette/src/frama-c/kernel/Locations.tsx
index a318d834a6d6a6d3f03851e61e865fd11c67cf27..6d5882f2f2d22a4cf6fceb399fd1b1a24dbd01d7 100644
--- a/ivette/src/frama-c/kernel/Locations.tsx
+++ b/ivette/src/frama-c/kernel/Locations.tsx
@@ -34,7 +34,7 @@ import { Label } from 'dome/controls/labels';
import { IconButton } from 'dome/controls/buttons';
import { Space } from 'dome/frame/toolbars';
import { TitleBar } from 'ivette';
-import { markerInfo } from 'frama-c/api/kernel/ast';
+import { markerInfo } from 'frama-c/kernel/api/ast';
// --------------------------------------------------------------------------
// --- Locations Panel
diff --git a/ivette/src/frama-c/kernel/Messages.tsx b/ivette/src/frama-c/kernel/Messages.tsx
index 3cd7892f5855defb805a7dd7e5d8445a885045e0..6b66f7cfd3d4fec79c04d66d1124563979363eb9 100644
--- a/ivette/src/frama-c/kernel/Messages.tsx
+++ b/ivette/src/frama-c/kernel/Messages.tsx
@@ -39,8 +39,8 @@ import * as Compare from 'dome/data/compare';
import { State, GlobalState, useGlobalState } from 'dome/data/states';
import * as States from 'frama-c/states';
-import * as Ast from 'frama-c/api/kernel/ast';
-import * as Kernel from 'frama-c/api/kernel/services';
+import * as Ast from 'frama-c/kernel/api/ast';
+import * as Kernel from 'frama-c/kernel/api/services';
type Message = Kernel.messageData;
type logkind = Kernel.logkind;
diff --git a/ivette/src/frama-c/kernel/PivotTable.tsx b/ivette/src/frama-c/kernel/PivotTable.tsx
new file mode 100644
index 0000000000000000000000000000000000000000..a30799c3664ec84f36ef8fb227ede036baaa28aa
--- /dev/null
+++ b/ivette/src/frama-c/kernel/PivotTable.tsx
@@ -0,0 +1,129 @@
+/* ************************************************************************ */
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/* ************************************************************************ */
+
+// --------------------------------------------------------------------------
+// --- Pivot Table
+// --------------------------------------------------------------------------
+
+import React from 'react';
+import { TitleBar } from 'ivette';
+import * as Server from 'frama-c/server';
+import { Button } from 'dome/controls/buttons';
+import { LED } from 'dome/controls/displays';
+import { Scroll } from 'dome/layout/boxes';
+import * as Status from 'frama-c/kernel/Status';
+import * as States from 'frama-c/states';
+import * as PivotState from 'frama-c/plugins/pivot/api/general';
+import PivotTableUI from 'react-pivottable/PivotTableUI';
+import 'react-pivottable/pivottable.css';
+
+// --------------------------------------------------------------------------
+// --- Pivot Table for Properties
+// --------------------------------------------------------------------------
+
+interface PivotTableProps {
+ data: string[][];
+}
+
+export function Pivot(props: PivotTableProps): JSX.Element {
+ const [state, setState] = React.useState({});
+ return (
+ <PivotTableUI
+ data={props.data}
+ onChange={setState}
+ {...state}
+ />
+ );
+}
+
+function PivotTable(rawData: PivotState.tableStateType): JSX.Element {
+ const data = new Array(rawData.length > 0 ? rawData.length - 1 : 0);
+ if (rawData.length > 0) {
+ const headers = rawData[0];
+ for (let i = 1; i < rawData.length; i++) {
+ const src = rawData[i];
+ data[i - 1] = {};
+ for (let j = 0; j < headers.length; j++) {
+ data[i - 1][headers[j]] = src[j];
+ }
+ }
+ }
+ return (<Pivot data={data} />);
+}
+
+function PivotTableBuild(): JSX.Element {
+ const rawData = States.useSyncValue(PivotState.pivotState);
+ const [computing, setComputing] = React.useState(false);
+ const [error, setError] = React.useState('');
+ async function handleError(err: string): Promise<void> {
+ const msg =
+ `The pivot table could not be built: an error has occured (${err}).`;
+ setError(msg);
+ Status.setMessage({ text: msg, kind: 'error' });
+ }
+ async function compute(): Promise<void> {
+ setComputing(true);
+ setError('');
+ Server.send(PivotState.compute, [])
+ .then(() => setComputing(false))
+ .catch((err) => { setComputing(false); handleError(err); });
+ }
+ if (rawData && rawData.length > 0) {
+ return (PivotTable(rawData));
+ }
+ if (computing) {
+ return (
+ <div className="pivot-centered">
+ <div>
+ <LED status="active" blink /> Computing…
+ </div>
+ </div>
+ );
+ }
+ const err = error ? <div className="part"> {error} </div> : undefined;
+ return (
+ <div className="pivot-centered">
+ {err}
+ <div className="part">
+ <Button
+ icon="EXECUTE"
+ label="Compute"
+ title="Builds the pivot table. This may take a few moments."
+ onClick={compute}
+ />
+ </div>
+ </div>
+ );
+}
+
+export default function PivotTableComponent(): JSX.Element {
+ return (
+ <>
+ <TitleBar />
+ <Scroll>
+ <PivotTableBuild />
+ </Scroll>
+ </>
+ );
+}
+
+// --------------------------------------------------------------------------
diff --git a/ivette/src/frama-c/kernel/Properties.tsx b/ivette/src/frama-c/kernel/Properties.tsx
index ce617cf16d6b3c55fdd4bdc6f692582eae178609..2e64d85e5369722304fcc8115fe53b2e72491c59 100644
--- a/ivette/src/frama-c/kernel/Properties.tsx
+++ b/ivette/src/frama-c/kernel/Properties.tsx
@@ -44,10 +44,10 @@ import { Scroll, Folder } from 'dome/layout/boxes';
import { RSplit } from 'dome/layout/splitters';
-import * as Ast from 'frama-c/api/kernel/ast';
-import { statusData } from 'frama-c/api/kernel/properties';
-import * as Properties from 'frama-c/api/kernel/properties';
-import * as Eva from 'frama-c/api/plugins/eva/general';
+import * as Ast from 'frama-c/kernel/api/ast';
+import { statusData } from 'frama-c/kernel/api/properties';
+import * as Properties from 'frama-c/kernel/api/properties';
+import * as Eva from 'frama-c/plugins/eva/api/general';
type Property = statusData & Eva.propertiesData;
diff --git a/ivette/src/frama-c/kernel/SourceCode.tsx b/ivette/src/frama-c/kernel/SourceCode.tsx
index 578415aeda9f454b0a45c861ff071cbdb22f8597..2d13f011ec78562cc9b283487276b2130b8417b8 100644
--- a/ivette/src/frama-c/kernel/SourceCode.tsx
+++ b/ivette/src/frama-c/kernel/SourceCode.tsx
@@ -34,7 +34,7 @@ import { RichTextBuffer } from 'dome/text/buffers';
import { Text } from 'dome/text/editors';
import { TitleBar } from 'ivette';
import * as Preferences from 'ivette/prefs';
-import { functions, markerInfo, getMarkerAt } from 'frama-c/api/kernel/ast';
+import { functions, markerInfo, getMarkerAt } from 'frama-c/kernel/api/ast';
import { Code } from 'dome/controls/labels';
import { Hfill } from 'dome/layout/boxes';
import { IconButton } from 'dome/controls/buttons';
diff --git a/ivette/src/frama-c/api/generated/kernel/ast/index.ts b/ivette/src/frama-c/kernel/api/ast/index.ts
similarity index 97%
rename from ivette/src/frama-c/api/generated/kernel/ast/index.ts
rename to ivette/src/frama-c/kernel/api/ast/index.ts
index e971013dd1252a03eafbf8993324378cba442f2b..702731a2a78641e60a6575dea33a23bdcf9819ae 100644
--- a/ivette/src/frama-c/api/generated/kernel/ast/index.ts
+++ b/ivette/src/frama-c/kernel/api/ast/index.ts
@@ -25,7 +25,7 @@
/**
Ast Services
@packageDocumentation
- @module frama-c/api/kernel/ast
+ @module frama-c/kernel/api/ast
*/
//@ts-ignore
@@ -38,21 +38,21 @@ import * as Server from 'frama-c/server';
import * as State from 'frama-c/states';
//@ts-ignore
-import { byTag } from 'frama-c/api/kernel/data';
+import { byTag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { byText } from 'frama-c/api/kernel/data';
+import { byText } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTag } from 'frama-c/api/kernel/data';
+import { jTag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTagSafe } from 'frama-c/api/kernel/data';
+import { jTagSafe } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jText } from 'frama-c/api/kernel/data';
+import { jText } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTextSafe } from 'frama-c/api/kernel/data';
+import { jTextSafe } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { tag } from 'frama-c/api/kernel/data';
+import { tag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { text } from 'frama-c/api/kernel/data';
+import { text } from 'frama-c/kernel/api/data';
const compute_internal: Server.ExecRequest<null,null> = {
kind: Server.RqKind.EXEC,
diff --git a/ivette/src/frama-c/api/generated/kernel/data/index.ts b/ivette/src/frama-c/kernel/api/data/index.ts
similarity index 99%
rename from ivette/src/frama-c/api/generated/kernel/data/index.ts
rename to ivette/src/frama-c/kernel/api/data/index.ts
index f848d3112771fed03f03194fba5c01ab79051b79..7caeafed52fb2c1bc5686d827262a367804d9c7c 100644
--- a/ivette/src/frama-c/api/generated/kernel/data/index.ts
+++ b/ivette/src/frama-c/kernel/api/data/index.ts
@@ -25,7 +25,7 @@
/**
Informations
@packageDocumentation
- @module frama-c/api/kernel/data
+ @module frama-c/kernel/api/data
*/
//@ts-ignore
diff --git a/ivette/src/frama-c/api/generated/kernel/project/index.ts b/ivette/src/frama-c/kernel/api/project/index.ts
similarity index 99%
rename from ivette/src/frama-c/api/generated/kernel/project/index.ts
rename to ivette/src/frama-c/kernel/api/project/index.ts
index a08cfb75ffe9b7424601bd0bb46e0bae6be3bcae..ab83d2be401a0580cfa6e5c25e21d123c4d2321f 100644
--- a/ivette/src/frama-c/api/generated/kernel/project/index.ts
+++ b/ivette/src/frama-c/kernel/api/project/index.ts
@@ -25,7 +25,7 @@
/**
Project Management
@packageDocumentation
- @module frama-c/api/kernel/project
+ @module frama-c/kernel/api/project
*/
//@ts-ignore
diff --git a/ivette/src/frama-c/api/generated/kernel/properties/index.ts b/ivette/src/frama-c/kernel/api/properties/index.ts
similarity index 96%
rename from ivette/src/frama-c/api/generated/kernel/properties/index.ts
rename to ivette/src/frama-c/kernel/api/properties/index.ts
index 1379aced2c69b7e54f858187595db95f925a2968..6da4d4f7d99c41648e069d29b8cfab2702409240 100644
--- a/ivette/src/frama-c/api/generated/kernel/properties/index.ts
+++ b/ivette/src/frama-c/kernel/api/properties/index.ts
@@ -25,7 +25,7 @@
/**
Property Services
@packageDocumentation
- @module frama-c/api/kernel/properties
+ @module frama-c/kernel/api/properties
*/
//@ts-ignore
@@ -38,21 +38,21 @@ import * as Server from 'frama-c/server';
import * as State from 'frama-c/states';
//@ts-ignore
-import { bySource } from 'frama-c/api/kernel/ast';
+import { bySource } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jSource } from 'frama-c/api/kernel/ast';
+import { jSource } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jSourceSafe } from 'frama-c/api/kernel/ast';
+import { jSourceSafe } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { source } from 'frama-c/api/kernel/ast';
+import { source } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { byTag } from 'frama-c/api/kernel/data';
+import { byTag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTag } from 'frama-c/api/kernel/data';
+import { jTag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTagSafe } from 'frama-c/api/kernel/data';
+import { jTagSafe } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { tag } from 'frama-c/api/kernel/data';
+import { tag } from 'frama-c/kernel/api/data';
/** Property Kinds */
export enum propKind {
diff --git a/ivette/src/frama-c/api/generated/kernel/services/index.ts b/ivette/src/frama-c/kernel/api/services/index.ts
similarity index 93%
rename from ivette/src/frama-c/api/generated/kernel/services/index.ts
rename to ivette/src/frama-c/kernel/api/services/index.ts
index d271d8fd722e44a281c5214cc56d93f47746cfc9..61117a23a03350915e7655a7ef6ff98c78695781 100644
--- a/ivette/src/frama-c/api/generated/kernel/services/index.ts
+++ b/ivette/src/frama-c/kernel/api/services/index.ts
@@ -25,7 +25,7 @@
/**
Kernel Services
@packageDocumentation
- @module frama-c/api/kernel/services
+ @module frama-c/kernel/api/services
*/
//@ts-ignore
@@ -38,29 +38,29 @@ import * as Server from 'frama-c/server';
import * as State from 'frama-c/states';
//@ts-ignore
-import { byMarker } from 'frama-c/api/kernel/ast';
+import { byMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { bySource } from 'frama-c/api/kernel/ast';
+import { bySource } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarker } from 'frama-c/api/kernel/ast';
+import { jMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarkerSafe } from 'frama-c/api/kernel/ast';
+import { jMarkerSafe } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jSource } from 'frama-c/api/kernel/ast';
+import { jSource } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jSourceSafe } from 'frama-c/api/kernel/ast';
+import { jSourceSafe } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { marker } from 'frama-c/api/kernel/ast';
+import { marker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { source } from 'frama-c/api/kernel/ast';
+import { source } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { byTag } from 'frama-c/api/kernel/data';
+import { byTag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTag } from 'frama-c/api/kernel/data';
+import { jTag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTagSafe } from 'frama-c/api/kernel/data';
+import { jTagSafe } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { tag } from 'frama-c/api/kernel/data';
+import { tag } from 'frama-c/kernel/api/data';
const getConfig_internal: Server.GetRequest<
null,
diff --git a/ivette/src/frama-c/kernel/style.css b/ivette/src/frama-c/kernel/style.css
index 8b8b0435238982f4201588f9a930c83850d3f9a2..295008738903d77b302382ab92371a4d20bf5ecb 100644
--- a/ivette/src/frama-c/kernel/style.css
+++ b/ivette/src/frama-c/kernel/style.css
@@ -103,5 +103,30 @@
white-space: pre-line;
}
+/* -------------------------------------------------------------------------- */
+/* --- Pivot table --- */
+/* -------------------------------------------------------------------------- */
+
+.pivot-centered {
+ user-select: text;
+ display: flex;
+ flex-wrap: wrap;
+ flex-direction: column;
+ justify-content: center;
+ align-content: center;
+ height: 80%;
+}
+
+.pivot-centered .part {
+ user-select: text;
+ margin-top: 10px;
+ margin-bottom: 10px;
+ text-align: center;
+}
+
+.pivot-centered .dome-xButton-led {
+ display: inline-block;
+ vertical-align: baseline;
+}
/* -------------------------------------------------------------------------- */
diff --git a/ivette/src/frama-c/menu.ts b/ivette/src/frama-c/menu.ts
index 1fd0dedadfb6f48abe50ea09989da23fc80524bc..6e9e16654d23b2d0c34653fc96de6d038c105220 100644
--- a/ivette/src/frama-c/menu.ts
+++ b/ivette/src/frama-c/menu.ts
@@ -27,8 +27,8 @@
import * as Dome from 'dome';
import * as Dialogs from 'dome/dialogs';
import * as Server from 'frama-c/server';
-import * as Services from 'frama-c/api/kernel/services';
-import * as Ast from 'frama-c/api/kernel/ast';
+import * as Services from 'frama-c/kernel/api/services';
+import * as Ast from 'frama-c/kernel/api/ast';
import * as Status from 'frama-c/kernel/Status';
import * as States from 'frama-c/states';
@@ -44,7 +44,7 @@ const allFilter = {
async function parseFiles(files: string[]): Promise<void> {
Status.setMessage({ text: 'Parsing source files…', kind: 'progress' });
await Server.send(Ast.setFiles, files);
- await Server.send(Ast.compute, { });
+ await Server.send(Ast.compute, {});
Status.setMessage({ text: 'Source files parsed.', kind: 'success' });
return;
}
diff --git a/ivette/src/frama-c/api/generated/plugins/dive/index.ts b/ivette/src/frama-c/plugins/dive/api/index.ts
similarity index 96%
rename from ivette/src/frama-c/api/generated/plugins/dive/index.ts
rename to ivette/src/frama-c/plugins/dive/api/index.ts
index f1210ae95a63830f71366c2ccca8676f58a0b519..dbce1879e7e7b3597f40213ba21a6a9ee5592790 100644
--- a/ivette/src/frama-c/api/generated/plugins/dive/index.ts
+++ b/ivette/src/frama-c/plugins/dive/api/index.ts
@@ -25,7 +25,7 @@
/**
Dive Services
@packageDocumentation
- @module frama-c/api/plugins/dive
+ @module frama-c/plugins/dive/api
*/
//@ts-ignore
@@ -38,21 +38,21 @@ import * as Server from 'frama-c/server';
import * as State from 'frama-c/states';
//@ts-ignore
-import { byLocation } from 'frama-c/api/kernel/ast';
+import { byLocation } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { byMarker } from 'frama-c/api/kernel/ast';
+import { byMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jLocation } from 'frama-c/api/kernel/ast';
+import { jLocation } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jLocationSafe } from 'frama-c/api/kernel/ast';
+import { jLocationSafe } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarker } from 'frama-c/api/kernel/ast';
+import { jMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarkerSafe } from 'frama-c/api/kernel/ast';
+import { jMarkerSafe } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { location } from 'frama-c/api/kernel/ast';
+import { location } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { marker } from 'frama-c/api/kernel/ast';
+import { marker } from 'frama-c/kernel/api/ast';
/** Parametrization of the exploration range. */
export interface range {
diff --git a/ivette/src/frama-c/plugins/dive/index.tsx b/ivette/src/frama-c/plugins/dive/index.tsx
index 4ce8e0165e071e4c2c36c8cf04966e33de968983..d8828a539a07c49d6259cc6b765e8411b6006d7d 100644
--- a/ivette/src/frama-c/plugins/dive/index.tsx
+++ b/ivette/src/frama-c/plugins/dive/index.tsx
@@ -28,7 +28,7 @@ import * as Ivette from 'ivette';
import * as Server from 'frama-c/server';
import * as States from 'frama-c/states';
-import * as API from 'frama-c/api/plugins/dive';
+import * as API from 'frama-c/plugins/dive/api';
import Cytoscape from 'cytoscape';
import CytoscapeComponent from 'react-cytoscapejs';
@@ -396,8 +396,7 @@ class Dive {
async exec<In>(
request: Server.ExecRequest<In, API.diffData | null>,
- param: In): Promise<Cytoscape.NodeSingular | undefined>
- {
+ param: In): Promise<Cytoscape.NodeSingular | undefined> {
try {
if (Server.isRunning()) {
await this.setMode();
diff --git a/ivette/src/frama-c/plugins/eva/Coverage.tsx b/ivette/src/frama-c/plugins/eva/Coverage.tsx
index 4052f6e676ebfadc833d3009312660b8c506c732..9673bb3a59a11a1f5bdd9bd3b0222d3551a926a3 100644
--- a/ivette/src/frama-c/plugins/eva/Coverage.tsx
+++ b/ivette/src/frama-c/plugins/eva/Coverage.tsx
@@ -29,7 +29,7 @@ import * as Compare from 'dome/data/compare';
import * as Ivette from 'ivette';
import * as States from 'frama-c/states';
-import * as Eva from 'frama-c/api/plugins/eva/general';
+import * as Eva from 'frama-c/plugins/eva/api/general';
import CoverageMeter, { percent } from './CoverageMeter';
type key = Json.key<'#fundec'>;
diff --git a/ivette/src/frama-c/plugins/eva/Summary.tsx b/ivette/src/frama-c/plugins/eva/Summary.tsx
index 69e191ea73b54c70c24e2d94d7f9b10a697e4ee8..40589c58e65731696102bee0c67f9b3c057ff1eb 100644
--- a/ivette/src/frama-c/plugins/eva/Summary.tsx
+++ b/ivette/src/frama-c/plugins/eva/Summary.tsx
@@ -25,7 +25,7 @@ import React from 'react';
import { LED } from 'dome/controls/displays';
import * as Ivette from 'ivette';
import * as States from 'frama-c/states';
-import * as Eva from 'frama-c/api/plugins/eva/general';
+import * as Eva from 'frama-c/plugins/eva/api/general';
import CoverageMeter, { percent } from './CoverageMeter';
diff --git a/ivette/src/frama-c/api/generated/plugins/eva/general/index.ts b/ivette/src/frama-c/plugins/eva/api/general/index.ts
similarity index 97%
rename from ivette/src/frama-c/api/generated/plugins/eva/general/index.ts
rename to ivette/src/frama-c/plugins/eva/api/general/index.ts
index e0d31cec7827634693a791baebce957b4312ab3e..fbea0e7f945ce958511748060dac97096de8c178 100644
--- a/ivette/src/frama-c/api/generated/plugins/eva/general/index.ts
+++ b/ivette/src/frama-c/plugins/eva/api/general/index.ts
@@ -25,7 +25,7 @@
/**
Eva General Services
@packageDocumentation
- @module frama-c/api/plugins/eva/general
+ @module frama-c/plugins/eva/api/general
*/
//@ts-ignore
@@ -38,21 +38,21 @@ import * as Server from 'frama-c/server';
import * as State from 'frama-c/states';
//@ts-ignore
-import { byMarker } from 'frama-c/api/kernel/ast';
+import { byMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarker } from 'frama-c/api/kernel/ast';
+import { jMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarkerSafe } from 'frama-c/api/kernel/ast';
+import { jMarkerSafe } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { marker } from 'frama-c/api/kernel/ast';
+import { marker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { byTag } from 'frama-c/api/kernel/data';
+import { byTag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTag } from 'frama-c/api/kernel/data';
+import { jTag } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { jTagSafe } from 'frama-c/api/kernel/data';
+import { jTagSafe } from 'frama-c/kernel/api/data';
//@ts-ignore
-import { tag } from 'frama-c/api/kernel/data';
+import { tag } from 'frama-c/kernel/api/data';
/** State of the computation of Eva Analysis. */
export type computationStateType = "not_computed" | "computing" | "computed";
diff --git a/ivette/src/frama-c/api/generated/plugins/eva/values/index.ts b/ivette/src/frama-c/plugins/eva/api/values/index.ts
similarity index 96%
rename from ivette/src/frama-c/api/generated/plugins/eva/values/index.ts
rename to ivette/src/frama-c/plugins/eva/api/values/index.ts
index 38080fe75823cdb553b8134c5bf142796a809e97..7d6d3e4ec3d52b1ea1a1bfe167571d8152ed3e02 100644
--- a/ivette/src/frama-c/api/generated/plugins/eva/values/index.ts
+++ b/ivette/src/frama-c/plugins/eva/api/values/index.ts
@@ -25,7 +25,7 @@
/**
Eva Values
@packageDocumentation
- @module frama-c/api/plugins/eva/values
+ @module frama-c/plugins/eva/api/values
*/
//@ts-ignore
@@ -38,13 +38,13 @@ import * as Server from 'frama-c/server';
import * as State from 'frama-c/states';
//@ts-ignore
-import { byMarker } from 'frama-c/api/kernel/ast';
+import { byMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarker } from 'frama-c/api/kernel/ast';
+import { jMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarkerSafe } from 'frama-c/api/kernel/ast';
+import { jMarkerSafe } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { marker } from 'frama-c/api/kernel/ast';
+import { marker } from 'frama-c/kernel/api/ast';
/** Emitted when EVA results has changed */
export const changed: Server.Signal = {
diff --git a/ivette/src/frama-c/plugins/eva/cells.ts b/ivette/src/frama-c/plugins/eva/cells.ts
index ac8614b069d1ea262da4a156a8061c25a8e0d9b9..d37b4c2a184ef4b00a55c50647e911741b528d68 100644
--- a/ivette/src/frama-c/plugins/eva/cells.ts
+++ b/ivette/src/frama-c/plugins/eva/cells.ts
@@ -26,8 +26,8 @@
// Frama-C
import * as Server from 'frama-c/server';
-import * as Ast from 'frama-c/api/kernel/ast';
-import * as Values from 'frama-c/api/plugins/eva/values';
+import * as Ast from 'frama-c/kernel/api/ast';
+import * as Values from 'frama-c/plugins/eva/api/values';
// --------------------------------------------------------------------------
// --- Cell Utilities
diff --git a/ivette/src/frama-c/plugins/eva/layout.ts b/ivette/src/frama-c/plugins/eva/layout.ts
index c08227e211b4f9a41fcf2f666bd1029c10f0a276..e4de02d332f767c58d2fc0a617c602267c022d85 100644
--- a/ivette/src/frama-c/plugins/eva/layout.ts
+++ b/ivette/src/frama-c/plugins/eva/layout.ts
@@ -24,7 +24,7 @@
/* --- Layout ---*/
/* --------------------------------------------------------------------------*/
-import { callstack } from 'frama-c/api/plugins/eva/values';
+import { callstack } from 'frama-c/plugins/eva/api/values';
import { Probe } from './probes';
import { StacksCache } from './stacks';
import { Size, EMPTY, leq, addH, ValueCache } from './cells';
diff --git a/ivette/src/frama-c/plugins/eva/model.ts b/ivette/src/frama-c/plugins/eva/model.ts
index 4ea851059f542c89cc5c2777c14e6cbd24ad28e6..96839e91c3af66e19c7528b40f9df62c8c7df1d0 100644
--- a/ivette/src/frama-c/plugins/eva/model.ts
+++ b/ivette/src/frama-c/plugins/eva/model.ts
@@ -33,7 +33,7 @@ import * as Dome from 'dome';
import * as Server from 'frama-c/server';
import * as States from 'frama-c/states';
-import * as Values from 'frama-c/api/plugins/eva/values';
+import * as Values from 'frama-c/plugins/eva/api/values';
// Model
import { Probe } from './probes';
diff --git a/ivette/src/frama-c/plugins/eva/probes.ts b/ivette/src/frama-c/plugins/eva/probes.ts
index 3ba97ec06d601822f17914dc3a3945eb97386ce1..deb048a757d56413bc90b34d3d1f9fd49f29a34f 100644
--- a/ivette/src/frama-c/plugins/eva/probes.ts
+++ b/ivette/src/frama-c/plugins/eva/probes.ts
@@ -26,8 +26,8 @@
// Frama-C
import * as Server from 'frama-c/server';
-import * as Values from 'frama-c/api/plugins/eva/values';
-import * as Ast from 'frama-c/api/kernel/ast';
+import * as Values from 'frama-c/plugins/eva/api/values';
+import * as Ast from 'frama-c/kernel/api/ast';
// Model
import { ModelCallbacks } from './cells';
diff --git a/ivette/src/frama-c/plugins/eva/stacks.ts b/ivette/src/frama-c/plugins/eva/stacks.ts
index 45a28c043bec211b62a2ab872f59ec1e152cf5ef..1780027c1fbbbd51e8ca0c33c3cfa191ce6f7fce 100644
--- a/ivette/src/frama-c/plugins/eva/stacks.ts
+++ b/ivette/src/frama-c/plugins/eva/stacks.ts
@@ -25,8 +25,8 @@
// --------------------------------------------------------------------------
import * as Server from 'frama-c/server';
-import * as Ast from 'frama-c/api/kernel/ast';
-import * as Values from 'frama-c/api/plugins/eva/values';
+import * as Ast from 'frama-c/kernel/api/ast';
+import * as Values from 'frama-c/plugins/eva/api/values';
import { ModelCallbacks } from './cells';
diff --git a/ivette/src/frama-c/plugins/eva/valueinfos.tsx b/ivette/src/frama-c/plugins/eva/valueinfos.tsx
index c5e68c86fb58a15b744fd10db42f975c9bee8026..aad98cea55cc10cd1b31afde10e6dd895dd6f78e 100644
--- a/ivette/src/frama-c/plugins/eva/valueinfos.tsx
+++ b/ivette/src/frama-c/plugins/eva/valueinfos.tsx
@@ -32,7 +32,7 @@ import { classes } from 'dome/misc/utils';
import { Hpack, Vpack } from 'dome/layout/boxes';
import { Code, Cell } from 'dome/controls/labels';
import * as States from 'frama-c/states';
-import * as Ast from 'frama-c/api/kernel/ast';
+import * as Ast from 'frama-c/kernel/api/ast';
import { ModelProp } from 'frama-c/plugins/eva/model';
// Locals
diff --git a/ivette/src/frama-c/plugins/pivot/api/general/index.ts b/ivette/src/frama-c/plugins/pivot/api/general/index.ts
new file mode 100644
index 0000000000000000000000000000000000000000..fce9c56e3945df2203aec43d17d9919d837f624b
--- /dev/null
+++ b/ivette/src/frama-c/plugins/pivot/api/general/index.ts
@@ -0,0 +1,89 @@
+/* ************************************************************************ */
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/* ************************************************************************ */
+
+/* --- Generated Frama-C Server API --- */
+
+/**
+ Pivot Table Services
+ @packageDocumentation
+ @module frama-c/plugins/pivot/api/general
+*/
+
+//@ts-ignore
+import * as Json from 'dome/data/json';
+//@ts-ignore
+import * as Compare from 'dome/data/compare';
+//@ts-ignore
+import * as Server from 'frama-c/server';
+//@ts-ignore
+import * as State from 'frama-c/states';
+
+
+/** State of the pivot table source data. */
+export type tableStateType = string[][];
+
+/** Safe decoder for `tableStateType` */
+export const jTableStateTypeSafe: Json.Safe<tableStateType> =
+ Json.jArray(Json.jArray(Json.jFail(Json.jString,'String expected')));
+
+/** Loose decoder for `tableStateType` */
+export const jTableStateType: Json.Loose<tableStateType> =
+ Json.jTry(jTableStateTypeSafe);
+
+/** Natural order for `tableStateType` */
+export const byTableStateType: Compare.Order<tableStateType> =
+ Compare.array(Compare.array(Compare.string));
+
+/** Signal for state [`pivotState`](#pivotstate) */
+export const signalPivotState: Server.Signal = {
+ name: 'plugins.pivot.general.signalPivotState',
+};
+
+const getPivotState_internal: Server.GetRequest<null,tableStateType> = {
+ kind: Server.RqKind.GET,
+ name: 'plugins.pivot.general.getPivotState',
+ input: Json.jNull,
+ output: jTableStateType,
+ signals: [],
+};
+/** Getter for state [`pivotState`](#pivotstate) */
+export const getPivotState: Server.GetRequest<null,tableStateType>= getPivotState_internal;
+
+const pivotState_internal: State.Value<tableStateType> = {
+ name: 'plugins.pivot.general.pivotState',
+ signal: signalPivotState,
+ getter: getPivotState,
+};
+/** State of the pivot table source data. */
+export const pivotState: State.Value<tableStateType> = pivotState_internal;
+
+const compute_internal: Server.ExecRequest<null,null> = {
+ kind: Server.RqKind.EXEC,
+ name: 'plugins.pivot.general.compute',
+ input: Json.jNull,
+ output: Json.jNull,
+ signals: [],
+};
+/** Computes the pivot table. */
+export const compute: Server.ExecRequest<null,null>= compute_internal;
+
+/* ------------------------------------- */
diff --git a/ivette/src/frama-c/api/generated/plugins/studia/studia/index.ts b/ivette/src/frama-c/plugins/studia/api/studia/index.ts
similarity index 94%
rename from ivette/src/frama-c/api/generated/plugins/studia/studia/index.ts
rename to ivette/src/frama-c/plugins/studia/api/studia/index.ts
index 20ec58320d5613d739ea0db2ca90f6f94df12628..e27deb9e321e729ae0a5fd15822ac6bc9a3b0de2 100644
--- a/ivette/src/frama-c/api/generated/plugins/studia/studia/index.ts
+++ b/ivette/src/frama-c/plugins/studia/api/studia/index.ts
@@ -25,7 +25,7 @@
/**
Studia
@packageDocumentation
- @module frama-c/api/plugins/studia/studia
+ @module frama-c/plugins/studia/api/studia
*/
//@ts-ignore
@@ -38,13 +38,13 @@ import * as Server from 'frama-c/server';
import * as State from 'frama-c/states';
//@ts-ignore
-import { byMarker } from 'frama-c/api/kernel/ast';
+import { byMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarker } from 'frama-c/api/kernel/ast';
+import { jMarker } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { jMarkerSafe } from 'frama-c/api/kernel/ast';
+import { jMarkerSafe } from 'frama-c/kernel/api/ast';
//@ts-ignore
-import { marker } from 'frama-c/api/kernel/ast';
+import { marker } from 'frama-c/kernel/api/ast';
/** Statements that read or write a location. */
export interface effects {
diff --git a/ivette/src/frama-c/react-pivottable.d.ts b/ivette/src/frama-c/react-pivottable.d.ts
new file mode 100644
index 0000000000000000000000000000000000000000..69405ebe30afd6ccfd34a8248511096bf09ad711
--- /dev/null
+++ b/ivette/src/frama-c/react-pivottable.d.ts
@@ -0,0 +1,23 @@
+/* ************************************************************************ */
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/* ************************************************************************ */
+
+declare module 'react-pivottable/PivotTableUI';
diff --git a/ivette/src/frama-c/states.ts b/ivette/src/frama-c/states.ts
index 17b2cdecf005275456e90cd68e53e1b03c856608..cd761f407f26511a76d2fcf0dda689c3dffb5179 100644
--- a/ivette/src/frama-c/states.ts
+++ b/ivette/src/frama-c/states.ts
@@ -39,7 +39,7 @@ import { Order } from 'dome/data/compare';
import { GlobalState, useGlobalState } from 'dome/data/states';
import { Client, useModel } from 'dome/table/models';
import { CompactModel } from 'dome/table/arrays';
-import * as Ast from 'frama-c/api/kernel/ast';
+import * as Ast from 'frama-c/kernel/api/ast';
import * as Server from './server';
const PROJECT = new Dome.Event('frama-c.project');
@@ -448,7 +448,7 @@ function lookupSyncArray<K, A>(
array: Array<K, A>,
): SyncArray<K, A> {
const id = `${currentProject}@${array.name}`;
- let st = syncArrays.get(id) as SyncArray<K,A> | undefined;
+ let st = syncArrays.get(id) as SyncArray<K, A> | undefined;
if (!st) {
st = new SyncArray(array);
syncArrays.set(id, st as SyncArray<unknown, unknown>);
diff --git a/ivette/src/frama-c/utils.ts b/ivette/src/frama-c/utils.ts
index 2bb2a6413569fea08c9055f62cd48c299a88aef7..f4ac8ec30988a8eab0dd910571be06f191f4816c 100644
--- a/ivette/src/frama-c/utils.ts
+++ b/ivette/src/frama-c/utils.ts
@@ -31,7 +31,7 @@
import * as Dome from 'dome';
import * as DomeBuffers from 'dome/text/buffers';
-import * as KernelData from 'frama-c/api/kernel/data';
+import * as KernelData from 'frama-c/kernel/api/data';
const D = new Dome.Debug('Utils');
diff --git a/ivette/yarn.lock b/ivette/yarn.lock
index cf9d9194ab96324c64e326719d726c7346dcf010..c423bf7fe1d48d7ea40479de19ef7cbb61633836 100644
--- a/ivette/yarn.lock
+++ b/ivette/yarn.lock
@@ -2571,6 +2571,11 @@ class-utils@^0.3.5:
isobject "^3.0.0"
static-extend "^0.1.1"
+classnames@^2.2.5:
+ version "2.3.1"
+ resolved "https://registry.yarnpkg.com/classnames/-/classnames-2.3.1.tgz#dfcfa3891e306ec1dad105d0e88f4417b8535e8e"
+ integrity sha512-OlQdbZ7gLfGarSqxesMesDa5uz7KFbID8Kpq/SxIoNGDqY8lSYs0D+hhtBXhcdB3rcbXArFr7vlHheLk1voeNA==
+
clean-css@^4.2.3:
version "4.2.4"
resolved "https://registry.yarnpkg.com/clean-css/-/clean-css-4.2.4.tgz#733bf46eba4e607c6891ea57c24a989356831178"
@@ -5054,6 +5059,13 @@ immediate@~3.0.5:
resolved "https://registry.yarnpkg.com/immediate/-/immediate-3.0.6.tgz#9db1dbd0faf8de6fbe0f5dd5e56bb606280de69b"
integrity sha1-nbHb0Pr43m++D13V5Wu2BigN5ps=
+immutability-helper@^2.3.1:
+ version "2.9.1"
+ resolved "https://registry.yarnpkg.com/immutability-helper/-/immutability-helper-2.9.1.tgz#71c423ba387e67b6c6ceba0650572f2a2a6727df"
+ integrity sha512-r/RmRG8xO06s/k+PIaif2r5rGc3j4Yhc01jSBfwPCXDLYZwp/yxralI37Df1mwmuzcCsen/E/ITKcTEvc1PQmQ==
+ dependencies:
+ invariant "^2.2.0"
+
immutable@:
version "4.0.0"
resolved "https://registry.yarnpkg.com/immutable/-/immutable-4.0.0.tgz#b86f78de6adef3608395efb269a91462797e2c23"
@@ -5150,6 +5162,13 @@ interpret@^1.4.0:
resolved "https://registry.yarnpkg.com/interpret/-/interpret-1.4.0.tgz#665ab8bc4da27a774a40584e812e3e0fa45b1a1e"
integrity sha512-agE4QfB2Lkp9uICn7BAqoscw4SZP9kTE2hxiFI3jBPmXJfdqiahTbUuKGsMoN2GtqL9AxhYioAcVvgsb1HvRbA==
+invariant@^2.2.0:
+ version "2.2.4"
+ resolved "https://registry.yarnpkg.com/invariant/-/invariant-2.2.4.tgz#610f3c92c9359ce1db616e538008d23ff35158e6"
+ integrity sha512-phJfQVBuaJM5raOpJjSfkiD6BpbCE4Ns//LaXl6wGYtUBY83nWS6Rf9tXm2e8VaK60JEjYldbPif/A2B1C2gNA==
+ dependencies:
+ loose-envify "^1.0.0"
+
ip-regex@^2.1.0:
version "2.1.0"
resolved "https://registry.yarnpkg.com/ip-regex/-/ip-regex-2.1.0.tgz#fa78bf5d2e6913c911ce9f819ee5146bb6d844e9"
@@ -5843,7 +5862,7 @@ loglevel@^1.6.8:
resolved "https://registry.yarnpkg.com/loglevel/-/loglevel-1.8.0.tgz#e7ec73a57e1e7b419cb6c6ac06bf050b67356114"
integrity sha512-G6A/nJLRgWOuuwdNuA6koovfEV1YpqqAG4pRUlFaz3jj2QNZ8M4vBqnVA+HBTmU/AMNUtlOsMmSpF6NyOjztbA==
-loose-envify@^1.1.0, loose-envify@^1.4.0:
+loose-envify@^1.0.0, loose-envify@^1.1.0, loose-envify@^1.4.0:
version "1.4.0"
resolved "https://registry.yarnpkg.com/loose-envify/-/loose-envify-1.4.0.tgz#71ee51fa7be4caec1a63839f7e682d8132d30caf"
integrity sha512-lyuxPGr/Wfhrlem2CL/UcnUc1zcqKAImBDzukY7Y5F/yQiNdko6+fRLevlw1HgMySw7f611UIY408EtxRSoK3Q==
@@ -6988,6 +7007,15 @@ promise-inflight@^1.0.1:
resolved "https://registry.yarnpkg.com/promise-inflight/-/promise-inflight-1.0.1.tgz#98472870bf228132fcbdd868129bad12c3c029e3"
integrity sha1-mEcocL8igTL8vdhoEputEsPAKeM=
+prop-types@>=15.0.0, prop-types@^15.5.10:
+ version "15.8.1"
+ resolved "https://registry.yarnpkg.com/prop-types/-/prop-types-15.8.1.tgz#67d87bf1a694f48435cf332c24af10214a3140b5"
+ integrity sha512-oj87CgZICdulUohogVAR7AjlC0327U4el4L6eAvOqCeudMDVU0NThNaV+b9Df4dXgSP1gXMTnPdhfe/2qDH5cg==
+ dependencies:
+ loose-envify "^1.4.0"
+ object-assign "^4.1.1"
+ react-is "^16.13.1"
+
prop-types@^15.6.0, prop-types@^15.6.1, prop-types@^15.6.2, prop-types@^15.7.2:
version "15.7.2"
resolved "https://registry.yarnpkg.com/prop-types/-/prop-types-15.7.2.tgz#52c41e75b8c87e72b9d9360e0206b99dcbffa6c5"
@@ -7170,6 +7198,14 @@ react-dom@^16:
prop-types "^15.6.2"
scheduler "^0.19.1"
+react-draggable@^3.0.3:
+ version "3.3.2"
+ resolved "https://registry.yarnpkg.com/react-draggable/-/react-draggable-3.3.2.tgz#966ef1d90f2387af3c2d8bd3516f601ea42ca359"
+ integrity sha512-oaz8a6enjbPtx5qb0oDWxtDNuybOylvto1QLydsXgKmwT7e3GXC2eMVDwEMIUYJIFqVG72XpOv673UuuAq6LhA==
+ dependencies:
+ classnames "^2.2.5"
+ prop-types "^15.6.0"
+
react-draggable@^4.4.4:
version "4.4.4"
resolved "https://registry.yarnpkg.com/react-draggable/-/react-draggable-4.4.4.tgz#5b26d9996be63d32d285a426f41055de87e59b2f"
@@ -7197,7 +7233,7 @@ react-hot-loader@^4:
shallowequal "^1.1.0"
source-map "^0.7.3"
-react-is@^16.7.0, react-is@^16.8.1:
+react-is@^16.13.1, react-is@^16.7.0, react-is@^16.8.1:
version "16.13.1"
resolved "https://registry.yarnpkg.com/react-is/-/react-is-16.13.1.tgz#789729a4dc36de2999dc156dd6c1d9c18cea56a4"
integrity sha512-24e6ynE2H+OKt4kqsOvNd8kBpV65zoxbA4BVsEOB3ARVWQki/DHzaUoC5KuON/BiccDaCCTZBuOcfZs70kR8bQ==
@@ -7207,6 +7243,24 @@ react-lifecycles-compat@^3.0.4:
resolved "https://registry.yarnpkg.com/react-lifecycles-compat/-/react-lifecycles-compat-3.0.4.tgz#4f1a273afdfc8f3488a8c516bfda78f872352362"
integrity sha512-fBASbA6LnOU9dOU2eW7aQ8xmYBSXUIWr+UmF9b1efZBazGNO+rcXT/icdKnYm2pTwcRylVUYwW7H1PHfLekVzA==
+react-pivottable@^0.11.0:
+ version "0.11.0"
+ resolved "https://registry.yarnpkg.com/react-pivottable/-/react-pivottable-0.11.0.tgz#2ac9a28db6bdcefdb7bdeeb1ed067df229bb9dd8"
+ integrity sha512-hFU10XYL28NWVRnm+RRyHrzsAn/xIJzPgwPebUE2Hx5JZQl/Zxty3WUL/5cAcdK4AmTb9FQBRopLKLwuiI6VlA==
+ dependencies:
+ immutability-helper "^2.3.1"
+ prop-types "^15.5.10"
+ react-draggable "^3.0.3"
+ react-sortablejs "^1.3.4"
+ sortablejs "^1.6.1"
+
+react-sortablejs@^1.3.4:
+ version "1.5.1"
+ resolved "https://registry.yarnpkg.com/react-sortablejs/-/react-sortablejs-1.5.1.tgz#ba05a554548cf9733cc2d5411ece9b97f911b63e"
+ integrity sha512-bKIc1UVhjZt55Nb6WZFxZ8Jwyngg8CTt+w+iG1pA5k9LQsg1J0X6nLppHatSSDZDECtRZKp2z47tmmhPRJNj4g==
+ dependencies:
+ prop-types ">=15.0.0"
+
react-virtualized@^9.22.3:
version "9.22.3"
resolved "https://registry.yarnpkg.com/react-virtualized/-/react-virtualized-9.22.3.tgz#f430f16beb0a42db420dbd4d340403c0de334421"
@@ -7943,6 +7997,11 @@ sort-keys@^1.0.0:
dependencies:
is-plain-obj "^1.0.0"
+sortablejs@^1.6.1:
+ version "1.14.0"
+ resolved "https://registry.yarnpkg.com/sortablejs/-/sortablejs-1.14.0.tgz#6d2e17ccbdb25f464734df621d4f35d4ab35b3d8"
+ integrity sha512-pBXvQCs5/33fdN1/39pPL0NZF20LeRbLQ5jtnheIPN9JQAaufGjKdWduZn4U7wCtVuzKhmRkI0DFYHYRbB2H1w==
+
source-list-map@^2.0.0:
version "2.0.1"
resolved "https://registry.yarnpkg.com/source-list-map/-/source-list-map-2.0.1.tgz#3993bd873bfc48479cca9ea3a547835c7c154b34"
diff --git a/share/analysis-scripts/build.py b/share/analysis-scripts/build.py
new file mode 100755
index 0000000000000000000000000000000000000000..768082a01d42c21ea3621d7dc92bebf382ecf79b
--- /dev/null
+++ b/share/analysis-scripts/build.py
@@ -0,0 +1,352 @@
+#!/usr/bin/env python3
+#-*- coding: utf-8 -*-
+##########################################################################
+# #
+# This file is part of Frama-C. #
+# #
+# Copyright (C) 2007-2021 #
+# CEA (Commissariat à l'énergie atomique et aux énergies #
+# alternatives) #
+# #
+# you can redistribute it and/or modify it under the terms of the GNU #
+# Lesser General Public License as published by the Free Software #
+# Foundation, version 2.1. #
+# #
+# It is distributed in the hope that it will be useful, #
+# but WITHOUT ANY WARRANTY; without even the implied warranty of #
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
+# GNU Lesser General Public License for more details. #
+# #
+# See the GNU Lesser General Public License version 2.1 #
+# for more details (enclosed in the file licenses/LGPLv2.1). #
+# #
+##########################################################################
+
+# This script uses blug and a build_commands.json file to produce an
+# analysis GNUmakefile, as automatically as possible.
+
+import argparse
+import json
+import logging
+import os
+from pathlib import Path
+import re
+import shutil
+import sys
+import subprocess
+
+import function_finder
+import source_filter
+
+script_dir = os.path.dirname(sys.argv[0])
+
+# Command-line parsing ########################################################
+
+parser = argparse.ArgumentParser(description="""Produces a GNUmakefile
+for analysis with Frama-C. Tries to use a build_commands.json file if
+available.""")
+parser.add_argument('--debug', metavar='FILE',
+ help='enable debug mode and redirect output to the specified file')
+parser.add_argument('--force', action="store_true",
+ help='overwrite files without prompting')
+parser.add_argument('--jbdb', metavar='FILE', default="build_commands.json",
+ help='path to JBDB (default: build_commands.json)')
+parser.add_argument('--machdep', metavar='MACHDEP',
+ help="analysis machdep (default: Frama-C's default)")
+parser.add_argument('--main', metavar='FUNCTION', default="main",
+ help='name of the main function (default: main)')
+parser.add_argument('--sources', metavar='FILE', nargs='+',
+ help='list of sources to parse (overrides --jbdb)',
+ type=Path)
+parser.add_argument('--targets', metavar='FILE', nargs='+',
+ help='targets to build. When using --sources, ' +
+ 'only a single target is allowed.',
+ type=Path)
+
+args = parser.parse_args()
+force = args.force
+jbdb_path = args.jbdb
+machdep = args.machdep
+main = args.main
+sources = args.sources
+targets = args.targets
+debug = args.debug
+
+debug_level = logging.DEBUG if debug else logging.INFO
+# special values for debug filename
+if debug == "stdout":
+ logging.basicConfig(stream=sys.stdout, level=debug_level,
+ format='[%(levelname)s] %(message)s')
+elif debug == "stderr":
+ logging.basicConfig(stream=sys.stderr, level=debug_level,
+ format='[%(levelname)s] %(message)s')
+elif debug:
+ logging.basicConfig(filename=debug, level=debug_level, filemode='w',
+ format='[%(levelname)s] %(message)s')
+else:
+ logging.basicConfig(level=logging.INFO,
+ format='[%(levelname)s] %(message)s')
+
+dot_framac_dir = Path(".frama-c")
+
+# Check required environment variables and commands in the PATH ###############
+
+framac_bin = os.getenv('FRAMAC_BIN')
+if not framac_bin:
+ sys.exit("error: FRAMAC_BIN not in environment (set by frama-c-script)")
+framac_bin = Path(framac_bin)
+
+under_test = os.getenv("PTESTS_TESTING")
+
+# Prepare blug-related variables and functions ################################
+
+blug = os.getenv('BLUG')
+if not blug:
+ blug = shutil.which("blug")
+ if not blug:
+ sys.exit("error: path to 'blug' binary must be in PATH or variable BLUG")
+blug = Path(blug)
+blug_dir = blug.resolve().parent
+blug_print = blug_dir / "blug-print"
+# to import blug_jbdb
+sys.path.insert(0, blug_dir.as_posix())
+import blug_jbdb
+from blug_jbdb import prettify
+
+
+# Auxiliary functions #########################################################
+
+def call_and_get_output(command_and_args):
+ try:
+ return subprocess.check_output(command_and_args, stderr=subprocess.STDOUT).decode()
+ except subprocess.CalledProcessError as e:
+ sys.exit(f"error running command: {command_and_args}\n{e}")
+
+def ask_if_overwrite(path):
+ yn = input(f"warning: {path} already exists. Overwrite? [y/N] ")
+ if yn == "" or not (yn[0] == "Y" or yn[0] == "y"):
+ sys.exit("Exiting without overwriting.")
+
+def insert_lines_after(lines, line_pattern, new_lines):
+ re_line = re.compile(line_pattern)
+ for i, line in enumerate(lines):
+ if re_line.search(line):
+ for j, new_line in enumerate(new_lines):
+ lines.insert(i+1+j, new_line)
+ return
+ sys.exit(f"error: no lines found matching pattern: {line_pattern}")
+
+# delete the first occurrence of [line_pattern]
+def delete_line(lines, line_pattern):
+ re_line = re.compile(line_pattern)
+ for i, line in enumerate(lines):
+ if re_line.search(line):
+ del lines[i]
+ return
+ sys.exit(f"error: no lines found matching pattern: {line_pattern}")
+
+def replace_line(lines, line_pattern, value, all_occurrences=False):
+ replaced = False
+ re_line = re.compile(line_pattern)
+ for i, line in enumerate(lines):
+ if re_line.search(line):
+ lines[i] = value
+ replaced = True
+ if not all_occurrences:
+ return
+ if replaced:
+ return
+ sys.exit(f"error: no lines found matching pattern: {line_pattern}")
+
+# replaces '/' and '.' with '_' so that a valid target name is created
+def make_target_name(target):
+ return prettify(target).replace('/', '_').replace('.', '_')
+
+# sources are pretty-printed relatively to the .frama-c directory, where the
+# GNUmakefile will reside
+def rel_prefix(path):
+ return path if os.path.isabs(path) else os.path.relpath(path, start=dot_framac_dir)
+
+def pretty_sources(sources):
+ return [f" {rel_prefix(source)} \\" for source in sources]
+
+def lines_of_file(path):
+ return path.read_text().splitlines()
+
+fc_stubs_copied = False
+def copy_fc_stubs():
+ global fc_stubs_copied
+ dest = dot_framac_dir / "fc_stubs.c"
+ if not fc_stubs_copied:
+ fc_stubs = lines_of_file(share_dir / "analysis-scripts" / "fc_stubs.c")
+ re_main = re.compile(r"\bmain\b")
+ for i, line in enumerate(fc_stubs):
+ if line.startswith("//"):
+ continue
+ fc_stubs[i] = re.sub(re_main, main, line)
+ if not force and dest.exists():
+ ask_if_overwrite(dest)
+ with open(dest,"w") as f:
+ f.write("\n".join(fc_stubs))
+ logging.info("wrote: %s", dest)
+ fc_stubs_copied = True
+ return dest
+
+# Returns pairs (line_number, has_args) for each likely definition of
+# [funcname] in [filename].
+# [has_args] is used to distinguish between main(void) and main(int, char**).
+def find_definitions(funcname, filename):
+ file_content = source_filter.open_and_filter(filename, not under_test)
+ file_lines = file_content.splitlines(keepends=True)
+ newlines = function_finder.compute_newline_offsets(file_lines)
+ defs = function_finder.find_definitions_and_declarations(True, False, filename, file_content, file_lines, newlines, funcname)
+ res = []
+ for d in defs:
+ defining_line = file_lines[d[2]-1]
+ after_funcname = defining_line[defining_line.find(funcname)+len(funcname):]
+ # heuristics: if there is a comma after the function name,
+ # it is very likely the signature contains arguments;
+ # otherwise, the function is either defined in several lines,
+ # or we somehow missed it. By default, we assume it has no arguments
+ # if we miss it.
+ has_args = ',' in after_funcname
+ res.append((d[2], has_args))
+ return res
+
+# End of auxiliary functions ##################################################
+
+sources_map = dict()
+if sources:
+ if not targets:
+ sys.exit("error: option --targets is mandatory when --sources is specified")
+ if len(targets) > 1:
+ sys.exit("error: option --targets can only have a single target when --sources is specified")
+ sources_map[targets[0]] = [s for s in sources if blug_jbdb.filter_source(s)]
+elif os.path.isfile(jbdb_path):
+ # JBDB exists
+ with open(jbdb_path, "r") as data:
+ jbdb = json.load(data)
+ blug_jbdb.absolutize_jbdb(jbdb)
+ jbdb_targets = []
+ for f in jbdb:
+ jbdb_targets += [t for t in f["targets"] if blug_jbdb.filter_target(t)]
+ if not jbdb_targets:
+ sys.exit(f"no targets found in JBDB ({jbdb_path})")
+ if not targets:
+ # no targets specified in command line; use all from JBDB
+ targets = jbdb_targets
+ logging.info("Computing sources for each target (%d target(s))...", len(targets))
+ unknown_targets = []
+ graph = blug_jbdb.build_graph(jbdb)
+ for target in targets:
+ if target not in jbdb_targets:
+ unknown_targets.append(target)
+ else:
+ if unknown_targets != []:
+ continue # already found a problem; avoid useless computations
+ sources = [s for s in blug_jbdb.collect_leaves(graph, [target]) if blug_jbdb.filter_source(s)]
+ sources_map[target] = sorted(sources)
+ if unknown_targets:
+ targets_pretty = "\n".join(unknown_targets)
+ sys.exit("target(s) not found in JBDB:\n{targets_pretty}")
+else:
+ if not jbdb_path:
+ sys.exit("error: either a JBDB or option --sources are required")
+ else:
+ sys.exit(f"error: invalid JBDB path: '{jbdb_path}'")
+
+logging.debug("sources_map: %s", sorted([prettify(k) + ": " + ', '.join(sorted([prettify(s) for s in v])) for (k, v) in sources_map.items()]))
+logging.debug("targets: %s", sorted([prettify(t) for t in targets]))
+
+# check that source files exist
+unknown_sources = sorted({s for sources in sources_map.values() for s in sources if not s.exists()})
+if unknown_sources:
+ sys.exit("error: source(s) not found:\n" + "\n".join([prettify(s) for s in unknown_sources]))
+
+# Check that the main function is defined exactly once per target.
+# note: this is only based on heuristics (and fails on a few real case studies),
+# so we cannot emit errors, only warnings.
+# We also need to check if the main function uses a 'main(void)'-style
+# signature, to patch fc_stubs.c.
+
+main_definitions = {}
+for target, sources in sources_map.items():
+ main_definitions[target] = []
+ for source in sources:
+ fundefs = find_definitions(main, source)
+ main_definitions[target] += [(source, fundef[0], fundef[1]) for fundef in fundefs]
+ if main_definitions[target] == []:
+ logging.warning("function '%s' seems to be never defined in the sources of target '%s'", main, prettify(target))
+ elif len(main_definitions[target]) > 1:
+ logging.warning("function '%s' seems to be defined multiple times in the sources of target '%s':", main, prettify(target))
+ for (filename, line, _) in main_definitions[target]:
+ print(f"- definition at {filename}:{line}")
+
+# End of checks; start writing GNUmakefile and stubs from templates ###########
+
+if not dot_framac_dir.is_dir():
+ logging.debug("creating %s", dot_framac_dir)
+ dot_framac_dir.mkdir(parents=True, exist_ok=False)
+
+fc_config = json.loads(call_and_get_output([framac_bin / "frama-c", "-print-config-json"]))
+share_dir = Path(fc_config['datadir'])
+
+# copy fc_stubs if at least one main function has arguments
+any_has_arguments = False
+for defs in main_definitions.values():
+ if any(d[2] for d in defs):
+ any_has_arguments = True
+ break
+
+if any_has_arguments:
+ fc_stubs = copy_fc_stubs()
+ for target in targets:
+ if any(d[2] for d in main_definitions[target]):
+ logging.debug("target %s has main with args, adding fc_stubs.c to its sources", prettify(target))
+ sources_map[target].insert(0, fc_stubs)
+
+gnumakefile = dot_framac_dir / "GNUmakefile"
+
+template = lines_of_file(share_dir / "analysis-scripts" / "template.mk")
+
+if machdep:
+ machdeps = fc_config['machdeps']
+ if machdep not in machdeps:
+ logging.warning("unknown machdep (%s) not in Frama-C's default machdeps:\n%s", machdep, " ".join(machdeps))
+ replace_line(template, "^MACHDEP = .*", f"MACHDEP = {machdep}")
+
+if jbdb_path:
+ insert_lines_after(template, "^FCFLAGS", [f" -json-compilation-database {rel_prefix(jbdb_path)} \\"])
+
+targets_eva = ([f" {make_target_name(target)}.eva \\" for target in targets])
+replace_line(template, "^TARGETS = main.eva", "TARGETS = \\")
+insert_lines_after(template, r"^TARGETS = \\", targets_eva)
+
+delete_line(template, r"^main.parse: \\")
+delete_line(template, r"^ main.c \\")
+for target, sources in reversed(sources_map.items()):
+ pp_target = make_target_name(target)
+ new_lines = [f"{pp_target}.parse: \\"] + pretty_sources(sources) + [""]
+ if any(d[2] for d in main_definitions[target]):
+ logging.debug("target %s has main with args, adding -main eva_main to its FCFLAGS", prettify(target))
+ new_lines += [f"{pp_target}.parse: FCFLAGS += -main eva_main", ""]
+ insert_lines_after(template, "^### Each target <t>.eva", new_lines)
+
+gnumakefile.write_text("\n".join(template))
+
+logging.info("wrote: %s", gnumakefile)
+
+# write path.mk, but only if it does not exist.
+path_mk = dot_framac_dir / "path.mk"
+if not force and path_mk.exists():
+ logging.info("%s already exists, will not overwrite it", path_mk)
+else:
+ path_mk.write_text(f"""FRAMAC_BIN={framac_bin}
+ifeq ($(wildcard $(FRAMAC_BIN)),)
+# Frama-C not installed locally; using the version in the PATH
+else
+FRAMAC=$(FRAMAC_BIN)/frama-c
+FRAMAC_GUI=$(FRAMAC_BIN)/frama-c-gui
+endif
+""")
+ logging.info("wrote: %s", path_mk)
diff --git a/share/analysis-scripts/build_callgraph.py b/share/analysis-scripts/build_callgraph.py
index b53e0d33bb133f15413b096c368f0cc8701d3df2..a1047a70e0eaa9d92044396ed947d5178c2a0822 100755
--- a/share/analysis-scripts/build_callgraph.py
+++ b/share/analysis-scripts/build_callgraph.py
@@ -25,14 +25,14 @@
# This script finds files containing likely declarations and definitions
# for a given function name, via heuristic syntactic matching.
-import sys
import os
import re
+import sys
+
import function_finder
+import source_filter
-MIN_PYTHON = (3, 5)
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
+under_test = os.getenv("PTESTS_TESTING")
arg = ""
if len(sys.argv) < 2:
@@ -78,13 +78,13 @@ class Callgraph:
return f"Callgraph({self.succs}, {self.edges})"
def compute(files):
- #print(f"Computing callgraph for {len(files)} file(s)...")
cg = Callgraph()
for f in files:
- #print(f"Processing {os.path.relpath(f)}...")
- newlines = function_finder.compute_newline_offsets(f)
- defs = function_finder.find_definitions_and_declarations(True, False, f, newlines)
- calls = function_finder.find_calls(f, newlines)
+ file_content = source_filter.open_and_filter(f, not under_test)
+ file_lines = file_content.splitlines(keepends=True)
+ newlines = function_finder.compute_newline_offsets(file_lines)
+ defs = function_finder.find_definitions_and_declarations(True, False, f, file_content, file_lines, newlines)
+ calls = function_finder.find_calls(file_content, newlines)
for call in calls:
caller = function_finder.find_caller(defs, call)
if caller:
@@ -93,7 +93,6 @@ def compute(files):
if debug:
print(f"build_callgraph: {f}:{line}: {caller} -> {called}")
cg.add_edge(caller, called, loc)
- #print(f"Callgraph computed ({len(cg.succs)} node(s), {len(cg.edges)} edge(s))")
return cg
def print_edge(cg, caller, called, padding="", end="\n"):
diff --git a/share/analysis-scripts/detect_recursion.py b/share/analysis-scripts/detect_recursion.py
index 332d80f3b8ca50eb555c5100b68d96dc7c880e4f..c5da73ad2f3712259a6b8cde93193997ee9a45f9 100755
--- a/share/analysis-scripts/detect_recursion.py
+++ b/share/analysis-scripts/detect_recursion.py
@@ -28,10 +28,6 @@
import sys
import build_callgraph
-MIN_PYTHON = (3, 5) # for glob(recursive)
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
arg = ""
if len(sys.argv) < 2:
print(f"usage: {sys.argv[0]} [file1 file2 ...]")
diff --git a/share/analysis-scripts/estimate_difficulty.py b/share/analysis-scripts/estimate_difficulty.py
index dab975aabac5e7bf03d0de6a7f20bb4adac0a367..2c41c48764a52c397cf913ee3ae4a1a1a1ae819f 100755
--- a/share/analysis-scripts/estimate_difficulty.py
+++ b/share/analysis-scripts/estimate_difficulty.py
@@ -26,25 +26,23 @@
# of analyzing a new code base with Frama-C.
import argparse
-import build_callgraph
-import function_finder
import json
import os
-from pathlib import Path
+from pathlib import Path
import re
import subprocess
import sys
import tempfile
+import build_callgraph
+import function_finder
+import source_filter
+
#TODO : avoid relativizing paths when introducing too many ".." ;
#TODO : accept directory as argument (--full-tree), and then do glob **/*.{c,i} inside
#TODO : try to check the presence of compiler builtins
#TODO : try to check for pragmas
-MIN_PYTHON = (3, 5)
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
parser = argparse.ArgumentParser(description="""
Estimates the difficulty of analyzing a given code base""")
parser.add_argument("--header-dirs", "-d", metavar='DIR', nargs='+',
@@ -57,6 +55,8 @@ if not header_dirs:
header_dirs = []
files = args["files"]
+under_test = os.getenv("PTESTS_TESTING")
+
# gather information from several sources
def extract_keys(l):
@@ -79,16 +79,16 @@ def get_framac_libc_function_statuses(framac, framac_share):
return (defined, spec_only)
re_include = re.compile(r'\s*#\s*include\s*("|<)([^">]+)("|>)')
-def grep_includes_in_file(file):
- with open(file, "r", encoding="utf-8", errors='ignore') as f:
- i = 0
- for line in f.readlines():
- i += 1
- m = re_include.match(line)
- if m:
- kind = m.group(1)
- header = m.group(2)
- yield((i,kind,header))
+def grep_includes_in_file(filename):
+ file_content = source_filter.open_and_filter(filename, not under_test)
+ i = 0
+ for line in file_content.splitlines():
+ i += 1
+ m = re_include.match(line)
+ if m:
+ kind = m.group(1)
+ header = m.group(2)
+ yield((i,kind,header))
def get_includes(files):
quote_includes = {}
@@ -165,9 +165,10 @@ for callee in sorted(callees):
warnings += 1
if verbose or debug or status == "warning":
print(f"- {status}: {callee} ({standard}) {reason}")
- #print(f"callee: {callee}")
+ is_problematic = callee in posix_identifiers and "notes" in posix_identifiers[callee] and "fc-support" in posix_identifiers[callee]["notes"] and posix_identifiers[callee]["notes"]["fc-support"] == "problematic"
if callee in posix_identifiers:
used_headers.add(posix_identifiers[callee]["header"])
+ status_emitted = False # to avoid re-emitting a message for functions in both C11 and POSIX
if callee in c11_functions:
standard = "C11"
# check that the callee is not a macro or type (e.g. va_arg);
@@ -175,30 +176,40 @@ for callee in sorted(callees):
# so we must test membership before checking the POSIX type
if callee in posix_identifiers and posix_identifiers[callee]["id_type"] != "function":
continue
- #print(f"C11 function: {callee}")
- if callee in libc_specified_functions:
+ if (not is_problematic) and callee in libc_specified_functions:
callee_status("good", standard, "is specified in Frama-C's libc")
- elif callee in libc_defined_functions:
+ status_emitted = True
+ elif (not is_problematic) and callee in libc_defined_functions:
callee_status("ok", standard, "is defined in Frama-C's libc")
+ status_emitted = True
else:
- # Some functions without specification are actually variadic
- # (and possibly handled by the Variadic plug-in)
- if callee in posix_identifiers and "notes" in posix_identifiers[callee] and "variadic-plugin" in posix_identifiers[callee]["notes"]:
- callee_status("ok", standard, "is handled by the Variadic plug-in")
- else:
+ if callee not in posix_identifiers:
callee_status("warning", standard, "has neither code nor spec in Frama-C's libc")
- elif callee in posix_identifiers:
+ status_emitted = True
+ if not status_emitted and callee in posix_identifiers:
standard = "POSIX"
# check that the callee is not a macro or type (e.g. va_arg)
if posix_identifiers[callee]["id_type"] != "function":
continue
- #print(f"Non-C11, POSIX function: {callee}")
- if callee in libc_specified_functions:
+ if (not is_problematic) and callee in libc_specified_functions:
callee_status("good", standard, "specified in Frama-C's libc")
- elif callee in libc_defined_functions:
+ status_emitted = True
+ elif (not is_problematic) and callee in libc_defined_functions:
callee_status("ok", standard, "defined in Frama-C's libc")
+ status_emitted = True
else:
- callee_status("warning", standard, "has neither code nor spec in Frama-C's libc")
+ # Some functions without specification are actually variadic
+ # (and possibly handled by the Variadic plug-in)
+ if "notes" in posix_identifiers[callee]:
+ if "variadic-plugin" in posix_identifiers[callee]["notes"]:
+ callee_status("ok", standard, "is handled by the Variadic plug-in")
+ status_emitted = True
+ elif is_problematic:
+ callee_status("warning", standard, "is known to be problematic for code analysis")
+ status_emitted = True
+ if not status_emitted:
+ callee_status("warning", standard, "has neither code nor spec in Frama-C's libc")
+
print(f"Function-related warnings: {warnings}")
if (verbose or debug) and used_headers:
@@ -217,13 +228,13 @@ def is_local_header(header_dirs, header):
print(f"Estimating difficulty for {len(chevron_includes)} '#include <header>' directives...")
non_posix_headers = []
+header_warnings = 0
for header in sorted(chevron_includes, key=str.casefold):
if header in posix_headers:
fc_support = posix_headers[header]["fc-support"]
if fc_support == "unsupported":
+ header_warnings += 1
print(f"- WARNING: included header <{header}> is explicitly unsupported by Frama-C")
- elif fc_support == "none":
- print(f"- warning: included header <{header}> not currently included in Frama-C's libc")
else:
if verbose or debug:
c11_or_posix = "C11" if header in c11_headers else "POSIX"
@@ -234,8 +245,9 @@ for header in sorted(chevron_includes, key=str.casefold):
print(f"- ok: included header <{header}> seems to be available locally")
else:
non_posix_headers.append(header)
+ header_warnings += 1
print(f"- warning: included non-POSIX header <{header}>")
-print(f"Header-related warnings: {len(non_posix_headers)}")
+print(f"Header-related warnings: {header_warnings}")
# dynamic allocation
@@ -248,7 +260,9 @@ if dyncallees:
# unsupported C11-specific features
-c11_unsupported = ["_Alignas", "_Alignof", "_Generic", "_Static_assert"]
+c11_unsupported = ["_Alignas", "_Alignof", "_Complex", "_Generic", "_Imaginary",
+ "alignas", "alignof" # stdalign.h may use these symbols instead of the C11 keywords
+ ];
for keyword in c11_unsupported:
out = subprocess.Popen(["grep", "-n", '\\b' + keyword + '\\b'] + files + ["/dev/null"],
diff --git a/share/analysis-scripts/find_fun.py b/share/analysis-scripts/find_fun.py
index b14e429fba77ebf14b0e952f5826b0ffa71a6a10..c05fbb68af1854602b05ca2587450f0c1cb501cd 100755
--- a/share/analysis-scripts/find_fun.py
+++ b/share/analysis-scripts/find_fun.py
@@ -32,10 +32,6 @@ import re
import sys
from pathlib import Path
-MIN_PYTHON = (3, 5) # for glob(recursive)
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
parser = argparse.ArgumentParser(description="""
Looks for likely declarations/definitions of a function
in files with extensions '.c', '.h' and '.i'.
@@ -78,12 +74,15 @@ possible_declarators = []
possible_definers = []
re_fun = function_finder.prepare_re_specific_name(fname)
for f in files:
- found = function_finder.find_specific_name(re_fun, f)
- if found:
- if found == 1:
- possible_declarators.append(f)
- else:
- possible_definers.append(f)
+ try:
+ found = function_finder.find_specific_name(re_fun, f)
+ if found:
+ if found == 1:
+ possible_declarators.append(f)
+ else:
+ possible_definers.append(f)
+ except OSError as e:
+ print(f"error opening '{f}' ({e.errno}, {e.strerror}), skipping file")
def relative_path_to(start):
return lambda p: os.path.relpath(p, start=start)
diff --git a/share/analysis-scripts/function_finder.py b/share/analysis-scripts/function_finder.py
index e68f15ee479361b58be8bbea9284b2538b0130e5..7aef53cef0644df796ea85810fb9545c8de7c849 100755
--- a/share/analysis-scripts/function_finder.py
+++ b/share/analysis-scripts/function_finder.py
@@ -60,9 +60,9 @@ def prepare_re_specific_name(fname):
# Returns 0 if not found, 1 if declaration, 2 if definition
def find_specific_name(prepared_re, f):
- with open(f, encoding="ascii", errors='ignore') as content_file:
- content = content_file.read()
- has_decl_or_def = prepared_re.search(content)
+ with open(f, encoding="ascii", errors='ignore') as data:
+ file_content = data.read()
+ has_decl_or_def = prepared_re.search(file_content)
if has_decl_or_def is None:
return 0
else:
@@ -70,33 +70,35 @@ def find_specific_name(prepared_re, f):
return 1 if is_decl else 2
-# matches function definitions
-re_fundef_or_decl = re.compile("^" + optional_type_prefix +
- "(" + c_identifier + ")" + whitespace +
- argument_list + whitespace +
- optional_c_id + whitespace + "(;|{)",
- flags=re.DOTALL | re.MULTILINE)
+# matches function definitions or declarations
+# if funcname is not None, only matches for the specified
+# function name
+def compute_re_def_or_decl(funcname):
+ id = funcname if funcname else c_identifier
+ return re.compile("^" + optional_type_prefix +
+ "(" + id + ")" + whitespace +
+ argument_list + whitespace +
+ optional_c_id + whitespace + "(;|{)",
+ flags=re.DOTALL | re.MULTILINE)
# matches function calls
re_funcall = re.compile("(" + c_identifier + ")" + whitespace + "\(")
# Computes the offset (in bytes) of each '\n' in the file,
# returning them as a list
-def compute_newline_offsets(filename):
+def compute_newline_offsets(file_lines):
offsets = []
current = 0
- with open(filename, encoding="ascii", errors='ignore') as data:
- for line in data:
- current += len(line)
- offsets.append(current)
+ for line in file_lines:
+ current += len(line)
+ offsets.append(current)
return offsets
# Returns the line number (starting at 1) containing the character
# of offset [offset].
# [offsets] is the sorted list of offsets for newline characters in the file.
def line_of_offset(offsets, offset):
- i = bisect.bisect_right(offsets, offset)
- return i+1
+ return bisect.bisect_right(offsets, offset) + 1
# Returns the line number (starting at 1) of each line starting with '}'
# as its first character.
@@ -104,12 +106,19 @@ def line_of_offset(offsets, offset):
# This is a heuristic to attempt to detect function closing braces:
# it assumes that the first '}' (without preceding whitespace) after a
# function definition denotes its closing brace.
-def compute_closing_braces(filename):
+def compute_closing_braces(file_lines):
braces = []
- with open(filename, encoding="ascii", errors='ignore') as data:
- for i, line in enumerate(data, start=1):
- if line.startswith("}"):
- braces.append(i)
+ for i, line in enumerate(file_lines, start=1):
+ # note: lines contain '\n', so they are never empty
+ if line[0] == '}':
+ braces.append(i)
+ # Special heuristics: if the last line contains whitespace + '}',
+ # assume it closes a function.
+ last_line_number = len(file_lines)+1
+ if file_lines != [] and not (last_line_number in braces):
+ last_line = file_lines[-1].lstrip()
+ if len(last_line) >= 1 and last_line[0] == '}':
+ braces.append(last_line_number)
return braces
# Returns the first element of [line_numbers] greater than [n], or [None]
@@ -118,10 +127,11 @@ def compute_closing_braces(filename):
#
# [line_numbers] must be sorted in ascending order.
def get_first_line_after(line_numbers, n):
- for line in line_numbers:
- if line > n:
- return line
- return None
+ try:
+ return line_numbers[bisect.bisect_left(line_numbers, n)]
+ except IndexError:
+ # could not find line (e.g. for closing braces); return None
+ return None
# Returns a list of tuples (fname, is_def, line_start, line_end, terminator_offset)
# for each function definition or declaration.
@@ -133,37 +143,38 @@ def get_first_line_after(line_numbers, n):
# [terminator_offset] is used by the caller to filter the function prototype
# itself and avoid considering it as a call. For function definitions,
# this is the opening brace; for function declarations, this is the semicolon.
-def find_definitions_and_declarations(want_defs, want_decls, filename, newlines):
- braces = compute_closing_braces(filename)
- with open(filename, encoding="ascii", errors='ignore') as data:
- content = data.read()
+def find_definitions_and_declarations(want_defs, want_decls, filename, file_content, file_lines, newlines, funcname=None):
+ braces = compute_closing_braces(file_lines)
res = []
- for match in re.finditer(re_fundef_or_decl, content):
+ re_fundef_or_decl = compute_re_def_or_decl(funcname)
+ for match in re.finditer(re_fundef_or_decl, file_content):
funcname = match.group(1)
- is_def = match.group(2) == "{"
- is_decl = match.group(2) == ";"
+ terminator = match.group(2)
+ terminator_offset = match.start(2)
+ is_def = terminator == "{"
+ is_decl = terminator == ";"
assert is_def or is_decl
start = line_of_offset(newlines, match.start(1))
if is_decl:
if not want_decls:
continue
- end = line_of_offset(newlines, match.start(2))
+ end = line_of_offset(newlines, terminator_offset)
else:
if not want_defs:
continue
- definition = content[match.start(1):newlines[start-1]]
+ definition = file_content[match.start(1):newlines[start-1]]
# try "single-line function heuristic":
# assume the function is defined as 'type f(...) { code; }',
# in a single line
if definition.strip().endswith("}"):
- end = line_of_offset(newlines, match.start(2))
+ end = line_of_offset(newlines, terminator_offset)
else:
end = get_first_line_after(braces, start)
if not end:
# no closing braces found; try again the "single-line function heuristic"
def_start_newline_offset = newlines[start-1]
- line_of_opening_brace = line_of_offset(newlines, match.start(2))
- if start == line_of_opening_brace and definition.rstrip().endswith("}"):
+ line_of_opening_brace = line_of_offset(newlines, terminator_offset)
+ if start == line_of_opening_brace and definition.rstrip()[-1] == '}':
# assume the '}' is closing the '{' from the same line
end = line_of_opening_brace
else:
@@ -171,7 +182,6 @@ def find_definitions_and_declarations(want_defs, want_decls, filename, newlines)
print(f"{os.path.relpath(filename)}:{start}:closing brace not found, " +
f"skipping potential definition of '{funcname}'")
continue
- terminator_offset = match.start(2)
if debug:
print(f"function_finder: {'def' if is_def else 'decl'} of {funcname} between {start} and {end}")
res.append((funcname, is_def, start, end, terminator_offset))
@@ -184,12 +194,10 @@ calls_blacklist = ["if", "while", "for", "return", "sizeof", "switch", "_Alignas
#
# Note: this may include the function prototype itself;
# it must be filtered by the caller.
-def find_calls(filename, newlines):
- with open(filename, encoding="ascii", errors='ignore') as data:
- content = data.read()
+def find_calls(file_content, newlines):
# create a list of Match objects that fit "pattern" regex
res = []
- for match in re.finditer(re_funcall, content):
+ for match in re.finditer(re_funcall, file_content):
funcname = match.group(1)
offset = match.start(1)
line = line_of_offset(newlines, offset)
diff --git a/share/analysis-scripts/heuristic_list_functions.py b/share/analysis-scripts/heuristic_list_functions.py
index ceee3fd5a3cf2892f1ed5c8fc8de5b8e76ce3c82..93c2d5c82f5c6cd5b45d5c3fcae6bf2f42579cb4 100755
--- a/share/analysis-scripts/heuristic_list_functions.py
+++ b/share/analysis-scripts/heuristic_list_functions.py
@@ -30,10 +30,6 @@ import os
import re
import function_finder
-MIN_PYTHON = (3, 5) # for glob(recursive)
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
debug = bool(os.getenv("DEBUG", False))
arg = ""
@@ -55,8 +51,11 @@ want_decls = boolish_string(sys.argv[2])
files = sys.argv[3:]
for f in files:
- newlines = function_finder.compute_newline_offsets(f)
- defs_and_decls = function_finder.find_definitions_and_declarations(want_defs, want_decls, f, newlines)
+ with open(f, encoding="ascii", errors='ignore') as data:
+ file_content = data.read()
+ file_lines = file_content.splitlines(keepends=True)
+ newlines = function_finder.compute_newline_offsets(file_lines)
+ defs_and_decls = function_finder.find_definitions_and_declarations(want_defs, want_decls, f, file_content, file_lines, newlines)
for (funcname, is_def, start, end, _offset) in defs_and_decls:
if is_def:
print(f"{os.path.relpath(f)}:{start}:{end}: {funcname} (definition)")
diff --git a/share/analysis-scripts/list_files.py b/share/analysis-scripts/list_files.py
index ac822030be89c50fcde456d387e91d6708cc50f7..e39ae6cb6d2940e8fd7a8d54f9c4ca29a477a697 100755
--- a/share/analysis-scripts/list_files.py
+++ b/share/analysis-scripts/list_files.py
@@ -33,10 +33,6 @@ import json
import re
from pathlib import Path
-MIN_PYTHON = (3, 6) # for glob(recursive) and automatic Path conversions
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
if len(sys.argv) < 2:
# no argument, assume default name
arg = Path("compile_commands.json")
diff --git a/share/analysis-scripts/make_template.py b/share/analysis-scripts/make_template.py
index 6e47b60c60993be74bbc2d40a32e9cd45150f880..dad3225eeced1547e9ea2e295987b5b445a2d650 100755
--- a/share/analysis-scripts/make_template.py
+++ b/share/analysis-scripts/make_template.py
@@ -36,10 +36,6 @@ from subprocess import Popen, PIPE
from pathlib import Path
import function_finder
-MIN_PYTHON = (3, 6) # for glob(recursive) and automatic Path conversions
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
if len(sys.argv) > 2:
print(f"usage: {sys.argv[0]} [dir]")
print(" creates a Frama-C makefile in [dir] (default: .frama-c)")
diff --git a/share/analysis-scripts/make_wrapper.py b/share/analysis-scripts/make_wrapper.py
index 7f9f5b9b517b3be2e1eacdc325dad720ee5eed69..56fb52e0f8c1ce4b1f6937dfc15d6ff9f04f6601 100755
--- a/share/analysis-scripts/make_wrapper.py
+++ b/share/analysis-scripts/make_wrapper.py
@@ -34,10 +34,6 @@ import sys
from functools import partial
import tempfile
-MIN_PYTHON = (3, 6) # for automatic Path conversions
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
# Check if GNU make is available and has the minimal required version
# (4.0). Otherwise, this script will fail.
# We first test with 'gmake', then 'make', then fail.
diff --git a/share/analysis-scripts/normalize_jcdb.py b/share/analysis-scripts/normalize_jcdb.py
index 041baef52d449f8fb0e73d0c39a542ecf481f4c2..70cff41349cc48c7f2d218aea4a42bdee2a5b152 100755
--- a/share/analysis-scripts/normalize_jcdb.py
+++ b/share/analysis-scripts/normalize_jcdb.py
@@ -32,10 +32,6 @@ import json
import re
from pathlib import Path
-MIN_PYTHON = (3, 6) # for automatic Path conversions
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
if len(sys.argv) < 2:
# no argument, assume default name
arg = Path("compile_commands.json")
diff --git a/share/analysis-scripts/print_callgraph.py b/share/analysis-scripts/print_callgraph.py
index 9c5451669dc0955757608d50db117bb2249b7923..54822dd238817f2840a48fb5a3dd82cb69134890 100755
--- a/share/analysis-scripts/print_callgraph.py
+++ b/share/analysis-scripts/print_callgraph.py
@@ -28,10 +28,6 @@
import sys
import build_callgraph
-MIN_PYTHON = (3, 5) # for glob(recursive)
-if sys.version_info < MIN_PYTHON:
- sys.exit("Python %s.%s or later is required.\n" % MIN_PYTHON)
-
dotfile = None
args = sys.argv[1:]
if "--dot" in args:
diff --git a/share/analysis-scripts/source_filter.py b/share/analysis-scripts/source_filter.py
new file mode 100644
index 0000000000000000000000000000000000000000..4156e072aee0fbf7b331d7fe8bbf18b2ae7b1a64
--- /dev/null
+++ b/share/analysis-scripts/source_filter.py
@@ -0,0 +1,90 @@
+#-*- coding: utf-8 -*-
+##########################################################################
+# #
+# This file is part of Frama-C. #
+# #
+# Copyright (C) 2007-2021 #
+# CEA (Commissariat à l'énergie atomique et aux énergies #
+# alternatives) #
+# #
+# you can redistribute it and/or modify it under the terms of the GNU #
+# Lesser General Public License as published by the Free Software #
+# Foundation, version 2.1. #
+# #
+# It is distributed in the hope that it will be useful, #
+# but WITHOUT ANY WARRANTY; without even the implied warranty of #
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
+# GNU Lesser General Public License for more details. #
+# #
+# See the GNU Lesser General Public License version 2.1 #
+# for more details (enclosed in the file licenses/LGPLv2.1). #
+# #
+##########################################################################
+
+# This file provides some functions to open and filter source files
+# before they are used by other scripts. These filters help improve
+# the efficiency of regex-based heuristics.
+
+# These filters require external tools, either in the PATH, or in
+# environment variables (the latter has higher priority than the former).
+# - scc (a fork including option -k), to remove C comments (variable SCC);
+# - astyle, to re-indent lines (variable ASTYLE)
+# If a tool is absent, the filter is equivalent to a no-op.
+
+# These functions receive a file object (such as produced by open(),
+# subprocess.run, or a previous filter) and return a
+# file object containing the output. They abort execution in case
+# of errors when running the filters. Note that an absent tool
+# does _not_ lead to an error.
+
+import os
+from pathlib import Path
+import shutil
+import subprocess
+import sys
+
+# warnings about missing commands are disabled during testing
+emit_warns = os.getenv("PTESTS_TESTING") == None
+
+# Returns a Path to the command binary, or None if it is not found
+# Emits a warning the first time it looks for a command
+warned = {}
+def get_command(command, env_var_name):
+ p = os.getenv(env_var_name)
+ if not p:
+ p = shutil.which(command)
+ if not p:
+ if emit_warns and command not in warned:
+ print(f"info: optional external command '{command}' not found in PATH; consider installing it or setting environment variable {env_var_name}")
+ warned[command] = True
+ return None
+ return Path(p)
+
+def run_and_check(command_and_args, input_data):
+ try:
+ return subprocess.check_output(command_and_args, input=input_data, stderr=None, encoding="ascii", errors="ignore")
+ except subprocess.CalledProcessError as e:
+ sys.exit(f"error running command: {command_and_args}\n{e}")
+
+def filter_with_scc(input_data):
+ scc = get_command("scc", "SCC")
+ if scc:
+ return run_and_check([scc, "-k"], input_data)
+ else:
+ return input_data
+
+def filter_with_astyle(input_data):
+ astyle = get_command("astyle", "ASTYLE")
+ if astyle:
+ return run_and_check([astyle, "--keep-one-line-blocks", "--keep-one-line-statements"], input_data)
+ else:
+ return input_data
+
+def open_and_filter(filename, apply_filters):
+ # we ignore encoding errors and use ASCII to avoid issues when
+ # opening files with different encodings (UTF-8, ISO-8859, etc)
+ with open(filename, "r", encoding="ascii", errors='ignore') as f:
+ data = f.read()
+ if apply_filters:
+ data = filter_with_astyle(filter_with_scc(data))
+ return data
diff --git a/share/compliance/posix_identifiers.json b/share/compliance/posix_identifiers.json
index b4badf4cb0004a8ee1a6cfd547a27f9981c0aac8..a634d328e5650e3490876287f7135090e2451412 100644
--- a/share/compliance/posix_identifiers.json
+++ b/share/compliance/posix_identifiers.json
@@ -2,8 +2,9 @@
"description": "POSIX.1-2008 reserved function identifiers (plus a few legacy POSIX identifiers)",
"source":"POSIX.1-2008 - Base Specifications, Issue 7 (IEEE Std 1003.1-2008, 2016 Edition)",
"notes": {
- "description": "The 'notes' field is a list of characteristics related to CWEs or that may affect the 'difficulty' of analyzing such headers or functions with Frama-C. Each note is succintly described below.",
- "fc-support":"How well Frama-C supports this construct, w.r.t. the C11 standard: 'unsupported', 'none', 'partial', or 'good'. The difference between 'unsupported' and 'none' is that the former means something requiring substantial changes to be supported by Frama-C, while the latter only means 'not tried yet'.",
+ "description": "The 'notes' field is a list of extra data related to the identifier: characteristics related to CWEs; or that may affect the 'difficulty' of analyzing such headers or functions with Frama-C; or disambiguation information. Each note is succintly described below.",
+ "fc-support":"How well Frama-C supports this construct: 'unsupported', 'problematic', 'partial', or 'good'. 'unsupported' means something requiring substantial changes to be supported by Frama-C. 'problematic' indicates an identifier which is known to cause issues to code analyzers, e.g. setjmp.",
+ "types":"For identifiers whose type is 'multiple', this details the actual types.",
"variadic-plugin":"This is a variadic function known by the Variadic plug-in, which can (in some cases) generate a specification for it."
},
"id_types":[
@@ -12,17 +13,18 @@
{"type":"function", "description":"declared as a function; may also be defined as a macro"},
{"type":"macroOrIdentifier", "description":"declaration or definition; unspecified whether it is a macro or an identifier declared with external linkage"},
{"type":"macro", "description":"macro"},
+ {"type":"multiple", "description":"this identifier is used to define more than one object (typically, a function as well as a type); the 'notes' field contains the list 'types'."},
{"type":"pragma", "description":"preprocessing pragma directive"},
{"type":"reserved_name", "description":"name reserved by POSIX"},
{"type":"type", "description":"type or structure"},
{"type":"variable", "description":"external variable"}
],
"headers":{
- "aio.h": {"fc-support":"none", "extensions":[]},
+ "aio.h": {"fc-support":"partial", "extensions":[]},
"arpa/inet.h": {"fc-support":"partial", "extensions":[]},
"assert.h": {"fc-support":"good", "extensions":[]},
"complex.h": {"fc-support":"unsupported", "extensions":[]},
- "cpio.h": {"fc-support":"none", "extensions":[]},
+ "cpio.h": {"fc-support":"good", "extensions":[]},
"ctype.h": {"fc-support":"good", "extensions":[]},
"dirent.h": {"fc-support":"partial", "extensions":[]},
"dlfcn.h": {"fc-support":"partial", "extensions":[]},
@@ -30,7 +32,7 @@
"fcntl.h": {"fc-support":"partial", "extensions":[]},
"fenv.h": {"fc-support":"partial", "extensions":[]},
"float.h": {"fc-support":"partial", "extensions":[]},
- "fmtmsg.h": {"fc-support":"none", "extensions":["XSI"]},
+ "fmtmsg.h": {"fc-support":"partial", "extensions":["XSI"]},
"fnmatch.h": {"fc-support":"partial", "extensions":[]},
"ftw.h": {"fc-support":"partial", "extensions":["XSI"]},
"glob.h": {"fc-support":"partial", "extensions":[]},
@@ -38,14 +40,14 @@
"iconv.h": {"fc-support":"partial", "extensions":[]},
"inttypes.h": {"fc-support":"good", "extensions":[]},
"iso646.h": {"fc-support":"good", "extensions":[]},
- "langinfo.h": {"fc-support":"none", "extensions":[]},
+ "langinfo.h": {"fc-support":"partial", "extensions":[]},
"libgen.h": {"fc-support":"good", "extensions":["XSI"]},
"limits.h": {"fc-support":"good", "extensions":[]},
"locale.h": {"fc-support":"partial", "extensions":[]},
"math.h": {"fc-support":"partial", "extensions":[]},
- "monetary.h": {"fc-support":"none", "extensions":[]},
- "mqueue.h": {"fc-support":"none", "extensions":["MSG"]},
- "ndbm.h": {"fc-support":"none", "extensions":["XSI"]},
+ "monetary.h": {"fc-support":"partial", "extensions":[]},
+ "mqueue.h": {"fc-support":"partial", "extensions":["MSG"]},
+ "ndbm.h": {"fc-support":"partial", "extensions":["XSI"]},
"net/if.h": {"fc-support":"partial", "extensions":[]},
"netdb.h": {"fc-support":"partial", "extensions":[]},
"netinet/in.h": {"fc-support":"partial", "extensions":[]},
@@ -56,11 +58,11 @@
"pwd.h": {"fc-support":"partial", "extensions":[]},
"regex.h": {"fc-support":"partial", "extensions":[]},
"sched.h": {"fc-support":"partial", "extensions":[]},
- "search.h": {"fc-support":"none", "extensions":["XSI"]},
+ "search.h": {"fc-support":"partial", "extensions":["XSI"]},
"semaphore.h": {"fc-support":"partial", "extensions":[]},
- "setjmp.h": {"fc-support":"partial", "extensions":[]},
+ "setjmp.h": {"fc-support":"partial", "extensions":[], "notes":{"fc-support":"problematic"}},
"signal.h": {"fc-support":"partial", "extensions":[]},
- "spawn.h": {"fc-support":"none", "extensions":["SPN"]},
+ "spawn.h": {"fc-support":"partial", "extensions":["SPN"]},
"stdarg.h": {"fc-support":"good", "extensions":[]},
"stdbool.h": {"fc-support":"good", "extensions":[]},
"stddef.h": {"fc-support":"good", "extensions":[]},
@@ -72,14 +74,14 @@
"stropts.h": {"fc-support":"partial", "extensions":["OB", "XSR"]},
"sys/ipc.h": {"fc-support":"partial", "extensions":[]},
"sys/mman.h": {"fc-support":"partial", "extensions":[]},
- "sys/msg.h": {"fc-support":"none", "extensions":[]},
+ "sys/msg.h": {"fc-support":"partial", "extensions":[]},
"sys/resource.h": {"fc-support":"good", "extensions":[]},
"sys/select.h": {"fc-support":"partial", "extensions":[]},
- "sys/sem.h": {"fc-support":"none", "extensions":[]},
+ "sys/sem.h": {"fc-support":"partial", "extensions":[]},
"sys/shm.h": {"fc-support":"partial", "extensions":[]},
"sys/socket.h": {"fc-support":"partial", "extensions":[]},
"sys/stat.h": {"fc-support":"partial", "extensions":[]},
- "sys/statvfs.h": {"fc-support":"none", "extensions":[]},
+ "sys/statvfs.h": {"fc-support":"partial", "extensions":[]},
"sys/time.h": {"fc-support":"partial", "extensions":[]},
"sys/times.h": {"fc-support":"partial", "extensions":[]},
"sys/types.h": {"fc-support":"good", "extensions":[]},
@@ -88,18 +90,18 @@
"sys/utsname.h": {"fc-support":"partial", "extensions":[]},
"sys/wait.h": {"fc-support":"partial", "extensions":[]},
"syslog.h": {"fc-support":"partial", "extensions":["XSI"]},
- "tar.h": {"fc-support":"none", "extensions":[]},
+ "tar.h": {"fc-support":"good", "extensions":[]},
"termios.h": {"fc-support":"partial", "extensions":[]},
"tgmath.h": {"fc-support":"unsupported", "extensions":[]},
"time.h": {"fc-support":"partial", "extensions":[]},
- "trace.h": {"fc-support":"none", "extensions":["OB", "TRC"]},
- "ulimit.h": {"fc-support":"none", "extensions":["OB", "XSI"]},
+ "trace.h": {"fc-support":"partial", "extensions":["OB", "TRC"]},
+ "ulimit.h": {"fc-support":"partial", "extensions":["OB", "XSI"]},
"unistd.h": {"fc-support":"partial", "extensions":[]},
"utime.h": {"fc-support":"partial", "extensions":["OB"]},
"utmpx.h": {"fc-support":"partial", "extensions":["XSI"]},
"wchar.h": {"fc-support":"partial", "extensions":[]},
"wctype.h": {"fc-support":"partial", "extensions":[]},
- "wordexp.h": {"fc-support":"none", "extensions":[]}
+ "wordexp.h": {"fc-support":"partial", "extensions":[]}
},
"extension_names":{
"ADV":"Advisory Information",
@@ -187,7 +189,7 @@
"_IOFBF": {"id_type":"macro", "header":"stdio.h", "extensions":[]},
"_IOLBF": {"id_type":"macro", "header":"stdio.h", "extensions":[]},
"_IONBF": {"id_type":"macro", "header":"stdio.h", "extensions":[]},
- "_longjmp": {"id_type":"function", "header":"setjmp.h", "extensions":["OB","XSI"]},
+ "_longjmp": {"id_type":"function", "header":"setjmp.h", "extensions":["OB","XSI"], "notes":{"fc-support":"problematic"}},
"_PC_2_SYMLINKS": {"id_type":"constant", "header":"unistd.h", "extensions":[]},
"_PC_ALLOC_SIZE_MIN": {"id_type":"constant", "header":"unistd.h", "extensions":[]},
"_PC_ASYNC_IO": {"id_type":"constant", "header":"unistd.h", "extensions":[]},
@@ -468,7 +470,7 @@
"_SC_XOPEN_UUCP": {"id_type":"constant", "header":"unistd.h", "extensions":[]},
"_SC_XOPEN_VERSION": {"id_type":"constant", "header":"unistd.h", "extensions":[]},
"_SC_XOPEN_XCU_VERSION": {"id_type":"constant", "header":"unistd.h", "extensions":["REM"]},
- "_setjmp": {"id_type":"function", "header":"setjmp.h", "extensions":["OB","XSI"]},
+ "_setjmp": {"id_type":"function", "header":"setjmp.h", "extensions":["OB","XSI"], "notes":{"fc-support":"problematic"}},
"_tolower": {"id_type":"function", "header":"ctype.h", "extensions":["OB","XSI"]},
"_toupper": {"id_type":"function", "header":"ctype.h", "extensions":["OB","XSI"]},
"_V6_ILP32_OFF32": {"id_type":"constant", "header":"unistd.h", "extensions":["REM"]},
@@ -1397,7 +1399,6 @@
"h_addrtype": {"id_type":"field", "header":"netdb.h", "extensions":[]},
"h_aliases": {"id_type":"field", "header":"netdb.h", "extensions":[]},
"h_errno": {"id_type":"macroOrIdentifier", "header":"netdb.h", "extensions":["OB","REM"]},
- "h_errno": {"id_type":"variable", "header":"netdb.h", "extensions":["REM"]},
"h_length": {"id_type":"field", "header":"netdb.h", "extensions":[]},
"h_name": {"id_type":"field", "header":"netdb.h", "extensions":[]},
"hcreate": {"id_type":"function", "header":"search.h", "extensions":[]},
@@ -1684,7 +1685,7 @@
"IXON": {"id_type":"constant", "header":"termios.h", "extensions":[]},
"j0": {"id_type":"function", "header":"math.h", "extensions":["XSI"]},
"j1": {"id_type":"function", "header":"math.h", "extensions":["XSI"]},
- "jmp_buf": {"id_type":"type", "header":"setjmp.h", "extensions":[]},
+ "jmp_buf": {"id_type":"type", "header":"setjmp.h", "extensions":[], "notes":{"fc-support":"problematic"}},
"jn": {"id_type":"function", "header":"math.h", "extensions":["XSI"]},
"jrand48": {"id_type":"function", "header":"stdlib.h", "extensions":["XSI"]},
"key_t": {"id_type":"type", "header":"sys/types.h", "extensions":[]},
@@ -1823,7 +1824,7 @@
"LONG_BIT": {"id_type":"macro", "header":"limits.h", "extensions":[]},
"LONG_MAX": {"id_type":"macro", "header":"limits.h", "extensions":[]},
"LONG_MIN": {"id_type":"macro", "header":"limits.h", "extensions":[]},
- "longjmp": {"id_type":"function", "header":"setjmp.h", "extensions":[]},
+ "longjmp": {"id_type":"function", "header":"setjmp.h", "extensions":[], "notes":{"fc-support":"problematic"}},
"lrand48": {"id_type":"function", "header":"stdlib.h", "extensions":["XSI"]},
"lrint": {"id_type":"function", "header":"math.h", "extensions":[]},
"lrintf": {"id_type":"function", "header":"math.h", "extensions":[]},
@@ -2910,7 +2911,7 @@
"setgrent": {"id_type":"function", "header":"grp.h", "extensions":["XSI"]},
"sethostent": {"id_type":"function", "header":"netdb.h", "extensions":[]},
"setitimer": {"id_type":"function", "header":"sys/time.h", "extensions":[]},
- "setjmp": {"id_type":"function", "header":"setjmp.h", "extensions":[]},
+ "setjmp": {"id_type":"function", "header":"setjmp.h", "extensions":[], "notes":{"fc-support":"problematic"}},
"setkey": {"id_type":"function", "header":"stdlib.h", "extensions":["XSI"]},
"setlocale": {"id_type":"function", "header":"locale.h", "extensions":[]},
"setlogmask": {"id_type":"function", "header":"syslog.h", "extensions":[]},
@@ -2981,8 +2982,7 @@
"SIG_SETMASK": {"id_type":"macro", "header":"signal.h", "extensions":[]},
"SIG_UNBLOCK": {"id_type":"macro", "header":"signal.h", "extensions":[]},
"SIGABRT": {"id_type":"macro", "header":"signal.h", "extensions":[]},
- "sigaction": {"id_type":"function", "header":"signal.h", "extensions":[]},
- "sigaction": {"id_type":"type", "header":"signal.h", "extensions":[]},
+ "sigaction": {"id_type":"multiple", "header":"signal.h", "extensions":[], "notes":{"types":["function", "type"]}},
"sigaddset": {"id_type":"function", "header":"signal.h", "extensions":[]},
"SIGALRM": {"id_type":"macro", "header":"signal.h", "extensions":[]},
"sigaltstack": {"id_type":"function", "header":"signal.h", "extensions":[]},
@@ -3010,9 +3010,9 @@
"SIGINT": {"id_type":"macro", "header":"signal.h", "extensions":[]},
"siginterrupt": {"id_type":"function", "header":"signal.h", "extensions":[]},
"sigismember": {"id_type":"function", "header":"signal.h", "extensions":[]},
- "sigjmp_buf": {"id_type":"type", "header":"setjmp.h", "extensions":["CX"]},
+ "sigjmp_buf": {"id_type":"type", "header":"setjmp.h", "extensions":["CX"], "notes":{"fc-support":"problematic"}},
"SIGKILL": {"id_type":"macro", "header":"signal.h", "extensions":[]},
- "siglongjmp": {"id_type":"function", "header":"setjmp.h", "extensions":["CX"]},
+ "siglongjmp": {"id_type":"function", "header":"setjmp.h", "extensions":["CX"], "notes":{"fc-support":"problematic"}},
"sigmask": {"id_type":"function", "header":"signal.h", "extensions":["REM"]},
"signal": {"id_type":"function", "header":"signal.h", "extensions":[]},
"signbit": {"id_type":"macro", "header":"math.h", "extensions":[]},
@@ -3032,7 +3032,7 @@
"SIGSEGV": {"id_type":"macro", "header":"signal.h", "extensions":[]},
"sigset": {"id_type":"function", "header":"signal.h", "extensions":[]},
"sigset_t": {"id_type":"type", "header":"signal.h", "extensions":[]},
- "sigsetjmp": {"id_type":"function", "header":"setjmp.h", "extensions":["CX"]},
+ "sigsetjmp": {"id_type":"function", "header":"setjmp.h", "extensions":["CX"], "notes":{"fc-support":"problematic"}},
"sigstack": {"id_type":"type", "header":"signal.h", "extensions":["REM"]},
"SIGSTKSZ": {"id_type":"macro", "header":"signal.h", "extensions":[]},
"SIGSTOP": {"id_type":"macro", "header":"signal.h", "extensions":[]},
@@ -3147,11 +3147,9 @@
"st_size": {"id_type":"field", "header":"sys/stat.h", "extensions":["SHM", "TYM"]},
"st_uid": {"id_type":"field", "header":"sys/stat.h", "extensions":[]},
"stack_t": {"id_type":"type", "header":"signal.h", "extensions":[]},
- "stat": {"id_type":"function", "header":"sys/stat.h", "extensions":["OB"]},
- "stat": {"id_type":"type", "header":"sys/stat.h", "extensions":["OB"]},
+ "stat": {"id_type":"multiple", "header":"sys/stat.h", "extensions":["OB"], "notes":{"types":["function", "type"]}},
"static_assert": {"id_type":"macro", "header":"assert.h", "extensions":[]},
- "statvfs": {"id_type":"function", "header":"sys/statvfs.h", "extensions":[]},
- "statvfs": {"id_type":"type", "header":"sys/statvfs.h", "extensions":[]},
+ "statvfs": {"id_type":"multiple", "header":"sys/statvfs.h", "extensions":[], "notes":{"types":["function", "type"]}},
"stderr": {"id_type":"macro", "header":"stdio.h", "extensions":[]},
"STDERR_FILENO": {"id_type":"constant", "header":"unistd.h", "extensions":[]},
"stdin": {"id_type":"macro", "header":"stdio.h", "extensions":[]},
diff --git a/share/libc/__fc_libc.h b/share/libc/__fc_libc.h
index 5738cd8f09acd17f1e610c042604768e520382c2..7254946a0f9adfa2b0b3a6b3b10970c1a7e26546 100644
--- a/share/libc/__fc_libc.h
+++ b/share/libc/__fc_libc.h
@@ -27,21 +27,25 @@
#define _POSIX_C_SOURCE 200112L
#define _GNU_SOURCE 1
+#include "aio.h"
#include "alloca.h"
#include "argz.h"
#include "arpa/inet.h"
#include "assert.h"
#include "byteswap.h"
//#include "complex.h"
+#include "cpio.h"
#include "ctype.h"
#include "dirent.h"
#include "dlfcn.h"
#include "endian.h"
+#include "err.h"
#include "errno.h"
#include "fcntl.h"
#include "features.h"
#include "fenv.h"
#include "float.h"
+#include "fmtmsg.h"
#include "fnmatch.h"
#include "ftw.h"
#include "getopt.h"
@@ -58,6 +62,9 @@
#include "malloc.h"
#include "math.h"
#include "memory.h"
+#include "monetary.h"
+#include "mqueue.h"
+#include "ndbm.h"
#include "netdb.h"
#include "net/if.h"
#include "netinet/in.h"
@@ -70,9 +77,11 @@
#include "regex.h"
#include "resolv.h"
#include "sched.h"
+#include "search.h"
#include "semaphore.h"
#include "setjmp.h"
#include "signal.h"
+#include "spawn.h"
#include "stdalign.h"
#include "stdarg.h"
#include "stdatomic.h"
@@ -90,10 +99,12 @@
#include "sys/ipc.h"
#include "syslog.h"
#include "sys/mman.h"
+#include "sys/msg.h"
#include "sys/param.h"
#include "sys/random.h"
#include "sys/resource.h"
#include "sys/select.h"
+#include "sys/sem.h"
#include "sys/sendfile.h"
#include "sys/shm.h"
#include "sys/signal.h"
@@ -109,12 +120,17 @@
#include "sys/utsname.h"
#include "sys/vfs.h"
#include "sys/wait.h"
+#include "tar.h"
#include "termios.h"
//#include "tgmath.h"
#include "time.h"
+#include "trace.h"
+#include "ulimit.h"
#include "unistd.h"
#include "utime.h"
#include "utmp.h"
#include "utmpx.h"
+#include "wait.h"
#include "wchar.h"
#include "wctype.h"
+#include "wordexp.h"
diff --git a/share/libc/aio.h b/share/libc/aio.h
new file mode 100644
index 0000000000000000000000000000000000000000..c3dea2d57cfda7b70e39b9766915d3b71eeff239
--- /dev/null
+++ b/share/libc/aio.h
@@ -0,0 +1,77 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_AIO
+#define __FC_AIO
+#include "features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_off_t.h"
+#include "__fc_define_size_t.h"
+#include "__fc_define_ssize_t.h"
+#include "__fc_define_timespec.h"
+#include "signal.h"
+
+__BEGIN_DECLS
+
+struct aiocb {
+ int aio_fildes;
+ off_t aio_offset;
+ volatile void *aio_buf;
+ size_t aio_nbytes;
+ int aio_reqprio;
+ struct sigevent aio_sigevent;
+ int aio_lio_opcode;
+};
+
+#define AIO_ALLDONE 2
+#define AIO_CANCELED 0
+#define AIO_NOTCANCELED 1
+
+#define LIO_NOP 2
+#define LIO_NOWAIT 1
+
+#define LIO_READ 0
+#define LIO_WAIT 0
+#define LIO_WRITE 1
+
+extern int aio_cancel(int fildes, struct aiocb *aiocbp);
+
+extern int aio_error(const struct aiocb *aiocbp);
+
+extern int aio_fsync(int op, struct aiocb *aiocbp);
+
+extern int aio_read(struct aiocb *aiocbp);
+
+extern ssize_t aio_return(struct aiocb *aiocbp);
+
+extern int aio_suspend(const struct aiocb *const list[], int nent,
+ const struct timespec *timeout);
+
+extern int aio_write(struct aiocb *aiocbp);
+
+extern int lio_listio(int mode, struct aiocb *restrict const list[restrict],
+ int nent, struct sigevent *restrict sig);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/argz.c b/share/libc/argz.c
index 51f5110052118cafdbe34218164f11870299c802..04744ce2435b680d15d105db6877d0e7ae96ce92 100644
--- a/share/libc/argz.c
+++ b/share/libc/argz.c
@@ -60,7 +60,7 @@ static void str_append (char **to, size_t *to_len, const char *buf,
error_t argz_replace (char **argz, size_t *argz_len, const char *str,
const char *with, unsigned *replace_count) {
- error_t err = 0;
+ error_t er = 0;
if (str && *str) {
char *arg = 0;
@@ -71,7 +71,7 @@ error_t argz_replace (char **argz, size_t *argz_len, const char *str,
int delayed_copy = 1;
size_t str_len = strlen (str), with_len = strlen (with);
- while (!err && (arg = argz_next (src, src_len, arg))) {
+ while (!er && (arg = argz_next (src, src_len, arg))) {
char *match = strstr (arg, str);
if (match) {
char *from = match + str_len;
@@ -95,22 +95,22 @@ error_t argz_replace (char **argz, size_t *argz_len, const char *str,
if (to) {
if (delayed_copy) {
if (arg > src)
- err = argz_append (&dst, &dst_len, src, (arg - src));
+ er = argz_append (&dst, &dst_len, src, (arg - src));
delayed_copy = 0;
}
- if (! err)
- err = argz_add (&dst, &dst_len, to);
+ if (! er)
+ er = argz_add (&dst, &dst_len, to);
free (to);
} else
- err = ENOMEM;
+ er = ENOMEM;
if (replace_count)
(*replace_count)++;
} else if (! delayed_copy)
- err = argz_add (&dst, &dst_len, arg);
+ er = argz_add (&dst, &dst_len, arg);
}
- if (! err) {
+ if (! er) {
if (! delayed_copy) {
free (src);
*argz = dst;
@@ -120,7 +120,7 @@ error_t argz_replace (char **argz, size_t *argz_len, const char *str,
free (dst);
}
- return err;
+ return er;
}
char * argz_next (const char *argz, size_t argz_len, const char *entry) {
diff --git a/share/libc/cpio.h b/share/libc/cpio.h
new file mode 100644
index 0000000000000000000000000000000000000000..58e9ed75aa3f04c304c5a4dcc55d53cf1f4855a2
--- /dev/null
+++ b/share/libc/cpio.h
@@ -0,0 +1,47 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_CPIO
+#define __FC_CPIO
+
+#define C_IRUSR 0000400
+#define C_IWUSR 0000200
+#define C_IXUSR 0000100
+#define C_IRGRP 0000040
+#define C_IWGRP 0000020
+#define C_IXGRP 0000010
+#define C_IROTH 0000004
+#define C_IWOTH 0000002
+#define C_IXOTH 0000001
+#define C_ISUID 0004000
+#define C_ISGID 0002000
+#define C_ISVTX 0001000
+#define C_ISDIR 0040000
+#define C_ISFIFO 0010000
+#define C_ISREG 0100000
+#define C_ISBLK 0060000
+#define C_ISCHR 0020000
+#define C_ISCTG 0110000
+#define C_ISLNK 0120000
+#define C_ISSOCK 0140000
+
+#endif
diff --git a/share/libc/err.h b/share/libc/err.h
new file mode 100644
index 0000000000000000000000000000000000000000..e2da20ac48182c5568126ab412a67a9ff4d4e63e
--- /dev/null
+++ b/share/libc/err.h
@@ -0,0 +1,96 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+// Non-POSIX and not in the C ISO standard; this file is defined in the
+// GNU libc.
+
+#ifndef __FC_ERR_H
+#define __FC_ERR_H
+
+#include "features.h"
+__PUSH_FC_STDLIB
+
+#include "__fc_string_axiomatic.h"
+#include "stdarg.h"
+
+__BEGIN_DECLS
+
+// TODO: extend Variadic to handle these functions, or provide C stubs.
+// Currently, given their limited usage and non-standard status, this
+// lightweight approach seems better suited.
+
+/*@
+ requires fmt_valid_read_or_null: valid_read_string(fmt) || fmt == \null;
+ assigns \exit_status \from eval;
+ ensures never_terminates: \false;
+ */
+void err(int eval, const char *fmt, ...);
+
+/*@
+ requires fmt_valid_read_or_null: valid_read_string(fmt) || fmt == \null;
+ assigns \exit_status \from eval;
+ ensures never_terminates: \false;
+ */
+void errx(int eval, const char *fmt, ...);
+
+/*@
+ requires fmt_valid_read_or_null: valid_read_string(fmt) || fmt == \null;
+ assigns \nothing;
+ */
+void warn(const char *fmt, ...);
+
+/*@
+ requires fmt_valid_read_or_null: valid_read_string(fmt) || fmt == \null;
+ assigns \nothing;
+ */
+void warnx(const char *fmt, ...);
+
+/*@
+ requires fmt_valid_read_or_null: valid_read_string(fmt) || fmt == \null;
+ assigns \exit_status \from eval;
+ ensures never_terminates: \false;
+ */
+void verr(int eval, const char *fmt, va_list args);
+
+/*@
+ requires fmt_valid_read_or_null: valid_read_string(fmt) || fmt == \null;
+ assigns \exit_status \from eval;
+ ensures never_terminates: \false;
+ */
+void verrx(int eval, const char *fmt, va_list args);
+
+/*@
+ requires fmt_valid_read_or_null: valid_read_string(fmt) || fmt == \null;
+ assigns \nothing;
+ */
+void vwarn(const char *fmt, va_list args);
+
+/*@
+ requires fmt_valid_read_or_null: valid_read_string(fmt) || fmt == \null;
+ assigns \nothing;
+ */
+void vwarnx(const char *fmt, va_list args);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/fmtmsg.h b/share/libc/fmtmsg.h
new file mode 100644
index 0000000000000000000000000000000000000000..c86e4e7462cc11bf9e3636d277f4cce2addafd20
--- /dev/null
+++ b/share/libc/fmtmsg.h
@@ -0,0 +1,64 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_FMTMSG
+#define __FC_FMTMSG
+#include "features.h"
+__PUSH_FC_STDLIB
+
+__BEGIN_DECLS
+
+#define MM_HARD 0x001
+#define MM_SOFT 0x002
+#define MM_FIRM 0x004
+#define MM_APPL MM_APPL
+#define MM_UTIL 0x010
+#define MM_OPSYS 0x020
+#define MM_RECOVER 0x040
+#define MM_NRECOV 0x080
+#define MM_HALT 1
+#define MM_ERROR 2
+#define MM_WARNING 3
+#define MM_INFO 4
+#define MM_NOSEV 0
+#define MM_PRINT 0x100
+#define MM_CONSOLE 0x200
+
+#define MM_NULLLBL ((char*)0)
+#define MM_NULLSEV 0
+#define MM_NULLMC 0L
+#define MM_NULLTXT ((char*)0)
+#define MM_NULLACT ((char*)0)
+#define MM_NULLTAG ((char*)0)
+
+#define MM_OK 0
+#define MM_NOTOK (-1)
+#define MM_NOMSG 1
+#define MM_NOCON 4
+
+extern int fmtmsg(long classification, const char *label, int severity,
+ const char *text, const char *action, const char *tag);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/limits.h b/share/libc/limits.h
index 7c19508f17883e2954384f61b9d79f6ca228440a..63b64bfdf64f6f74d6c64430befd1f6f07457e11 100644
--- a/share/libc/limits.h
+++ b/share/libc/limits.h
@@ -100,4 +100,70 @@
// 1024 is the value used by some Linux implementations.
#define IOV_MAX 1024
+
+// Maximum Values
+
+#define _POSIX_CLOCKRES_MIN 20000000
+
+// Minimum Values
+
+#define _POSIX_AIO_LISTIO_MAX 2
+#define _POSIX_AIO_MAX 1
+#define _POSIX_ARG_MAX 4096
+#define _POSIX_CHILD_MAX 25
+#define _POSIX_DELAYTIMER_MAX 32
+#define _POSIX_HOST_NAME_MAX 255
+#define _POSIX_LINK_MAX 8
+#define _POSIX_LOGIN_NAME_MAX 9
+#define _POSIX_MAX_CANON 255
+#define _POSIX_MAX_INPUT 255
+#define _POSIX_MQ_OPEN_MAX 8
+#define _POSIX_MQ_PRIO_MAX 32
+#define _POSIX_NAME_MAX 14
+#define _POSIX_NGROUPS_MAX 8
+#define _POSIX_OPEN_MAX 20
+#define _POSIX_PATH_MAX 256
+#define _POSIX_PIPE_BUF 512
+#define _POSIX_RE_DUP_MAX 255
+#define _POSIX_RTSIG_MAX 8
+#define _POSIX_SEM_NSEMS_MAX 256
+#define _POSIX_SEM_VALUE_MAX 32767
+#define _POSIX_SIGQUEUE_MAX 32
+#define _POSIX_SSIZE_MAX 32767
+#define _POSIX_SS_REPL_MAX 4
+#define _POSIX_STREAM_MAX 8
+#define _POSIX_SYMLINK_MAX 255
+#define _POSIX_SYMLOOP_MAX 8
+#define _POSIX_THREAD_DESTRUCTOR_ITERATIONS 4
+#define _POSIX_THREAD_KEYS_MAX 128
+#define _POSIX_THREAD_THREADS_MAX 64
+#define _POSIX_TIMER_MAX 32
+#define _POSIX_TRACE_EVENT_NAME_MAX 30
+#define _POSIX_TRACE_NAME_MAX 8
+#define _POSIX_TRACE_SYS_MAX 8
+#define _POSIX_TRACE_USER_EVENT_MAX 32
+#define _POSIX_TTY_NAME_MAX 9
+#define _POSIX_TZNAME_MAX 6
+#define _POSIX2_BC_BASE_MAX 99
+#define _POSIX2_BC_DIM_MAX 2048
+#define _POSIX2_BC_SCALE_MAX 99
+#define _POSIX2_BC_STRING_MAX 1000
+#define _POSIX2_CHARCLASS_NAME_MAX 14
+#define _POSIX2_COLL_WEIGHTS_MAX 2
+#define _POSIX2_EXPR_NEST_MAX 32
+#define _POSIX2_LINE_MAX 2048
+#define _POSIX2_RE_DUP_MAX 255
+#define _XOPEN_IOV_MAX 16
+#define _XOPEN_NAME_MAX 255
+#define _XOPEN_PATH_MAX 1024
+
+// Other Invariant Values
+
+#define NL_ARGMAX 9
+#define NL_LANGMAX 14
+#define NL_MSGMAX 32767
+#define NL_SETMAX 255
+#define NL_TEXTMAX _POSIX2_LINE_MAX
+#define NZERO 20
+
#endif
diff --git a/share/libc/monetary.h b/share/libc/monetary.h
new file mode 100644
index 0000000000000000000000000000000000000000..3eac861d8c13cd01e380daf61c7e0fe5fc0d6c48
--- /dev/null
+++ b/share/libc/monetary.h
@@ -0,0 +1,42 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_MONETARY
+#define __FC_MONETARY
+#include "features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_locale_t.h"
+#include "__fc_define_size_t.h"
+#include "__fc_define_ssize_t.h"
+
+__BEGIN_DECLS
+
+extern ssize_t strfmon(char *restrict s, size_t maxsize,
+ const char *restrict format, ...);
+
+extern ssize_t strfmon_l(char *restrict s, size_t maxsize, locale_t locale,
+ const char *restrict format, ...);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/mqueue.h b/share/libc/mqueue.h
new file mode 100644
index 0000000000000000000000000000000000000000..58ba20d1e057e4e41f7b5ace4ab08ac7242f001a
--- /dev/null
+++ b/share/libc/mqueue.h
@@ -0,0 +1,71 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_MQUEUE
+#define __FC_MQUEUE
+#include "features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_size_t.h"
+#include "__fc_define_ssize_t.h"
+#include "signal.h"
+
+__BEGIN_DECLS
+
+typedef int mqd_t;
+
+struct mq_attr {
+ long mq_flags;
+ long mq_maxmsg;
+ long mq_msgsize;
+ long mq_curmsgs;
+};
+
+extern int mq_close(mqd_t mqdes);
+
+extern int mq_getattr(mqd_t mqdes, struct mq_attr *mqstat);
+
+extern int mq_notify(mqd_t mqdes, const struct sigevent *notification);
+
+extern mqd_t mq_open(const char *name, int oflag, ...);
+
+extern ssize_t mq_receive(mqd_t mqdes, char *msg_ptr, size_t msg_len,
+ unsigned *msg_prio);
+
+extern int mq_send(mqd_t mqdes, const char *msg_ptr, size_t msg_len,
+ unsigned msg_prio);
+
+extern int mq_setattr(mqd_t mqdes, const struct mq_attr *restrict mqstat,
+ struct mq_attr *restrict omqstat);
+
+extern ssize_t mq_timedreceive(mqd_t mqdes, char *restrict msg_ptr,
+ size_t msg_len, unsigned *restrict msg_prio,
+ const struct timespec *restrict abstime);
+
+extern int mq_timedsend(mqd_t mqdes, const char *msg_ptr, size_t msg_len,
+ unsigned msg_prio, const struct timespec *abstime);
+
+extern int mq_unlink(const char *name);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/ndbm.h b/share/libc/ndbm.h
new file mode 100644
index 0000000000000000000000000000000000000000..2101be1d837a9fde676958aef0b4c6456b6cb325
--- /dev/null
+++ b/share/libc/ndbm.h
@@ -0,0 +1,63 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_NDBM
+#define __FC_NDBM
+#include "features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_mode_t.h"
+#include "__fc_define_size_t.h"
+
+__BEGIN_DECLS
+
+typedef struct __fc_datum {
+ void *dptr;
+ size_t dsize;
+} datum;
+
+typedef int DBM;
+
+#define DBM_INSERT 0
+#define DBM_REPLACE 1
+
+extern int dbm_clearerr(DBM *db);
+
+extern void dbm_close(DBM *db);
+
+extern int dbm_delete(DBM *db, datum key);
+
+extern int dbm_error(DBM *db);
+
+extern datum dbm_fetch(DBM *db, datum key);
+
+extern datum dbm_firstkey(DBM *db);
+
+extern datum dbm_nextkey(DBM *db);
+
+extern DBM *dbm_open(const char *file, int open_flags, mode_t file_mode);
+
+extern int dbm_store(DBM *db, datum key, datum content, int store_mode);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/search.h b/share/libc/search.h
new file mode 100644
index 0000000000000000000000000000000000000000..0fd946fb1e2dbc187ba56c227b4cdd5674132baf
--- /dev/null
+++ b/share/libc/search.h
@@ -0,0 +1,70 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_SEARCH
+#define __FC_SEARCH
+#include "features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_size_t.h"
+
+__BEGIN_DECLS
+
+typedef struct entry {
+ char *key;
+ void *data;
+} ENTRY;
+
+typedef enum { FIND, ENTER } ACTION;
+typedef enum { preorder, postorder, endorder, leaf } VISIT;
+
+extern int hcreate(size_t nel);
+
+extern void hdestroy(void);
+
+extern ENTRY *hsearch(ENTRY item, ACTION action);
+
+extern void insque(void *element, void *pred);
+
+extern void *lfind(const void *key, const void *base, size_t *nelp,
+ size_t width, int (*compar)(const void *, const void *));
+
+extern void *lsearch(const void *key, void *based, size_t *nelp,
+ size_t width, int (*compar)(const void *, const void *));
+
+extern void remque(void *element);
+
+extern void *tdelete(const void *restrict key, void **restrict,
+ int(*compar)(const void *, const void *));
+
+extern void *tfind(const void *key, void *const *rootp,
+ int(*compar)(const void *, const void *));
+
+extern void *tsearch(const void *key, void **rootp,
+ int(*compar)(const void *, const void *));
+
+extern void twalk(const void *root,
+ void (*action)(const void *, VISIT, int ));
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/spawn.h b/share/libc/spawn.h
new file mode 100644
index 0000000000000000000000000000000000000000..6bf386b0839ae9a0741ed1b0cb20daec1cfe165d
--- /dev/null
+++ b/share/libc/spawn.h
@@ -0,0 +1,125 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_SPAWN
+#define __FC_SPAWN
+#include "features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_mode_t.h"
+#include "__fc_define_pid_t.h"
+#include "__fc_define_sigset_t.h"
+
+__BEGIN_DECLS
+
+
+typedef struct __fc_posix_spawnattr_t {
+ int __fc_psa;
+} posix_spawnattr_t;
+
+typedef struct __fc_posix_posix_spawn_file_actions_t {
+ int __fc_psfa;
+} posix_spawn_file_actions_t;
+
+#define POSIX_SPAWN_RESETIDS 0x01
+#define POSIX_SPAWN_SETPGROUP 0x02
+#define POSIX_SPAWN_SETSCHEDPARAM 0x10
+#define POSIX_SPAWN_SETSCHEDULER 0x20
+#define POSIX_SPAWN_SETSIGDEF 0x04
+#define POSIX_SPAWN_SETSIGMASK 0x08
+
+extern int posix_spawn(pid_t *restrict pid, const char *restrict path,
+ const posix_spawn_file_actions_t *file_actions,
+ const posix_spawnattr_t *restrict attrp,
+ char *const *restrict argv,
+ char *const *restrict envp);
+
+extern int posix_spawn_file_actions_addclose(posix_spawn_file_actions_t
+ *file_actions,
+ int fildes);
+
+extern int posix_spawn_file_actions_adddup2(posix_spawn_file_actions_t
+ *file_actions,
+ int fildes, int newfildes);
+
+extern int posix_spawn_file_actions_addopen(posix_spawn_file_actions_t
+ *restrict file_actions,
+ int fildes,
+ const char *restrict path,
+ int oflag, mode_t mode);
+
+extern int posix_spawn_file_actions_destroy(posix_spawn_file_actions_t
+ *file_actions);
+
+extern int posix_spawn_file_actions_init(posix_spawn_file_actions_t
+ *file_actions);
+
+extern int posix_spawnattr_destroy(posix_spawnattr_t *attr);
+
+extern int posix_spawnattr_getflags(const posix_spawnattr_t *restrict attr,
+ short *restrict flags);
+
+extern int posix_spawnattr_getpgroup(const posix_spawnattr_t *restrict attr,
+ pid_t *restrict pgroup);
+
+extern int posix_spawnattr_getschedparam(const posix_spawnattr_t *restrict attr,
+ struct sched_param *restrict
+ schedparam);
+
+extern int posix_spawnattr_getschedpolicy(const posix_spawnattr_t *restrict
+ attr,
+ int *restrict schedpolicy);
+
+extern int posix_spawnattr_getsigdefault(const posix_spawnattr_t *restrict attr,
+ sigset_t *restrict sigdefault);
+
+extern int posix_spawnattr_getsigmask(const posix_spawnattr_t *restrict attr,
+ sigset_t *restrict);
+
+extern int posix_spawnattr_init(posix_spawnattr_t *attr);
+
+extern int posix_spawnattr_setflags(posix_spawnattr_t *attr, short flags);
+
+extern int posix_spawnattr_setpgroup(posix_spawnattr_t *attr, pid_t pgroup);
+
+extern int posix_spawnattr_setschedparam(posix_spawnattr_t *restrict attr,
+ const struct sched_param *restrict
+ schedparam);
+
+extern int posix_spawnattr_setschedpolicy(posix_spawnattr_t *attr,
+ int schedpolicy);
+
+extern int posix_spawnattr_setsigdefault(posix_spawnattr_t *restrict attr,
+ const sigset_t *restrict sigdefault);
+
+extern int posix_spawnattr_setsigmask(posix_spawnattr_t *restrict attr,
+ const sigset_t *restrict sigmask);
+
+extern int posix_spawnp(pid_t *restrict pid, const char *restrict file,
+ const posix_spawn_file_actions_t *file_actions,
+ const posix_spawnattr_t *restrict attrp,
+ char *const *restrict argv,
+ char *const *restrict envp);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/sys/msg.h b/share/libc/sys/msg.h
new file mode 100644
index 0000000000000000000000000000000000000000..5c041a2c3698995b4623508131338acee94a1f15
--- /dev/null
+++ b/share/libc/sys/msg.h
@@ -0,0 +1,63 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_SYS_SHM
+#define __FC_SYS_SHM
+#include "../features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_pid_t.h"
+#include "__fc_define_size_t.h"
+#include "__fc_define_ssize_t.h"
+#include "__fc_define_time_t.h"
+#include "ipc.h"
+
+__BEGIN_DECLS
+
+typedef unsigned long msgqnum_t;
+typedef unsigned long msglen_t;
+
+#define MSG_NOERROR 010000
+
+struct msqid_ds {
+ struct ipc_perm msg_perm;
+ msgqnum_t msg_qnum;
+ msglen_t msg_qbytes;
+ pid_t msg_lspid;
+ pid_t msg_lrpid;
+ time_t msg_stime;
+ time_t msg_rtime;
+ time_t msg_ctime;
+};
+
+extern int msgctl(int msqid, int cmd, struct msqid_ds *buf);
+
+extern int msgget(key_t key, int msgflg);
+
+extern ssize_t msgrcv(int msgid, void *msgp, size_t msgsz, long msgtyp,
+ int msgflg);
+
+extern int msgsnd(int msqid, const void *msgp, size_t msgsz, int msgflg);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/sys/sem.h b/share/libc/sys/sem.h
new file mode 100644
index 0000000000000000000000000000000000000000..1db55fc6e4a7203b526372c826bfca4577134c77
--- /dev/null
+++ b/share/libc/sys/sem.h
@@ -0,0 +1,75 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_SYS_SEM
+#define __FC_SYS_SEM
+#include "../features.h"
+__PUSH_FC_STDLIB
+#include "../__fc_define_pid_t.h"
+#include "../__fc_define_size_t.h"
+#include "../__fc_define_time_t.h"
+#include "ipc.h"
+
+__BEGIN_DECLS
+
+#define SEM_UNDO 0x1000
+
+#define GETNCNT 14
+#define GETPID 11
+#define GETVAL 12
+#define GETALL 13
+#define GETZCNT 15
+#define SETVAL 16
+#define SETALL 17
+
+struct semid_ds {
+ struct ipc_perm sem_perm;
+ unsigned short sem_nsems;
+ time_t sem_otime;
+ time_t sem_ctime;
+};
+
+// POSIX 2018 states: "a semaphore shall be represented by an anonymous
+// structure, which shall include the following members".
+struct __fc_sem {
+ unsigned short semval;
+ pid_t sempid;
+ unsigned short semncnt;
+ unsigned short semzcnt;
+};
+
+struct sembuf {
+ unsigned short sem_num;
+ short sem_op;
+ short sem_flg;
+};
+
+extern int semctl(int semid, int semnum, int cmd, ...);
+
+extern int semget(key_t key, int nsems, int semflg);
+
+extern int semop(int semid, struct sembuf *sops, size_t nsops);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/tar.h b/share/libc/tar.h
new file mode 100644
index 0000000000000000000000000000000000000000..4155eaa94eeee31ca45fd339329dd1fa6a7d2bf3
--- /dev/null
+++ b/share/libc/tar.h
@@ -0,0 +1,54 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_TAR
+#define __FC_TAR
+
+#define TMAGIC "ustar"
+#define TMAGLEN 6
+#define TVERSION "00"
+#define TVERSLEN 2
+
+#define REGTYPE '0'
+#define AREGTYPE '\0'
+#define LNKTYPE '1'
+#define SYMTYPE '2'
+#define CHRTYPE '3'
+#define BLKTYPE '4'
+#define DIRTYPE '5'
+#define FIFOTYPE '6'
+#define CONTTYPE '7'
+
+#define TSUID 04000
+#define TSGID 02000
+#define TSVTX 01000
+#define TUREAD 00400
+#define TUWRITE 00200
+#define TUEXEC 00100
+#define TGREAD 00040
+#define TGWRITE 00020
+#define TGEXEC 00010
+#define TOREAD 00004
+#define TOWRITE 00002
+#define TOEXEC 00001
+
+#endif
diff --git a/share/libc/trace.h b/share/libc/trace.h
new file mode 100644
index 0000000000000000000000000000000000000000..afda99838a5719712c1e720df3aaba731e40b3ba
--- /dev/null
+++ b/share/libc/trace.h
@@ -0,0 +1,239 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_TRACE
+#define __FC_TRACE
+#include "features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_pid_t.h"
+#include "__fc_define_pthread_types.h"
+#include "__fc_define_size_t.h"
+#include "__fc_define_timespec.h"
+
+__BEGIN_DECLS
+
+typedef unsigned int trace_event_id_t;
+
+typedef unsigned int trace_id_t;
+
+typedef struct __fc_trace_attr_t {
+ int _fc ;
+} trace_attr_t;
+
+typedef struct __fc_trace_event_set_t {
+ int _fc ;
+} trace_event_set_t;
+
+struct posix_trace_event_info {
+ trace_event_id_t posix_event_id;
+ pid_t posix_pid;
+ void *posix_prog_address;
+ pthread_t posix_thread_id;
+ struct timespec posix_timestamp;
+ int posix_truncation_status;
+};
+
+struct posix_trace_status_info {
+ int posix_stream_full_status;
+ int posix_stream_overrun_status;
+ int posix_stream_status;
+ int posix_log_full_status;
+ int posix_log_overrun_status;
+ int posix_stream_flush_error;
+ int posix_stream_flush_status;
+};
+
+// Note: the constants below are not defined in most Linux systems,
+// so arbitrary values were chosen.
+
+#define POSIX_TRACE_ALL_EVENTS 1
+
+#define POSIX_TRACE_APPEND 2
+
+#define POSIX_TRACE_CLOSE_FOR_CHILD 3
+
+#define POSIX_TRACE_FILTER 4
+
+#define POSIX_TRACE_FLUSH 5
+#define POSIX_TRACE_FLUSH_START 6
+#define POSIX_TRACE_FLUSH_STOP 7
+#define POSIX_TRACE_FLUSHING 8
+
+#define POSIX_TRACE_FULL 9
+#define POSIX_TRACE_LOOP 10
+#define POSIX_TRACE_NO_OVERRUN 11
+
+#define POSIX_TRACE_NOT_FLUSHING 12
+
+#define POSIX_TRACE_NOT_FULL 13
+
+#define POSIX_TRACE_INHERITED 14
+
+#define POSIX_TRACE_NOT_TRUNCATED 15
+#define POSIX_TRACE_OVERFLOW 16
+#define POSIX_TRACE_OVERRUN 17
+#define POSIX_TRACE_RESUME 18
+#define POSIX_TRACE_RUNNING 19
+#define POSIX_TRACE_START 20
+#define POSIX_TRACE_STOP 21
+#define POSIX_TRACE_SUSPENDED 22
+#define POSIX_TRACE_SYSTEM_EVENTS 23
+#define POSIX_TRACE_TRUNCATED_READ 24
+#define POSIX_TRACE_TRUNCATED_RECORD 25
+#define POSIX_TRACE_UNNAMED_USER_EVENT 26
+#define POSIX_TRACE_UNTIL_FULL 27
+#define POSIX_TRACE_WOPID_EVENTS 28
+
+extern int posix_trace_attr_destroy(trace_attr_t *);
+
+extern int posix_trace_attr_getclockres(const trace_attr_t *,
+ struct timespec *);
+
+extern int posix_trace_attr_getcreatetime(const trace_attr_t *,
+ struct timespec *);
+
+extern int posix_trace_attr_getgenversion(const trace_attr_t *, char *);
+
+extern int posix_trace_attr_getinherited(const trace_attr_t *restrict,
+ int *restrict);
+
+extern int posix_trace_attr_getlogfullpolicy(const trace_attr_t *restrict,
+ int *restrict);
+
+extern int posix_trace_attr_getlogsize(const trace_attr_t *restrict,
+ size_t *restrict);
+
+extern int posix_trace_attr_getmaxdatasize(const trace_attr_t *restrict,
+ size_t *restrict);
+
+extern int posix_trace_attr_getmaxsystemeventsize(const trace_attr_t *restrict,
+ size_t *restrict);
+
+extern int posix_trace_attr_getmaxusereventsize(const trace_attr_t *restrict,
+ size_t, size_t *restrict);
+
+extern int posix_trace_attr_getname(const trace_attr_t *, char *);
+
+extern int posix_trace_attr_getstreamfullpolicy(const trace_attr_t *restrict,
+ int *restrict);
+
+extern int posix_trace_attr_getstreamsize(const trace_attr_t *restrict,
+ size_t *restrict);
+
+extern int posix_trace_attr_init(trace_attr_t *);
+
+extern int posix_trace_attr_setinherited(trace_attr_t *, int);
+
+extern int posix_trace_attr_setlogfullpolicy(trace_attr_t *, int);
+
+extern int posix_trace_attr_setlogsize(trace_attr_t *, size_t);
+
+extern int posix_trace_attr_setmaxdatasize(trace_attr_t *, size_t);
+
+extern int posix_trace_attr_setname(trace_attr_t *, const char *);
+
+extern int posix_trace_attr_setstreamfullpolicy(trace_attr_t *, int);
+
+extern int posix_trace_attr_setstreamsize(trace_attr_t *, size_t);
+
+extern int posix_trace_clear(trace_id_t);
+
+extern int posix_trace_close(trace_id_t);
+
+extern int posix_trace_create(pid_t, const trace_attr_t *restrict,
+ trace_id_t *restrict);
+
+extern int posix_trace_create_withlog(pid_t, const trace_attr_t *restrict,
+ int, trace_id_t *restrict);
+
+extern void posix_trace_event(trace_event_id_t, const void *restrict, size_t);
+
+extern int posix_trace_eventid_equal(trace_id_t, trace_event_id_t,
+ trace_event_id_t);
+
+extern int posix_trace_eventid_get_name(trace_id_t, trace_event_id_t, char *);
+
+extern int posix_trace_eventid_open(const char *restrict,
+ trace_event_id_t *restrict);
+
+extern int posix_trace_eventset_add(trace_event_id_t, trace_event_set_t *);
+
+extern int posix_trace_eventset_del(trace_event_id_t, trace_event_set_t *);
+
+extern int posix_trace_eventset_empty(trace_event_set_t *);
+
+extern int posix_trace_eventset_fill(trace_event_set_t *, int);
+
+extern int posix_trace_eventset_ismember(trace_event_id_t,
+ const trace_event_set_t *restrict,
+ int *restrict);
+
+extern int posix_trace_eventtypelist_getnext_id(trace_id_t,
+ trace_event_id_t *restrict,
+ int *restrict);
+
+int posix_trace_eventtypelist_rewind(trace_id_t);
+
+extern int posix_trace_flush(trace_id_t);
+
+extern int posix_trace_get_attr(trace_id_t, trace_attr_t *);
+
+extern int posix_trace_get_filter(trace_id_t, trace_event_set_t *);
+
+extern int posix_trace_get_status(trace_id_t,
+ struct posix_trace_status_info *);
+
+extern int posix_trace_getnext_event(trace_id_t,
+ struct posix_trace_event_info *restrict,
+ void *restrict, size_t, size_t *restrict,
+ int *restrict);
+
+extern int posix_trace_open(int, trace_id_t *);
+
+extern int posix_trace_rewind(trace_id_t);
+
+extern int posix_trace_set_filter(trace_id_t, const trace_event_set_t *, int);
+
+extern int posix_trace_shutdown(trace_id_t);
+
+extern int posix_trace_start(trace_id_t);
+
+extern int posix_trace_stop(trace_id_t);
+
+extern int posix_trace_timedgetnext_event(trace_id_t,
+ struct posix_trace_event_info
+ *restrict, void *restrict, size_t,
+ size_t *restrict, int *restrict,
+ const struct timespec *restrict);
+
+extern int posix_trace_trid_eventid_open(trace_id_t, const char *restrict,
+ trace_event_id_t *restrict);
+
+extern int posix_trace_trygetnext_event(trace_id_t,
+ struct posix_trace_event_info
+ *restrict, void *restrict, size_t,
+ size_t *restrict, int *restrict);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/ulimit.h b/share/libc/ulimit.h
new file mode 100644
index 0000000000000000000000000000000000000000..e182a681a5d99c2cc29fb4bb5d0ce4fdbb78207d
--- /dev/null
+++ b/share/libc/ulimit.h
@@ -0,0 +1,38 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_ULIMIT
+#define __FC_ULIMIT
+#include "features.h"
+__PUSH_FC_STDLIB
+
+__BEGIN_DECLS
+
+#define UL_GETFSIZE 1
+#define UL_SETFSIZE 2
+
+extern long ulimit(int cmd, ...);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/share/libc/wait.h b/share/libc/wait.h
new file mode 100644
index 0000000000000000000000000000000000000000..669242ae82a2039978b44d7c8bb8d37688c795aa
--- /dev/null
+++ b/share/libc/wait.h
@@ -0,0 +1,25 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+// This file is neither in the C standard nor is POSIX;
+// it exists for compatibility purposes
+#include "sys/wait.h"
diff --git a/share/libc/wordexp.h b/share/libc/wordexp.h
new file mode 100644
index 0000000000000000000000000000000000000000..5a1439aedb672809384d75d982d14760aeddb58d
--- /dev/null
+++ b/share/libc/wordexp.h
@@ -0,0 +1,58 @@
+/**************************************************************************/
+/* */
+/* This file is part of Frama-C. */
+/* */
+/* Copyright (C) 2007-2021 */
+/* CEA (Commissariat à l'énergie atomique et aux énergies */
+/* alternatives) */
+/* */
+/* you can redistribute it and/or modify it under the terms of the GNU */
+/* Lesser General Public License as published by the Free Software */
+/* Foundation, version 2.1. */
+/* */
+/* It is distributed in the hope that it will be useful, */
+/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
+/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
+/* GNU Lesser General Public License for more details. */
+/* */
+/* See the GNU Lesser General Public License version 2.1 */
+/* for more details (enclosed in the file licenses/LGPLv2.1). */
+/* */
+/**************************************************************************/
+
+#ifndef __FC_WORDEXP
+#define __FC_WORDEXP
+#include "features.h"
+__PUSH_FC_STDLIB
+#include "__fc_define_size_t.h"
+
+__BEGIN_DECLS
+
+typedef struct __fc_wordexp_t {
+ size_t we_wordc;
+ char **we_wordv;
+ size_t we_offs;
+} wordexp_t;
+
+#define WRDE_DOOFFS (1 << 0)
+#define WRDE_APPEND (1 << 1)
+#define WRDE_NOCMD (1 << 2)
+#define WRDE_REUSE (1 << 3)
+#define WRDE_SHOWERR (1 << 4)
+#define WRDE_UNDEF (1 << 5)
+
+#define WRDE_NOSPACE 1
+#define WRDE_BADCHAR 2
+#define WRDE_BADVAL 3
+#define WRDE_CMDSUB 4
+#define WRDE_SYNTAX 5
+
+extern int wordexp(const char *restrict words, wordexp_t *restrict pwordexp,
+ int flags);
+
+extern void wordfree(wordexp_t *pwordexp);
+
+__END_DECLS
+
+__POP_FC_STDLIB
+#endif
diff --git a/src/kernel_internals/parsing/logic_lexer.mll b/src/kernel_internals/parsing/logic_lexer.mll
index 044cf5f450289b8bdbb8b30ca552da416397558c..6a73eae995e2013ed87e6509821403728bd6d297 100644
--- a/src/kernel_internals/parsing/logic_lexer.mll
+++ b/src/kernel_internals/parsing/logic_lexer.mll
@@ -283,7 +283,7 @@
end
(* Update lexer buffer. *)
- let update_line_loc lexbuf line =
+ let update_line_pos lexbuf line =
let pos = lexbuf.Lexing.lex_curr_p in
lexbuf.Lexing.lex_curr_p <-
{ pos with
@@ -291,10 +291,7 @@
Lexing.pos_bol = pos.Lexing.pos_cnum;
}
- let update_newline_loc lexbuf =
- update_line_loc lexbuf (lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum + 1)
-
- let update_file_loc lexbuf file =
+ let update_file_pos lexbuf file =
let pos = lexbuf.Lexing.lex_curr_p in
lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_fname = file }
@@ -349,8 +346,8 @@ let utf8_char = ['\128'-'\254']+
rule token = parse
| space+ { token lexbuf }
- | '\n' { update_newline_loc lexbuf; token lexbuf }
- | comment_line '\n' { update_newline_loc lexbuf; token lexbuf }
+ | '\n' { Lexing.new_line lexbuf; token lexbuf }
+ | comment_line '\n' { Lexing.new_line lexbuf; token lexbuf }
| comment_line eof { token lexbuf }
| "*/" { lex_error lexbuf "unexpected block-comment closing" }
| "/*" { if !accept_c_comments_into_acsl_spec
@@ -502,7 +499,7 @@ and chr buffer = parse
| _ { Buffer.add_string buffer (lexeme lexbuf); chr buffer lexbuf }
and hash = parse
- '\n' { update_newline_loc lexbuf; token lexbuf}
+ '\n' { Lexing.new_line lexbuf; token lexbuf}
| [' ''\t'] { hash lexbuf}
| rD+ { (* We are seeing a line number. This is the number for the
* next line *)
@@ -517,14 +514,14 @@ and hash = parse
"Bad line number in preprocessed file: %s" s;
(-1)
in
- update_line_loc lexbuf (lineno - 1);
+ update_line_pos lexbuf (lineno - 1);
(* A file name may follow *)
file lexbuf }
| "line" { hash lexbuf } (* MSVC line number info *)
| _ { endline lexbuf}
and file = parse
- '\n' { update_newline_loc lexbuf; token lexbuf}
+ '\n' { Lexing.new_line lexbuf; token lexbuf}
| [' ''\t''\r'] { file lexbuf}
| '"' ([^ '\012' '\t' '"']|"\\\"")* '"' {
let n = Lexing.lexeme lexbuf in
@@ -532,38 +529,36 @@ and file = parse
((String.length n) - 2) in
let unescape = Str.regexp_string "\\\"" in
let n1 = Str.global_replace unescape "\"" n1 in
- update_file_loc lexbuf n1;
+ update_file_pos lexbuf n1;
endline lexbuf
}
| _ { endline lexbuf}
and endline = parse
- '\n' { update_newline_loc lexbuf; token lexbuf}
+ '\n' { Lexing.new_line lexbuf; token lexbuf}
| eof { EOF }
| _ { endline lexbuf}
and comment = parse
- '\n' { update_newline_loc lexbuf; comment lexbuf}
+ '\n' { Lexing.new_line lexbuf; comment lexbuf}
| "*/" { token lexbuf}
| eof { lex_error lexbuf "non-terminating block-comment" }
| _ { comment lexbuf}
{
- let set_initial_location dest_lexbuf src_loc =
- Lexing.(
- dest_lexbuf.lex_curr_p <-
- { src_loc with
- pos_bol = src_loc.pos_bol - src_loc.pos_cnum;
- pos_cnum = 0; };
- )
-
- let parse_from_location f (loc, s : Filepath.position * string) =
+ (* When Ocaml 4.11+ becomes mandatory, we can probably replace this with
+ Lexing.set_position. *)
+ let set_initial_position dest_lexbuf src_pos =
+ dest_lexbuf.Lexing.lex_curr_p <- src_pos;
+ dest_lexbuf.lex_abs_pos <- src_pos.pos_cnum
+
+ let parse_from_position f (pos, s : Filepath.position * string) =
let finally _ = Logic_utils.exit_kw_c_mode () in
let output = Kernel.logwith finally ~wkey:Kernel.wkey_annot_error
in
let lb = from_string s in
- set_initial_location lb (Cil_datatype.Position.to_lexing_pos loc);
+ set_initial_position lb (Cil_datatype.Position.to_lexing_pos pos);
try
let res = f token lb in
Some (Cil_datatype.Position.of_lexing_pos lb.Lexing.lex_curr_p, res)
@@ -584,11 +579,11 @@ and comment = parse
Kernel.fatal ~source:(Cil_datatype.Position.of_lexing_pos lb.lex_curr_p) "Unknown error (%s)"
(Printexc.to_string exn)
- let lexpr = parse_from_location Logic_parser.lexpr_eof
+ let lexpr = parse_from_position Logic_parser.lexpr_eof
- let annot = parse_from_location Logic_parser.annot
+ let annot = parse_from_position Logic_parser.annot
- let spec = parse_from_location Logic_parser.spec
+ let spec = parse_from_position Logic_parser.spec
let ext_spec lexbuf = try
accept_c_comments_into_acsl_spec := true ;
diff --git a/src/kernel_internals/typing/cabs2cil.ml b/src/kernel_internals/typing/cabs2cil.ml
index f958082d4b04d4d907094cd9ea3fefcb985d5284..3b2e601d3e9c442cae2a372fe53fa3ea888a3332 100644
--- a/src/kernel_internals/typing/cabs2cil.ml
+++ b/src/kernel_internals/typing/cabs2cil.ml
@@ -59,7 +59,36 @@ let valid_sid = false
open Cil_types
open Cil_datatype
-let stripUnderscore s =
+(* Maps the start and end positions of a function declaration or definition
+ (including its possible contract) to its name. *)
+module FuncLocs = struct
+ include
+ State_builder.List_ref
+ (Datatype.Triple
+ (Cil_datatype.Position)(Cil_datatype.Position)(Datatype.String)
+ )
+ (struct
+ let name = "FuncLocs"
+ let dependencies = [ Kernel.Files.self ]
+ end)
+
+ let add_loc ?spec loc1 loc2 funcname =
+ let startpos =
+ match spec with
+ | None -> fst loc1
+ | Some (_, spec_loc) -> fst spec_loc
+ in
+ let endpos = snd loc2 in
+ add (startpos, endpos, funcname)
+end
+
+let func_locs () = FuncLocs.get ()
+
+(* Attributes which are entirely unsupported by Frama-C and must cause a
+ parsing error, since their behavior requires non-standard parsing *)
+let unsupported_attributes = ["vector_size"]
+
+let stripUnderscore ?(checkUnsupported=true) s =
if String.length s = 1 then begin
if s = "_" then
Kernel.error ~once:true ~current:true "Invalid attribute name %s" s;
@@ -68,6 +97,8 @@ let stripUnderscore s =
let res = Extlib.strip_underscore s in
if res = "" then
Kernel.error ~once:true ~current:true "Invalid attribute name %s" s;
+ if checkUnsupported && List.mem res unsupported_attributes then
+ Kernel.error ~current:true "unsupported attribute: %s" s;
res
end
@@ -4100,7 +4131,6 @@ let continueUsed () =
| [] -> Kernel.fatal ~current:true "not in a loop"
| (While lr | NotWhile lr) :: _ -> !lr <> ""
-
(****** TYPE SPECIFIERS *******)
(* JS: return [Some s] if the attribute string is the attribute annotation [s]
@@ -8613,12 +8643,14 @@ and createGlobal ghost logic_spec ((t,s,b,attr_list) : (typ * storage * bool * C
List.exists (fun (_,el) -> List.exists is_fc_stdlib el) a
in
(* Make a first version of the varinfo *)
+ let vi_loc = convLoc cloc in
let vi = makeVarInfoCabs ~ghost ~isformal:false ~referenced:islibc
- ~isglobal:true ~isgenerated (convLoc cloc) (t,s,b,attr_list) (n,ndt,a)
+ ~isglobal:true ~isgenerated vi_loc (t,s,b,attr_list) (n,ndt,a)
in
(* Add the variable to the environment before doing the initializer
* because it might refer to the variable itself *)
if isFunctionType vi.vtype then begin
+ FuncLocs.add_loc ?spec:logic_spec (CurrentLoc.get ()) vi_loc n;
if inite != Cabs.NO_INIT then
Kernel.error ~once:true ~current:true
"Function declaration with initializer (%s)\n" vi.vname;
@@ -9240,6 +9272,7 @@ and doDecl local_env (isglobal: bool) : Cabs.definition -> chunk = function
Kernel.debug ~dkey:Kernel.dkey_typing_global
"Definition of %s at %a\n" n Cil_printer.pp_location idloc;
CurrentLoc.set idloc;
+ FuncLocs.add_loc ?spec loc1 endloc n;
IH.clear callTempVars;
(* Make the fundec right away, and we'll populate it later. We
diff --git a/src/kernel_internals/typing/cabs2cil.mli b/src/kernel_internals/typing/cabs2cil.mli
index 44ea2ddf74785720d77ef8af20e9510925f8866b..f15e3a97b31a45f205d88aad2d1c1a375f4b208a 100644
--- a/src/kernel_internals/typing/cabs2cil.mli
+++ b/src/kernel_internals/typing/cabs2cil.mli
@@ -280,6 +280,22 @@ val stmtFallsThrough: Cil_types.stmt -> bool
val fieldsToInit: Cil_types.compinfo -> string option -> Cil_types.offset list
+(**
+ Returns a mapping (pos_start, pos_end, funcname) for each function
+ declaration and definition, spanning the entire function, including
+ its specification (if it has one).
+
+ Currently, for function declarations, the location ends at the function
+ name, before the formal parameter list. For definitions, it spans until the
+ closing brace.
+
+ Note that the list is _not_ sorted, and must be further processed
+ for efficient data retrieval.
+
+ @since Frama-C+dev
+*)
+val func_locs : unit -> (Filepath.position * Filepath.position * string) list
+
(*
Local Variables:
compile-command: "make -C ../../.."
diff --git a/src/kernel_services/ast_queries/cil_datatype.ml b/src/kernel_services/ast_queries/cil_datatype.ml
index ee6d4ef5573f305005e6e8ca321218f73bf56986..ef12ae7e9f1918b0e6d6f610be9b26642b78176d 100644
--- a/src/kernel_services/ast_queries/cil_datatype.ml
+++ b/src/kernel_services/ast_queries/cil_datatype.ml
@@ -206,6 +206,10 @@ module Position = struct
let pp_with_col fmt pos =
Format.fprintf fmt "%a char %d" pretty pos
(pos.Filepath.pos_cnum - pos.Filepath.pos_bol)
+ let pretty_debug fmt pos =
+ Format.fprintf fmt "%a:%d:%d"
+ Datatype.Filepath.pretty pos.Filepath.pos_path
+ pos.Filepath.pos_lnum pos.Filepath.pos_cnum
end
module Location = struct
@@ -242,11 +246,8 @@ module Location = struct
Format.fprintf fmt "generated"
let pretty_debug fmt loc =
- Format.fprintf fmt "(%a:%d:%d,%a:%d:%d)"
- Datatype.Filepath.pretty (fst loc).Filepath.pos_path
- (fst loc).Filepath.pos_lnum (fst loc).Filepath.pos_cnum
- Datatype.Filepath.pretty (snd loc).Filepath.pos_path
- (snd loc).Filepath.pos_lnum (snd loc).Filepath.pos_cnum
+ Format.fprintf fmt "(%a,%a)"
+ Position.pretty_debug (fst loc) Position.pretty_debug (snd loc)
let of_lexing_loc (pos1, pos2) =
Position.of_lexing_pos pos1, Position.of_lexing_pos pos2
diff --git a/src/kernel_services/ast_queries/cil_datatype.mli b/src/kernel_services/ast_queries/cil_datatype.mli
index df5138305b7a051784a19e7f9c6e893383ac0648..f1064f288f97e0a6192087f5def008d9a4ea80ca 100644
--- a/src/kernel_services/ast_queries/cil_datatype.mli
+++ b/src/kernel_services/ast_queries/cil_datatype.mli
@@ -58,6 +58,11 @@ module Position: sig
val pp_with_col : Format.formatter -> t -> unit
val of_lexing_pos : Lexing.position -> t
val to_lexing_pos : t -> Lexing.position
+
+ (** Pretty-print file, line and character offset.
+ @since Frama-C+dev
+ *)
+ val pretty_debug: t Pretty_utils.formatter
end
(** Cil locations. *)
diff --git a/src/kernel_services/plugin_entry_points/db.ml b/src/kernel_services/plugin_entry_points/db.ml
index b63abe98dc97998803b7e77f354a53aebedc043d..950e5d6150e13b42abbec2f706b23014a59104b7 100644
--- a/src/kernel_services/plugin_entry_points/db.ml
+++ b/src/kernel_services/plugin_entry_points/db.ml
@@ -266,14 +266,10 @@ module Value = struct
let globals_use_supplied_state () = not (VGlobals.get_option () = None)
- (* Do NOT add dependencies to Kernel parameters here, but at the top of
- Value/Value_parameters *)
- let dependencies =
- [ Ast.self;
- Alarms.self;
- Annotations.code_annot_state;
- FunArgs.self;
- VGlobals.self ]
+ let dependencies = [ FunArgs.self; VGlobals.self ]
+ let proxy = State_builder.Proxy.(create "eva_db" Forward dependencies)
+ let self = State_builder.Proxy.get proxy
+ let only_self = [ self ]
let size = 256
@@ -285,14 +281,14 @@ module Value = struct
(struct
let name = "Db.Value.Table_By_Callstack"
let size = size
- let dependencies = dependencies
+ let dependencies = [ self ]
end)
module Table =
Cil_state_builder.Stmt_hashtbl(Cvalue.Model)
(struct
let name = "Db.Value.Table"
let size = size
- let dependencies = [ Table_By_Callstack.self ]
+ let dependencies = [ self ]
end)
(* Clear Value's various caches each time [Db.Value.is_computed] is updated,
including when it is set, reset, or during project change. Some operations
@@ -308,26 +304,21 @@ module Value = struct
Function_Froms.Memory.clear_caches ();
)
-
module AfterTable_By_Callstack =
Cil_state_builder.Stmt_hashtbl(States_by_callstack)
(struct
let name = "Db.Value.AfterTable_By_Callstack"
let size = size
- let dependencies = [ Table_By_Callstack.self ]
+ let dependencies = [ self ]
end)
module AfterTable =
Cil_state_builder.Stmt_hashtbl(Cvalue.Model)
(struct
let name = "Db.Value.AfterTable"
let size = size
- let dependencies = [ AfterTable_By_Callstack.self ]
+ let dependencies = [ self ]
end)
-
- let self = Table_By_Callstack.self
- let only_self = [ self ]
-
let mark_as_computed =
Journal.register "Db.Value.mark_as_computed"
(Datatype.func Datatype.unit Datatype.unit)
diff --git a/src/kernel_services/plugin_entry_points/db.mli b/src/kernel_services/plugin_entry_points/db.mli
index 636ec1d8bd5a8f8b59f10256faf861772fc4edd7..d944d48b1542b56f9ba69055785a45640203ab1a 100644
--- a/src/kernel_services/plugin_entry_points/db.mli
+++ b/src/kernel_services/plugin_entry_points/db.mli
@@ -129,6 +129,8 @@ module Value : sig
val emitter: Emitter.t ref
(** Emitter used by Value to emit statuses *)
+ val proxy: State_builder.Proxy.t
+
val self : State.t
(** Internal state of the value analysis from projects viewpoint.
@plugin development guide *)
diff --git a/src/plugins/aorai/aorai_eva_analysis.enabled.ml b/src/plugins/aorai/aorai_eva_analysis.enabled.ml
index 8b007c55b15b021ba234a5d76899eb55587c0967..d4bb1d87ba568da2b4e8b1c373cd6520622be0c7 100644
--- a/src/plugins/aorai/aorai_eva_analysis.enabled.ml
+++ b/src/plugins/aorai/aorai_eva_analysis.enabled.ml
@@ -25,7 +25,7 @@
let show_aorai_variable state fmt var_name =
let vi = Data_for_aorai.(get_varinfo var_name) in
- let cvalue = !Db.Value.eval_expr state (Cil.evar vi) in
+ let cvalue = Cvalue.Model.find state (Locations.loc_of_varinfo vi) in
try
let i = Ival.project_int (Cvalue.V.project_ival cvalue) in
let state_name = Data_for_aorai.getStateName (Integer.to_int_exn i) in
@@ -80,7 +80,7 @@ let add_slevel_annotations () =
let add_partitioning varname =
match Data_for_aorai.get_varinfo_option varname with
| None -> ()
- | Some vi -> Eva.Value_parameters.use_global_value_partitioning vi
+ | Some vi -> Eva.Parameters.use_global_value_partitioning vi
let add_state_variables_partitioning () =
add_partitioning Data_for_aorai.curState;
diff --git a/src/plugins/callgraph/cg.ml b/src/plugins/callgraph/cg.ml
index 8781cee00fb4eb8b00afeb2abcd53697894cdcc5..091419156608e56ece6f04cbb0f4c78293d90eb8 100644
--- a/src/plugins/callgraph/cg.ml
+++ b/src/plugins/callgraph/cg.ml
@@ -63,7 +63,7 @@ module State =
(D)
(struct
let name = "Callgraph.Cg"
- let dependencies = [ Db.Value.self; Globals.Functions.self ]
+ let dependencies = [ Eva.Analysis.self; Globals.Functions.self ]
end)
let self = State.self
@@ -228,10 +228,10 @@ let compute () =
(* optimize with [Value] when either it is already computed or someone
requires it anyway *)
if Dynamic.Parameter.Bool.get "-eva" () then begin
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
semantic_compute g
end else
- (if Db.Value.is_computed () then semantic_compute else syntactic_compute) g;
+ (if Eva.Analysis.is_computed () then semantic_compute else syntactic_compute) g;
g
let get () = State.memo compute
diff --git a/src/plugins/constant_propagation/api.ml b/src/plugins/constant_propagation/api.ml
index 569d5d24e3aeb69d3dbbf390330390aecc1c60da..be5eb41d5d1c6f1f542cf27a213372c95b6037d5 100644
--- a/src/plugins/constant_propagation/api.ml
+++ b/src/plugins/constant_propagation/api.ml
@@ -131,11 +131,11 @@ class propagate project fnames ~cast_intro = object(self)
| TEnum _) -> ()
| _ -> raise Cannot_expand
end;
- let ki = match self#current_stmt with
+ let stmt = match self#current_stmt with
| None -> raise Cannot_change
- | Some s -> Kstmt s
+ | Some s -> s
in
- let evaled = !Db.Value.access_expr ki expr in
+ let evaled = Eva.Results.(before stmt |> eval_exp expr |> as_cvalue) in
let b, m = Cvalue.V.find_lonely_binding evaled in
let can_replace vi =
(* can replace the current expr by [vi] iff (1) it is a source var, or
@@ -340,7 +340,7 @@ module Result =
let size = 7
let name = "Semantical constant propagation"
let dependencies =
- [ Db.Value.self;
+ [ Eva.Analysis.self;
PropagationParameters.CastIntro.self;
PropagationParameters.Project_name.self ]
end)
@@ -352,7 +352,7 @@ let journalized_get =
let get fnames cast_intro =
Result.memo
(fun _ ->
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
let fresh_project =
FC_file.create_project_from_visitor
(PropagationParameters.Project_name.get ())
diff --git a/src/plugins/dive/build.ml b/src/plugins/dive/build.ml
index 6a08979f28db393ec3fcb6024a20c670f6a89241..b694d6d85ecb58b9256b6e05dcbf66547377dfa3 100644
--- a/src/plugins/dive/build.ml
+++ b/src/plugins/dive/build.ml
@@ -27,7 +27,6 @@ module Graph = Dive_graph
let dkey = Self.register_category "build"
-
(* --- Utility function --- *)
(* Breaks a list at n-th element into two sublists *)
@@ -76,29 +75,24 @@ end
module Eval =
struct
- let to_kf_list kinstr expr =
- let _,set = !Db.Value.expr_to_kernel_function kinstr ~deps:None expr in
- Kernel_function.Hptset.fold (fun kf acc -> kf :: acc) set []
+ open Eva.Results
+
+ let to_kf_list kinstr callee =
+ before_kinstr kinstr |> eval_callee callee |>
+ Result.value ~default:[]
let to_cvalue kinstr lval =
- let state = Db.Value.get_state kinstr in
- let _,cvalue = !Db.Value.eval_lval None state lval in
- cvalue
+ before_kinstr kinstr |> eval_lval lval |> as_cvalue
let to_location kinstr lval =
- let state = Db.Value.get_state kinstr in
- !Db.Value.lval_to_loc_state state lval
+ before_kinstr kinstr |> eval_address lval |> as_location |>
+ Result.value ~default:Locations.loc_bottom
let to_zone kinstr lval =
- !Db.Value.lval_to_zone kinstr lval
+ before_kinstr kinstr |> eval_address lval |> as_zone
let to_callstacks stmt =
- let states = Db.Value.get_stmt_state_callstack ~after:false stmt in
- match states with
- | None -> assert false
- | Some table ->
- let module Table = Value_types.Callstack.Hashtbl in
- Table.fold (fun cs _ acc -> cs :: acc) table []
+ before stmt |> callstacks
let studia_is_direct (_,{Studia.Writes.direct}) = direct
diff --git a/src/plugins/dive/context.ml b/src/plugins/dive/context.ml
index 3b91fbdf9ea2bbd5eb459079d421414f051f59c7..5dc407e377dc58dbfb24efb86459aa1fb28db5a1 100644
--- a/src/plugins/dive/context.ml
+++ b/src/plugins/dive/context.ml
@@ -51,7 +51,7 @@ type t = {
(* --- initialization --- *)
let create () =
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
{
graph = Graph.create ();
vertex_table = Index.create 13;
diff --git a/src/plugins/dive/server_interface.ml b/src/plugins/dive/server_interface.ml
index 93e389396dc826aae8771fb83ef57878bb4d635a..999e07549497bb37b4bf985f2d81397f58f9ba81 100644
--- a/src/plugins/dive/server_interface.ml
+++ b/src/plugins/dive/server_interface.ml
@@ -38,7 +38,7 @@ let get_context =
match !context with
| Some c -> c
| None ->
- if Db.Value.is_computed () then
+ if Eva.Analysis.is_computed () then
let c = Context.create () in
context := Some c;
c
diff --git a/src/plugins/e-acsl/examples/ensuresec/.gitignore b/src/plugins/e-acsl/examples/ensuresec/.gitignore
new file mode 100644
index 0000000000000000000000000000000000000000..567609b1234a9b8806c5a05da6c866e480aa148d
--- /dev/null
+++ b/src/plugins/e-acsl/examples/ensuresec/.gitignore
@@ -0,0 +1 @@
+build/
diff --git a/src/plugins/e-acsl/examples/ensuresec/Makefile b/src/plugins/e-acsl/examples/ensuresec/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..b60655a15f460b7785aade35fcee74c0ef119e16
--- /dev/null
+++ b/src/plugins/e-acsl/examples/ensuresec/Makefile
@@ -0,0 +1,37 @@
+OUT:=$(dir $(abspath $(lastword $(MAKEFILE_LIST))))build
+DEPS:=Makefile ensuresec_ee.c json_assert.c
+EACSL_CC:=e-acsl-gcc.sh -c --concurrency --external-assert json_assert.c ensuresec_ee.c
+MKDIR:=mkdir -p
+
+EE_ID:=EnsuresecEE
+EE_TOOL_ID:=EnsuresecEE_EACSL
+
+$(OUT)/ensuresec_ee.e-acsl: $(DEPS)
+ $(MKDIR) $(OUT)
+ $(EACSL_CC) -o $(OUT)/ensuresec_ee.frama.c -O $(OUT)/ensuresec_ee
+
+$(OUT)/ensuresec_ee_pall.e-acsl: $(DEPS)
+ $(MKDIR) $(OUT)
+ $(EACSL_CC) -e -DE_ACSL_DEBUG_ASSERT -o $(OUT)/ensuresec_ee_pall.frama.c -O $(OUT)/ensuresec_ee_pall
+
+$(OUT)/ensuresec_ee_debug.e-acsl: $(DEPS)
+ $(MKDIR) $(OUT)
+ $(EACSL_CC) -e -DE_ACSL_DEBUG_ASSERT --rt-debug -o $(OUT)/ensuresec_ee_debug.frama.c -O $(OUT)/ensuresec_ee_debug
+
+compile: $(OUT)/ensuresec_ee.e-acsl
+compile_print_all: $(OUT)/ensuresec_ee_pall.e-acsl
+compile_debug: $(OUT)/ensuresec_ee_debug.e-acsl
+
+run: $(OUT)/ensuresec_ee.e-acsl
+ ENSURESEC_EE_ID="$(EE_ID)" ENSURESEC_EE_TOOL_ID="$(EE_TOOL_ID)" ENSURESEC_OUTPUT_FILE="$(OUT)/ensuresec_ee.json" $(OUT)/ensuresec_ee.e-acsl
+
+run_print_all: $(OUT)/ensuresec_ee_pall.e-acsl
+ ENSURESEC_EE_ID="$(EE_ID)" ENSURESEC_EE_TOOL_ID="$(EE_TOOL_ID)" ENSURESEC_OUTPUT_FILE="$(OUT)/ensuresec_ee_pall.json" $(OUT)/ensuresec_ee_pall.e-acsl
+
+run_debug: $(OUT)/ensuresec_ee_debug.e-acsl
+ ENSURESEC_EE_ID="$(EE_ID)" ENSURESEC_EE_TOOL_ID="$(EE_TOOL_ID)" ENSURESEC_OUTPUT_FILE="$(OUT)/ensuresec_ee_debug.json" $(OUT)/ensuresec_ee_debug.e-acsl
+
+all: run run_print_all run_debug
+
+clean:
+ rm -rf $(OUT)
diff --git a/src/plugins/e-acsl/examples/ensuresec/README.md b/src/plugins/e-acsl/examples/ensuresec/README.md
new file mode 100644
index 0000000000000000000000000000000000000000..8192e73e7fb379db2c224eacebbb0dc0dce17d3f
--- /dev/null
+++ b/src/plugins/e-acsl/examples/ensuresec/README.md
@@ -0,0 +1,38 @@
+# Ensuresec
+
+This folder illustrates the developments done for the European H2020 project
+Ensuresec.
+
+## Files
+
+### `Makefile`
+
+The makefile in the folder provides some targets to test the ensuresec
+developments:
+
+- `compile` (default): Compile `ensuresec_ee.c` with the external assert
+ implementation in `json_assert.c`.
+- `compile_print_all`: Same as `compile` but every assertion (valid or invalid)
+ will be printed to the output.
+- `compile_debug`: Same as `compile_print_all` but in debug mode.
+- `run`: run the output of the `compile` step.
+- `run_print_all`: run the output of the `compile_print_all` step.
+- `run_debug`: run the output of the `compile_debug` step.
+
+### `json_assert.c`
+
+The file `json_assert.c` contains an external `__e_acsl_assert()` implementation
+that will print assertion violations to a json file.
+
+The following environment variables must be defined when using this
+implementation:
+
+- `ENSURESEC_EE_ID`: Ensuresec e-commerce ecosystem id
+- `ENSURESEC_EE_TOOL_ID`: Ensuresec e-commerce ecosystem tool id
+- `ENSURESEC_OUTPUT_FILE`: json output file
+
+### `ensuresec_ee.c`
+
+Multithread program serving as an exemple Ensuresec e-commerce ecosystem
+program. The program contains `check` assertions that will be violated during
+its execution without halting the program.
diff --git a/src/plugins/e-acsl/examples/ensuresec/ensuresec_ee.c b/src/plugins/e-acsl/examples/ensuresec/ensuresec_ee.c
new file mode 100644
index 0000000000000000000000000000000000000000..310c49c1c6cad0df52d8a1f26deee6c2b4abad93
--- /dev/null
+++ b/src/plugins/e-acsl/examples/ensuresec/ensuresec_ee.c
@@ -0,0 +1,139 @@
+// Get default definitions and macros, e.g. pthread_rwlock_t
+#ifndef _DEFAULT_SOURCE
+# define _DEFAULT_SOURCE 1
+#endif
+
+#include <assert.h>
+#include <errno.h>
+#include <pthread.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+
+// Number of writers and readers created
+#define SIZE 10
+
+// Mutex protecting the calls to `rand()`
+static pthread_mutex_t rand_mutex;
+
+// Data array
+static int *values[SIZE];
+
+// Synchronization array: if `written[idx] == 1` then `values[idx]` has been written to.
+static int written[SIZE] = {0};
+
+// Read-write lock protecting the accesses to `written`
+static pthread_rwlock_t locks[SIZE];
+
+// Thread-safe version of `rand()` that returns a random value between `min`
+// and `max`.
+/*@ requires 0 <= min < max <= RAND_MAX;
+ @ ensures min <= \result <= max; */
+static int ensuresec_rand(int min, int max) {
+ pthread_mutex_lock(&rand_mutex);
+ int value = rand();
+ pthread_mutex_unlock(&rand_mutex);
+ return (double)value * (max - min) / RAND_MAX + min;
+}
+
+/*@ requires \let idx = *(int*)arg; 0 <= idx < SIZE; */
+static void *write_value(void *arg) {
+ int idx = *(int *)arg;
+ pthread_rwlock_t *lock = &locks[idx];
+
+ // Acquire a read lock so that the specification can check `writte[idx]` and
+ // `values[idx]`.
+ pthread_rwlock_rdlock(lock);
+
+ /*@ requires written[idx] == 0;
+ @ ensures written[idx] == 1;
+ @ ensures \valid_read(values[idx]) && \initialized(values[idx]); */
+ {
+ // Long computation
+ int duration = ensuresec_rand(1, 5);
+ sleep(duration);
+
+ // No data race since each thread will access its own index and
+ // `read_value()` will not read this index until we update `written[idx]`.
+ values[idx] = malloc(sizeof(int));
+ *values[idx] = idx + duration;
+
+ // Now we want to update `written[idx]` so we need to acquire the lock for
+ // this index in writing mode
+ pthread_rwlock_unlock(lock);
+ pthread_rwlock_wrlock(lock);
+ written[idx] = 1;
+ }
+
+ pthread_rwlock_unlock(lock);
+ return NULL;
+}
+
+/*@ requires \let idx = *(int*)arg; 0 <= idx < SIZE; */
+static void *read_value(void *arg) {
+ int idx = *(int *)arg;
+ pthread_rwlock_t *lock = &locks[idx];
+
+ // Long computation
+ int duration = ensuresec_rand(0, 3);
+ sleep(duration);
+
+ // Check `written[idx]` while the value is 0
+ int idx_written;
+ do {
+ pthread_rwlock_rdlock(lock);
+ idx_written = written[idx];
+ // Unlock and sleep a bit between each check to let `write_value()` some
+ // time to change the value of `written[idx]`
+ pthread_rwlock_unlock(lock);
+ usleep(100);
+ } while (!idx_written);
+
+ // Acquire a read lock so that the specification can check `writte[idx]` and
+ // `values[idx]`.
+ pthread_rwlock_rdlock(lock);
+ /*@ requires written[idx] == 1;
+ @ requires \valid_read(values[idx]) && \initialized(values[idx]); */
+ {
+ int value = *values[idx];
+ free(values[idx]);
+
+ // Non-critical assertion that will sometimes fail and raise an alert
+ //@ check (value - idx) > duration;
+ }
+ pthread_rwlock_unlock(lock);
+
+ return NULL;
+}
+
+int main() {
+ pthread_t writers[SIZE];
+ pthread_t readers[SIZE];
+ int args[SIZE];
+
+ // Initialize rand seed
+ srand(time(NULL));
+
+ // Initialize locks
+ int res = pthread_mutex_init(&rand_mutex, NULL);
+ assert(res == 0);
+ for (int i = 0; i < SIZE; ++i) {
+ res = pthread_rwlock_init(&locks[i], NULL);
+ assert(res == 0);
+ }
+
+ // Create all threads
+ for (int i = 0; i < SIZE; ++i) {
+ args[i] = i;
+ pthread_create(&writers[i], NULL, write_value, &args[i]);
+ pthread_create(&readers[i], NULL, read_value, &args[i]);
+ }
+
+ // Wait for completion
+ for (int i = 0; i < SIZE; ++i) {
+ pthread_join(writers[i], NULL);
+ pthread_join(readers[i], NULL);
+ }
+
+ return 0;
+}
diff --git a/src/plugins/e-acsl/examples/ensuresec/json_assert.c b/src/plugins/e-acsl/examples/ensuresec/json_assert.c
new file mode 100644
index 0000000000000000000000000000000000000000..95ce2721c8a3316ee7a865c1526c770789e9a2eb
--- /dev/null
+++ b/src/plugins/e-acsl/examples/ensuresec/json_assert.c
@@ -0,0 +1,296 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+#include <unistd.h>
+#ifdef E_ACSL_CONCURRENCY_PTHREAD
+# include <pthread.h>
+#endif
+
+#include <e_acsl.h>
+
+extern int __e_acsl_sound_verdict;
+
+/*! Print to `output` the unicode string `str` as a json string, meaning all
+ unicode characters from `\x00` to `\x1f` are escaped, along with newlines,
+ tabulations, `"` and some others. */
+void json_print_escaped_str(FILE *output, const char *str) {
+ for (char *c = (char *)&str[0]; *c != '\0'; ++c) {
+ switch (*c) {
+ case '"':
+ fprintf(output, "%s", "\\\"");
+ break;
+ case '\\':
+ fprintf(output, "%s", "\\\\");
+ break;
+ case '\b':
+ fprintf(output, "%s", "\\b");
+ break;
+ case '\f':
+ fprintf(output, "%s", "\\f");
+ break;
+ case '\n':
+ fprintf(output, "%s", "\\n");
+ break;
+ case '\r':
+ fprintf(output, "%s", "\\r");
+ break;
+ case '\t':
+ fprintf(output, "%s", "\\t");
+ break;
+ default:
+ if ('\x00' <= *c && *c <= '\x1f') {
+ fprintf(output, "\\u%04x", (unsigned int)*c);
+ } else {
+ fprintf(output, "%c", *c);
+ }
+ }
+ }
+}
+
+/*! Print the given value to `output` as a json object. */
+void json_print_value(FILE *output, __e_acsl_assert_data_value_t *value) {
+ fprintf(output, " { \"name\": \"");
+ json_print_escaped_str(output, value->name);
+ fprintf(output, "\", \"value\": \"");
+ eacsl_print_value_content(output, value);
+ fprintf(output, "\" }");
+}
+
+#ifdef E_ACSL_CONCURRENCY_PTHREAD
+/*! Global lock for accessing the output json file. */
+static pthread_mutex_t ensuresec_mutex = PTHREAD_MUTEX_INITIALIZER;
+# define ENSURESEC_LOCK() pthread_mutex_lock(&ensuresec_mutex)
+# define ENSURESEC_UNLOCK() pthread_mutex_unlock(&ensuresec_mutex)
+#else
+# define ENSURESEC_LOCK() \
+ do { \
+ } while (0)
+# define ENSURESEC_UNLOCK() \
+ do { \
+ } while (0)
+#endif
+
+/*! Assert macro to output `msg` to `stderr` if `pred` is false. The output does
+ not allocate. */
+#define ENSURESEC_ASSERT(pred, msg) \
+ do { \
+ if (!(pred)) { \
+ const char m[] = msg; \
+ write(STDERR_FILENO, m, sizeof(m) - 1); \
+ abort(); \
+ } \
+ } while (0)
+
+/*! Json output file. */
+static FILE *ensuresec_output_file;
+/*! String to use for Ensuresec e-commerce ecosystem id (EE id) field. */
+static const char *ensuresec_ee_id;
+/*! String to use for Ensuresec e-commerce ecosystem tool id (EE tool id) field. */
+static const char *ensuresec_ee_tool_id;
+
+/*! \brief Finalize ensuresec output.
+
+ - Print the closing bracket of the json array.
+ - Flush the output. */
+void ensuresec_clean_assert() {
+ fprintf(ensuresec_output_file, "]\n");
+ int result = fflush(ensuresec_output_file);
+ ENSURESEC_ASSERT(result == 0, "Unable to flush ENSURESEC_OUTPUT_FILE\n");
+
+ // Purposefully do not close the json ouptut file: on normal termination, this
+ // function will be called after the return in `main()` and the shadow
+ // memories of E-ACSL will already be destroyed, resulting in a segmentation
+ // fault.
+ // The OS will automatically close the file descriptor and reclaim allocated
+ // memory on program termination.
+}
+
+/*! \brief Initialize ensuresec output.
+
+ - Retrieve the EE id and EE tool id from the environment variables
+ `ENSURESEC_EE_ID` and `ENSURESEC_EE_TOOL_ID`.
+ - Retrieve the path to the json output file from the environment variable
+ `ENSURESEC_OUTPUT_FILE`.
+ - Open the json output file.
+ - Print an opening bracket for a json array.
+ - Register the cleaning function to be called on normal program termination.
+*/
+void ensuresec_init_assert() {
+ ensuresec_ee_id = getenv("ENSURESEC_EE_ID");
+ ENSURESEC_ASSERT(ensuresec_ee_id != NULL,
+ "Unable to retrieve env var ENSURESEC_EE_ID\n");
+
+ ensuresec_ee_tool_id = getenv("ENSURESEC_EE_TOOL_ID");
+ ENSURESEC_ASSERT(ensuresec_ee_tool_id != NULL,
+ "Unable to retrieve env var ENSURESEC_EE_TOOL_ID\n");
+
+ const char *filename = getenv("ENSURESEC_OUTPUT_FILE");
+ ENSURESEC_ASSERT(filename != NULL,
+ "Unable to retrieve env var ENSURESEC_OUTPUT_FILE\n");
+ if (strcmp(filename, "-") == 0) {
+ ensuresec_output_file = stdout;
+ } else {
+ ensuresec_output_file = fopen(filename, "w");
+ }
+ ENSURESEC_ASSERT(ensuresec_output_file != NULL,
+ "Unable to open ENSURESEC_OUTPUT_FILE\n");
+
+ fprintf(ensuresec_output_file, "[\n");
+
+ // The function ensuresec_clean_assert will be called on normal program
+ // termination (via exit() or returning from main())
+ atexit(ensuresec_clean_assert);
+}
+
+/*! \brief __e_acsl_assert override to print output in a json file. */
+void __e_acsl_assert(int predicate, __e_acsl_assert_data_t *data) {
+ // Initialize output file only once per program execution
+#ifdef E_ACSL_CONCURRENCY_PTHREAD
+ static pthread_once_t already_run = PTHREAD_ONCE_INIT;
+ int result = pthread_once(&already_run, ensuresec_init_assert);
+ ENSURESEC_ASSERT(result == 0, "Unable to initialize __e_acsl_assert\n");
+#else
+ static int already_run = 0;
+ if (!already_run) {
+ ensuresec_init_assert();
+ already_run = 1;
+ }
+#endif
+
+#ifndef E_ACSL_DEBUG_ASSERT
+ if (!__e_acsl_sound_verdict || !predicate)
+#endif
+ {
+ ENSURESEC_LOCK();
+ // Id of the alert
+ static size_t alert_id = 0;
+
+ // We just want a smaller var for clearer source code
+ FILE *o = ensuresec_output_file;
+
+ // If this is not the first alert, we need to add a comma between the
+ // previous json object and the one we will print now
+ if (alert_id > 0) {
+ fprintf(o, ",\n");
+ }
+
+ // Start printing the alert
+ fprintf(o, "{\n");
+ fprintf(o, " \"version\": \"1.0\",\n");
+ fprintf(o, " \"partner\": \"CEA\",\n");
+ fprintf(o, " \"id\": \"CEA/Frama-C\",\n");
+ fprintf(o, " \"alert\": {\n");
+ fprintf(o, " \"id\": \"%d\",\n", alert_id++);
+ fprintf(o, " \"type\": \"%s/%s\",\n", data->kind,
+ data->name ? data->name : "");
+
+ // Print current time as an ISO8601 date
+ time_t t = time(NULL);
+ char timebuf[32]; // Enough space to print an ISO8601 date
+ strftime(timebuf, sizeof(timebuf), "%FT%T", gmtime(&t));
+ fprintf(o, " \"startTS\": \"%s\",\n", timebuf);
+ fprintf(o, " \"endTS\": \"%s\",\n", timebuf);
+
+ fprintf(o, " \"eCommerceEcoId\": \"%s\",\n", ensuresec_ee_id);
+
+ // Infer the severity of the alert from its kind:
+ // - RTE index out of bound or memory access: HIGH
+ // - Other RTE: MEDIUM
+ // - Assertions from the Frama-C libc: MEDIUM
+ // - User assertions: LOW
+ static const char *severities[] = {"LOW", "MEDIUM", "HIGH"};
+ int severity_idx = 0;
+ if (strcmp(data->kind, "RTE") == 0) {
+ if (strcmp(data->name, "index_bound") == 0
+ || strcmp(data->name, "mem_access") == 0) {
+ severity_idx = 2;
+ } else {
+ severity_idx = 1;
+ }
+ } else if (strstr(data->file, "FRAMAC_SHARE/libc") != NULL) {
+ severity_idx = 1;
+ }
+
+ fprintf(o, " \"severity\": \"%s\",\n", severities[severity_idx]);
+
+ fprintf(o, " \"EE_Element\": [{\n");
+ fprintf(o, " \"id\": \"%s:%d\",\n", data->file, data->line);
+ fprintf(o, " \"elementType\": \"EEAsset\",\n");
+ fprintf(o, " \"assetType\": \"cyber/CSourceFile\"\n");
+ fprintf(o, " }],\n");
+
+ fprintf(o, " \"detector\": {\n");
+ fprintf(o, " \"type\": \"cyber/RuntimeVerification\",\n");
+ fprintf(o, " \"providerId\": \"CEA\",\n");
+ fprintf(o, " \"sourceId\": \"%s\"\n", ensuresec_ee_tool_id);
+ fprintf(o, " },\n");
+ fprintf(o, " \"data\": [{\n");
+ fprintf(o, " \"contentType\": \"JsonData\",\n");
+ fprintf(o, " \"type\": \"AssertionData\",\n");
+ fprintf(o, " \"startTS\": \"%s\",\n", timebuf);
+ fprintf(o, " \"endTS\": \"%s\",\n", timebuf);
+ fprintf(o, " \"creationTS\": \"%s\",\n", timebuf);
+ fprintf(o, " \"dataSource\": {\n");
+ fprintf(o, " \"dataSourceType\": \"Detector\",\n");
+ fprintf(o, " \"type\": \"cyber/RuntimeVerification\",\n");
+ fprintf(o, " \"providerId\": \"CEA\",\n");
+ fprintf(o, " \"sourceId\": \"%s\"\n", ensuresec_ee_tool_id);
+ fprintf(o, " },\n");
+
+ // Details of the assertion
+ fprintf(o, " \"jsonContent\": {\n");
+ // Kind of verdict
+ fprintf(o, " \"verdict\": \"%s%s%s\",\n",
+ __e_acsl_sound_verdict ? "" : "unsound ",
+ predicate ? "valid" : "invalid",
+ data->blocking ? "" : " (non-blocking)");
+ // Kind and name of the assertion
+ fprintf(o, " \"kind\": \"%s\",\n", data->kind);
+ fprintf(o, " \"name\": \"%s\",\n", data->name ? data->name : "");
+ // Content of the predicate
+ fprintf(o, " \"predicate\": \"");
+ json_print_escaped_str(o, data->pred_txt);
+ fprintf(o, "\",\n");
+ // Location in the source code
+ fprintf(o, " \"location\": {\n");
+ fprintf(o, " \"file\": \"%s\",\n", data->file);
+ fprintf(o, " \"line\": \"%d\",\n", data->line);
+ fprintf(o, " \"function\": \"%s\"\n", data->fct);
+ fprintf(o, " },\n");
+ // Values of the assertion
+ fprintf(o, " \"values\": [\n");
+ __e_acsl_assert_data_value_t *value = data->values;
+ while (value != NULL) {
+ json_print_value(o, value);
+ value = value->next;
+ if (value) {
+ fprintf(o, ",\n");
+ } else {
+ fprintf(o, "\n");
+ }
+ }
+ fprintf(o, " ]\n");
+ fprintf(o, " }\n");
+
+ // Close the alert
+ fprintf(o, " }]\n");
+ fprintf(o, " }\n");
+ fprintf(o, "}\n");
+ fflush(o);
+
+ if (data->blocking && __e_acsl_sound_verdict && !predicate) {
+#ifndef E_ACSL_NO_ASSERT_FAIL
+# ifdef E_ACSL_FAIL_EXITCODE
+ exit(E_ACSL_FAIL_EXITCODE);
+# else
+ // If we are aborting then we need to manually call the cleanup function
+ ensuresec_clean_assert();
+ abort();
+# endif
+#endif
+ }
+
+ ENSURESEC_UNLOCK();
+ }
+}
diff --git a/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert.c b/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert.c
index 0d1158d3b7bf95f8f254905f500a2ec0ae883bd5..03338d3f3e01e0012a5da1a02055009d0d0cae43 100644
--- a/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert.c
+++ b/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert.c
@@ -45,185 +45,188 @@ void eacsl_print_values(eacsl_assert_data_t *data) {
}
}
-#ifndef E_ACSL_EXTERNAL_ASSERT
-/*! \brief Default implementation of E-ACSL runtime assertions */
-void eacsl_runtime_assert(int predicate, eacsl_assert_data_t *data) {
- if (eacsl_runtime_sound_verdict) {
- if (!predicate) {
- RTL_IO_LOCK();
- // clang-format off
- STDERR("%s: In function '%s'\n"
- "%s:%d: Error: %s failed:\n"
- "\tThe failing predicate is:\n"
- "\t%s.\n",
- data->file, data->fct,
- data->file, data->line, data->kind,
- data->pred_txt);
- // clang-format on
- eacsl_print_values(data);
- RTL_IO_UNLOCK();
- if (data->blocking) {
-# ifndef E_ACSL_NO_ASSERT_FAIL /* Do fail on assertions */
-# ifdef E_ACSL_FAIL_EXITCODE /* Fail by exit with a given code */
- exit(E_ACSL_FAIL_EXITCODE);
-# else
- raise_abort(data->file, data->line); /* Raise abort signal */
-# endif
-# endif
- }
- }
-# ifdef E_ACSL_DEBUG_ASSERT
- else {
- RTL_IO_LOCK();
- // clang-format off
- STDERR("%s: In function '%s'\n"
- "%s:%d: %s valid:\n"
- "\t%s.\n",
- data->file, data->fct,
- data->file, data->line, data->kind,
- data->pred_txt);
- // clang-format on
- eacsl_print_values(data);
- RTL_IO_UNLOCK();
- }
-# endif
- } else {
- RTL_IO_LOCK();
- // clang-format off
- STDERR("%s: In function '%s'\n"
- "%s:%d: Warning: no sound verdict for %s (guess: %s).\n"
- "\tthe considered predicate is:\n"
- "\t%s\n",
- data->file, data->fct,
- data->file, data->line, data->kind, predicate ? "ok" : "FAIL",
- data->pred_txt);
- // clang-format on
- eacsl_print_values(data);
- RTL_IO_UNLOCK();
- }
-}
-#endif
-
-#ifndef E_ACSL_EXTERNAL_PRINT_VALUE
-void eacsl_print_int_content(const char *name,
+/*! Print the given integer to `stream` */
+void eacsl_print_int_content(FILE *stream,
eacsl_assert_data_int_content_t *int_content) {
+ if (int_content->is_enum) {
+ fprintf(stream, "<enum> ");
+ }
switch (int_content->kind) {
case E_ACSL_IBOOL:
- fprintf(stderr, "\t- %s: %s%d\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_bool);
+ fprintf(stream, "%d", int_content->value.value_bool);
break;
case E_ACSL_ICHAR:
- fprintf(stderr, "\t- %s: %s%d\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_char);
+ fprintf(stream, "%d", int_content->value.value_char);
break;
case E_ACSL_ISCHAR:
- fprintf(stderr, "\t- %s: %s%hhd\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_schar);
+ fprintf(stream, "%hhd", int_content->value.value_schar);
break;
case E_ACSL_IUCHAR:
- fprintf(stderr, "\t- %s: %s%hhu\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_uchar);
+ fprintf(stream, "%hhu", int_content->value.value_uchar);
break;
case E_ACSL_IINT:
- fprintf(stderr, "\t- %s: %s%d\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_int);
+ fprintf(stream, "%d", int_content->value.value_int);
break;
case E_ACSL_IUINT:
- fprintf(stderr, "\t- %s: %s%u\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_uint);
+ fprintf(stream, "%u", int_content->value.value_uint);
break;
case E_ACSL_ISHORT:
- fprintf(stderr, "\t- %s: %s%hd\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_short);
+ fprintf(stream, "%hd", int_content->value.value_short);
break;
case E_ACSL_IUSHORT:
- fprintf(stderr, "\t- %s: %s%hu\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_ushort);
+ fprintf(stream, "%hu", int_content->value.value_ushort);
break;
case E_ACSL_ILONG:
- fprintf(stderr, "\t- %s: %s%ld\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_long);
+ fprintf(stream, "%ld", int_content->value.value_long);
break;
case E_ACSL_IULONG:
- fprintf(stderr, "\t- %s: %s%lu\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_ulong);
+ fprintf(stream, "%lu", int_content->value.value_ulong);
break;
case E_ACSL_ILONGLONG:
- fprintf(stderr, "\t- %s: %s%lld\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_llong);
+ fprintf(stream, "%lld", int_content->value.value_llong);
break;
case E_ACSL_IULONGLONG:
- fprintf(stderr, "\t- %s: %s%llu\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_ullong);
+ fprintf(stream, "%llu", int_content->value.value_ullong);
break;
case E_ACSL_IMPZ:
- __gmp_fprintf(stderr, "\t- %s: %s%Zd\n", name,
- int_content->is_enum ? "<enum> " : "",
- int_content->value.value_mpz);
+ __gmp_fprintf(stream, "%Zd", int_content->value.value_mpz);
break;
}
}
-void eacsl_print_real_content(const char *name,
+/*! Print the given real to `stream`. */
+void eacsl_print_real_content(FILE *stream,
eacsl_assert_data_real_content_t *real_content) {
switch (real_content->kind) {
case E_ACSL_RFLOAT:
- fprintf(stderr, "\t- %s: %e\n", name, real_content->value.value_float);
+ fprintf(stream, "%e", real_content->value.value_float);
break;
case E_ACSL_RDOUBLE:
- fprintf(stderr, "\t- %s: %le\n", name, real_content->value.value_double);
+ fprintf(stream, "%le", real_content->value.value_double);
break;
case E_ACSL_RLONGDOUBLE:
- fprintf(stderr, "\t- %s: %Le\n", name, real_content->value.value_ldouble);
+ fprintf(stream, "%Le", real_content->value.value_ldouble);
break;
case E_ACSL_RMPQ:
- __gmp_fprintf(stderr, "\t- %s: %Qd\n", name, real_content->value.value_mpq);
+ __gmp_fprintf(stream, "%Qd", real_content->value.value_mpq);
break;
}
}
-void eacsl_print_value(eacsl_assert_data_value_t *value) {
+void eacsl_print_value_content(FILE *stream, eacsl_assert_data_value_t *value) {
switch (value->type) {
case E_ACSL_INT:
- eacsl_print_int_content(value->name, &value->content.int_content);
+ eacsl_print_int_content(stream, &value->content.int_content);
break;
case E_ACSL_REAL:
- eacsl_print_real_content(value->name, &value->content.real_content);
+ eacsl_print_real_content(stream, &value->content.real_content);
break;
case E_ACSL_PTR:
- fprintf(stderr, "\t- %s: %p\n", value->name, value->content.value_ptr);
+ fprintf(stream, "%p", value->content.value_ptr);
break;
case E_ACSL_ARRAY:
- fprintf(stderr, "\t- %s: <array>\n\t\t- address: %p\n", value->name,
- value->content.value_array);
+ fprintf(stream, "<array>, address: %p", value->content.value_array);
break;
case E_ACSL_FUN:
- fprintf(stderr, "\t- %s: <function>\n", value->name);
+ fprintf(stream, "<function>");
break;
case E_ACSL_STRUCT:
- fprintf(stderr, "\t- %s: <struct>\n", value->name);
+ fprintf(stream, "<struct>");
break;
case E_ACSL_UNION:
- fprintf(stderr, "\t- %s: <union>\n", value->name);
+ fprintf(stream, "<union>");
break;
case E_ACSL_OTHER:
- fprintf(stderr, "\t- %s: <other>\n", value->name);
+ fprintf(stream, "<other>");
break;
default:
- fprintf(stderr, "\t- %s: <unknown>\n", value->name);
- break;
+ fprintf(stream, "<unknown>");
+ }
+}
+
+#ifndef E_ACSL_EXTERNAL_ASSERT
+
+/*! \brief Return `str` id `cond` is true, an empty string otherwise. */
+# define STR_IF(cond, str) ((cond) ? (str) : "")
+/*! \brief Return `str` if the string is not null, an empty string otherwise. */
+# define STR_IF_NOT_NULL(str) STR_IF(str, str)
+
+/*! \brief Default implementation of E-ACSL runtime assertions */
+void eacsl_runtime_assert(int predicate, eacsl_assert_data_t *data) {
+ if (eacsl_runtime_sound_verdict) {
+ if (!predicate) {
+ RTL_IO_LOCK();
+ // clang-format off
+ STDERR("%s: In function '%s'\n"
+ "%s:%d: Error: %s failed:\n"
+ "\tThe failing predicate is:\n"
+ "\t%s%s%s.\n",
+ data->file, data->fct,
+ data->file, data->line, data->kind,
+ STR_IF_NOT_NULL(data->name),
+ STR_IF(data->name, ":\n\t\t"),
+ data->pred_txt);
+ // clang-format on
+ eacsl_print_values(data);
+ RTL_IO_UNLOCK();
+ if (data->blocking) {
+# ifndef E_ACSL_NO_ASSERT_FAIL /* Do fail on assertions */
+# ifdef E_ACSL_FAIL_EXITCODE /* Fail by exit with a given code */
+ exit(E_ACSL_FAIL_EXITCODE);
+# else
+ raise_abort(data->file, data->line); /* Raise abort signal */
+# endif
+# endif
+ }
+ }
+# ifdef E_ACSL_DEBUG_ASSERT
+ else {
+ RTL_IO_LOCK();
+ // clang-format off
+ STDERR("%s: In function '%s'\n"
+ "%s:%d: %s valid:\n"
+ "\t%s%s%s.\n",
+ data->file, data->fct,
+ data->file, data->line, data->kind,
+ STR_IF_NOT_NULL(data->name),
+ STR_IF(data->name, ":\n\t\t"),
+ data->pred_txt);
+ // clang-format on
+ eacsl_print_values(data);
+ RTL_IO_UNLOCK();
+ }
+# endif
+ } else {
+ RTL_IO_LOCK();
+ // clang-format off
+ STDERR("%s: In function '%s'\n"
+ "%s:%d: Warning: no sound verdict for %s (guess: %s).\n"
+ "\tthe considered predicate is:\n"
+ "\t%s%s%s\n",
+ data->file, data->fct,
+ data->file, data->line, data->kind, predicate ? "ok" : "FAIL",
+ STR_IF_NOT_NULL(data->name),
+ STR_IF(data->name, ":\n\t\t"),
+ data->pred_txt);
+ // clang-format on
+ eacsl_print_values(data);
+ RTL_IO_UNLOCK();
+ }
+}
+#endif
+
+#ifndef E_ACSL_EXTERNAL_PRINT_VALUE
+void eacsl_print_value(eacsl_assert_data_value_t *value) {
+ fprintf(stderr, "\t- %s: ", value->name);
+ if (value->type == E_ACSL_ARRAY) {
+ // The function `eacsl_print_value_content()` prints the content of an array
+ // on one line to be more generic towards alternative implementation.
+ // For the default implementation we can override it to print something more
+ // consistent with the way the name of the value is printed.
+ fprintf(stderr, "<array>\n\t\t- address: %p", value->content.value_array);
+ } else {
+ eacsl_print_value_content(stderr, value);
}
+ fprintf(stderr, "\n");
}
#endif
diff --git a/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert.h b/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert.h
index 3911a3e244e16e47f5d98528c9265aca280e3821..b211cb53edeb5f80232cac97aa0569b4b5776a4f 100644
--- a/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert.h
+++ b/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert.h
@@ -34,6 +34,7 @@
#define eacsl_runtime_sound_verdict export_alias(sound_verdict)
#define eacsl_runtime_assert export_alias(assert)
#define eacsl_print_value export_alias(print_value)
+#define eacsl_print_value_content export_alias(print_value_content)
/*! E-ACSL instrumentation automatically sets this global to 0 if its verdict
becomes unsound.
@@ -62,4 +63,14 @@ void eacsl_runtime_assert(int predicate, eacsl_assert_data_t *data)
void eacsl_print_value(eacsl_assert_data_value_t *value)
__attribute__((FC_BUILTIN));
+/*! \brief Utility function that prints the content of the given data value in
+ * the given stream.
+ * \param stream Stream where to print the value content.
+ * \param value Value to print to the stream.
+ */
+/*@ requires \valid_read(value) && \initialized(value);
+ @ assigns \nothing; */
+void eacsl_print_value_content(FILE *stream, eacsl_assert_data_value_t *value)
+ __attribute__((FC_BUILTIN));
+
#endif // E_ACSL_ASSERT_H
diff --git a/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert_data.h b/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert_data.h
index 7a91b70ac09bd140111b81f58e064ce8d63a55ae..aa94970d5ceaccc64dceb6cb373404835d9310e8 100644
--- a/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert_data.h
+++ b/src/plugins/e-acsl/share/e-acsl/instrumentation_model/e_acsl_assert_data.h
@@ -190,6 +190,8 @@ typedef struct eacsl_assert_data_t {
int blocking;
/*! C string representing a kind of annotation (e.g., "Assertion") */
const char *kind;
+ /*! name identifying the predicate */
+ const char *name;
/*! stringified predicate */
const char *pred_txt;
/*! un-instrumented file of predicate placement */
diff --git a/src/plugins/e-acsl/share/e-acsl/numerical_model/e_acsl_floating_point.c b/src/plugins/e-acsl/share/e-acsl/numerical_model/e_acsl_floating_point.c
index 9cfaf188d995ecf9f3ac7a706c9fca56f668377a..4c1738332fcd47eb4c5c447a4e12c2ba052daa00 100644
--- a/src/plugins/e-acsl/share/e-acsl/numerical_model/e_acsl_floating_point.c
+++ b/src/plugins/e-acsl/share/e-acsl/numerical_model/e_acsl_floating_point.c
@@ -59,10 +59,10 @@ void eacsl_floating_point_exception(const char *exp) {
resp = "Floating-point underflow";
}
if (resp) {
- rtl_printf(
+ rtl_eprintf(
"Execution of the statement `%s` leads to a floating point exception\n",
exp);
- rtl_printf("Exception: %s\n", resp);
+ rtl_eprintf("Exception: %s\n", resp);
}
feclearexcept(FE_ALL_EXCEPT);
}
diff --git a/src/plugins/e-acsl/share/e-acsl/observation_model/internals/e_acsl_heap_tracking.c b/src/plugins/e-acsl/share/e-acsl/observation_model/internals/e_acsl_heap_tracking.c
index bd1f49c3dc13f0d3a9784288469c8b76344476c6..cca4782b1ace89e1c51aa26200e184c62af957bc 100644
--- a/src/plugins/e-acsl/share/e-acsl/observation_model/internals/e_acsl_heap_tracking.c
+++ b/src/plugins/e-acsl/share/e-acsl/observation_model/internals/e_acsl_heap_tracking.c
@@ -60,8 +60,9 @@ void report_heap_leaks() {
size_t size = eacsl_get_heap_allocation_size();
size_t blocks = eacsl_get_heap_allocated_blocks();
if (size) {
- rtl_printf(" *** WARNING: Leaked %lu bytes of heap memory in %ld block%s\n",
- size, blocks, (blocks == 1) ? "" : "s");
+ rtl_eprintf(
+ " *** WARNING: Leaked %lu bytes of heap memory in %ld block%s\n", size,
+ blocks, (blocks == 1) ? "" : "s");
}
#endif
}
diff --git a/src/plugins/e-acsl/src/code_generator/assert.ml b/src/plugins/e-acsl/src/code_generator/assert.ml
index 2321d56a757a74b949cb501e0ee961096daf2f61..f2528e9c6dfabee5d8a98719a5063c08ee2abc38 100644
--- a/src/plugins/e-acsl/src/code_generator/assert.ml
+++ b/src/plugins/e-acsl/src/code_generator/assert.ml
@@ -205,7 +205,7 @@ let kind_to_string loc k =
| Smart_stmt.Variant -> "Variant"
| Smart_stmt.RTE -> "RTE")
-let runtime_check_with_msg ~adata ~loc msg ~pred_kind kind kf env predicate_e =
+let runtime_check_with_msg ~adata ~loc ?(name="") msg ~pred_kind kind kf env predicate_e =
let env = Env.push env in
let data_registered, data_ptr, data_vi, env =
match adata with
@@ -234,14 +234,27 @@ let runtime_check_with_msg ~adata ~loc msg ~pred_kind kind kf env predicate_e =
let fct = Cil.mkString ~loc (Functions.RTL.get_original_name kf) in
let line = Cil.integer ~loc start_pos.Filepath.pos_lnum in
let stmts =
- [ Smart_stmt.rtl_call ~loc "assert" [ predicate_e; data_ptr ];
- Smart_stmt.assigns_field ~loc data_vi "line" line;
+ [ Smart_stmt.assigns_field ~loc data_vi "line" line;
Smart_stmt.assigns_field ~loc data_vi "fct" fct;
Smart_stmt.assigns_field ~loc data_vi "file" file;
Smart_stmt.assigns_field ~loc data_vi "pred_txt" pred_txt;
Smart_stmt.assigns_field ~loc data_vi "kind" kind;
Smart_stmt.assigns_field ~loc data_vi "blocking" blocking ]
in
+ let stmts =
+ if Datatype.String.equal name "" then
+ stmts
+ else
+ Smart_stmt.assigns_field
+ ~loc
+ data_vi
+ "name"
+ (Cil.mkString ~loc name)
+ :: stmts
+ in
+ let stmts =
+ Smart_stmt.rtl_call ~loc "assert" [ predicate_e; data_ptr ] :: stmts
+ in
let stmts=
if data_registered then
Smart_stmt.rtl_call ~loc "assert_clean" [ data_ptr ] :: stmts
@@ -259,5 +272,7 @@ let runtime_check_with_msg ~adata ~loc msg ~pred_kind kind kf env predicate_e =
let runtime_check ~adata ~pred_kind kind kf env e p =
let loc = p.pred_loc in
+ let name = String.concat "/" p.pred_name in
+ let p = { p with pred_name = [] } in
let msg = Format.asprintf "%a@?" Printer.pp_predicate p in
- runtime_check_with_msg ~adata ~loc msg ~pred_kind kind kf env e
+ runtime_check_with_msg ~adata ~loc ~name msg ~pred_kind kind kf env e
diff --git a/src/plugins/e-acsl/src/code_generator/assert.mli b/src/plugins/e-acsl/src/code_generator/assert.mli
index d81ed28c982d1fe1ac45c66cb85e13326ed4b61b..30ae0b268d0f09f5e14dbea4654f98576a5fdbe5 100644
--- a/src/plugins/e-acsl/src/code_generator/assert.mli
+++ b/src/plugins/e-acsl/src/code_generator/assert.mli
@@ -118,6 +118,7 @@ val runtime_check:
val runtime_check_with_msg:
adata:t ->
loc:location ->
+ ?name:string ->
string ->
pred_kind:predicate_kind ->
Smart_stmt.annotation_kind ->
@@ -125,12 +126,13 @@ val runtime_check_with_msg:
Env.t ->
exp ->
stmt * Env.t
-(** [runtime_check_with_msg ~adata ~loc msg ~pred_kind kind kf env e] generates
- a runtime check for [e] (or [!e] if [reverse] is [true]) by building a call
- to [__e_acsl_assert].
+(** [runtime_check_with_msg ~adata ~loc ?name msg ~pred_kind kind kf env e]
+ generates a runtime check for [e] (or [!e] if [reverse] is [true]) by
+ building a call to [__e_acsl_assert].
[adata] is the assertion context holding the data contributing to the
assertion.
[loc] is the location printed in the message if the runtime check fails.
+ [name] is the name of the predicate printed if the runtime check fails.
[msg] is the message printed if the runtime check fails.
[pred_kind] indicates if the assert should be blocking or not.
[kind] is the annotation kind of [p].
diff --git a/src/plugins/e-acsl/tests/arith/oracle/gen_arith.c b/src/plugins/e-acsl/tests/arith/oracle/gen_arith.c
index aa0c98f30f9b4a2d070d597e59699f9e2f90e58d..43aaec7eacd2592aa67157b4caf47aeb9ae6c097 100644
--- a/src/plugins/e-acsl/tests/arith/oracle/gen_arith.c
+++ b/src/plugins/e-acsl/tests/arith/oracle/gen_arith.c
@@ -277,10 +277,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_20,"y",0,y);
__gen_e_acsl_assert_data_20.blocking = 1;
__gen_e_acsl_assert_data_20.kind = "RTE";
- __gen_e_acsl_assert_data_20.pred_txt = "division_by_zero: y != 0";
+ __gen_e_acsl_assert_data_20.pred_txt = "y != 0";
__gen_e_acsl_assert_data_20.file = "arith.i";
__gen_e_acsl_assert_data_20.fct = "main";
__gen_e_acsl_assert_data_20.line = 31;
+ __gen_e_acsl_assert_data_20.name = "division_by_zero";
__e_acsl_assert(y != 0,& __gen_e_acsl_assert_data_20);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_20);
__gen_e_acsl_assert_data_19.blocking = 1;
diff --git a/src/plugins/e-acsl/tests/arith/oracle/gen_array.c b/src/plugins/e-acsl/tests/arith/oracle/gen_array.c
index 846ffae0ba569640d2baf6e4b1111c25313a6382..de262a615a363112e6d708bbb214a00d2e103c45 100644
--- a/src/plugins/e-acsl/tests/arith/oracle/gen_array.c
+++ b/src/plugins/e-acsl/tests/arith/oracle/gen_array.c
@@ -226,10 +226,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "mem_access: \\valid_read(&(*((int (*)[3])g))[__gen_e_acsl_iter_4])";
+ __gen_e_acsl_assert_data_10.pred_txt = "\\valid_read(&(*((int (*)[3])g))[__gen_e_acsl_iter_4])";
__gen_e_acsl_assert_data_10.file = "array.i";
__gen_e_acsl_assert_data_10.fct = "arrays";
__gen_e_acsl_assert_data_10.line = 40;
+ __gen_e_acsl_assert_data_10.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,
& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
@@ -279,10 +280,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "mem_access: \\valid_read((int *)*((int (*)[])g))";
+ __gen_e_acsl_assert_data_12.pred_txt = "\\valid_read((int *)*((int (*)[])g))";
__gen_e_acsl_assert_data_12.file = "array.i";
__gen_e_acsl_assert_data_12.fct = "arrays";
__gen_e_acsl_assert_data_12.line = 41;
+ __gen_e_acsl_assert_data_12.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
__gen_e_acsl_ = __e_acsl_block_length((void *)(*((int (*)[])g)));
@@ -307,10 +309,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_13.blocking = 1;
__gen_e_acsl_assert_data_13.kind = "RTE";
- __gen_e_acsl_assert_data_13.pred_txt = "mem_access: \\valid_read(&(*((int (*)[])g))[__gen_e_acsl_iter_5])";
+ __gen_e_acsl_assert_data_13.pred_txt = "\\valid_read(&(*((int (*)[])g))[__gen_e_acsl_iter_5])";
__gen_e_acsl_assert_data_13.file = "array.i";
__gen_e_acsl_assert_data_13.fct = "arrays";
__gen_e_acsl_assert_data_13.line = 41;
+ __gen_e_acsl_assert_data_13.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,
& __gen_e_acsl_assert_data_13);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_13);
@@ -362,10 +365,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "RTE";
- __gen_e_acsl_assert_data_15.pred_txt = "mem_access: \\valid_read(&(*((int (*)[3])f))[__gen_e_acsl_iter_6])";
+ __gen_e_acsl_assert_data_15.pred_txt = "\\valid_read(&(*((int (*)[3])f))[__gen_e_acsl_iter_6])";
__gen_e_acsl_assert_data_15.file = "array.i";
__gen_e_acsl_assert_data_15.fct = "arrays";
__gen_e_acsl_assert_data_15.line = 42;
+ __gen_e_acsl_assert_data_15.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_4,
& __gen_e_acsl_assert_data_15);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_15);
@@ -415,10 +419,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_17.blocking = 1;
__gen_e_acsl_assert_data_17.kind = "RTE";
- __gen_e_acsl_assert_data_17.pred_txt = "mem_access: \\valid_read((int *)*((int (*)[])f))";
+ __gen_e_acsl_assert_data_17.pred_txt = "\\valid_read((int *)*((int (*)[])f))";
__gen_e_acsl_assert_data_17.file = "array.i";
__gen_e_acsl_assert_data_17.fct = "arrays";
__gen_e_acsl_assert_data_17.line = 43;
+ __gen_e_acsl_assert_data_17.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_5,& __gen_e_acsl_assert_data_17);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_17);
__gen_e_acsl__3 = __e_acsl_block_length((void *)(*((int (*)[])f)));
@@ -443,10 +448,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_18.blocking = 1;
__gen_e_acsl_assert_data_18.kind = "RTE";
- __gen_e_acsl_assert_data_18.pred_txt = "mem_access: \\valid_read(&(*((int (*)[])f))[__gen_e_acsl_iter_7])";
+ __gen_e_acsl_assert_data_18.pred_txt = "\\valid_read(&(*((int (*)[])f))[__gen_e_acsl_iter_7])";
__gen_e_acsl_assert_data_18.file = "array.i";
__gen_e_acsl_assert_data_18.fct = "arrays";
__gen_e_acsl_assert_data_18.line = 43;
+ __gen_e_acsl_assert_data_18.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_6,
& __gen_e_acsl_assert_data_18);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_18);
@@ -611,10 +617,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_23.blocking = 1;
__gen_e_acsl_assert_data_23.kind = "RTE";
- __gen_e_acsl_assert_data_23.pred_txt = "mem_access: \\valid_read(&(*((int (*)[3])l))[__gen_e_acsl_iter_11])";
+ __gen_e_acsl_assert_data_23.pred_txt = "\\valid_read(&(*((int (*)[3])l))[__gen_e_acsl_iter_11])";
__gen_e_acsl_assert_data_23.file = "array.i";
__gen_e_acsl_assert_data_23.fct = "arrays";
__gen_e_acsl_assert_data_23.line = 55;
+ __gen_e_acsl_assert_data_23.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_7,
& __gen_e_acsl_assert_data_23);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_23);
@@ -631,10 +638,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_24.blocking = 1;
__gen_e_acsl_assert_data_24.kind = "RTE";
- __gen_e_acsl_assert_data_24.pred_txt = "mem_access: \\valid_read(&(*((int (*)[3])m))[__gen_e_acsl_iter_11])";
+ __gen_e_acsl_assert_data_24.pred_txt = "\\valid_read(&(*((int (*)[3])m))[__gen_e_acsl_iter_11])";
__gen_e_acsl_assert_data_24.file = "array.i";
__gen_e_acsl_assert_data_24.fct = "arrays";
__gen_e_acsl_assert_data_24.line = 55;
+ __gen_e_acsl_assert_data_24.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_8,
& __gen_e_acsl_assert_data_24);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_24);
@@ -688,10 +696,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_26.blocking = 1;
__gen_e_acsl_assert_data_26.kind = "RTE";
- __gen_e_acsl_assert_data_26.pred_txt = "mem_access: \\valid_read(&(*((int (*)[3])l))[__gen_e_acsl_iter_12])";
+ __gen_e_acsl_assert_data_26.pred_txt = "\\valid_read(&(*((int (*)[3])l))[__gen_e_acsl_iter_12])";
__gen_e_acsl_assert_data_26.file = "array.i";
__gen_e_acsl_assert_data_26.fct = "arrays";
__gen_e_acsl_assert_data_26.line = 56;
+ __gen_e_acsl_assert_data_26.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_9,
& __gen_e_acsl_assert_data_26);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_26);
@@ -708,10 +717,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_27.blocking = 1;
__gen_e_acsl_assert_data_27.kind = "RTE";
- __gen_e_acsl_assert_data_27.pred_txt = "mem_access: \\valid_read(&(*((int (*)[3])n))[__gen_e_acsl_iter_12])";
+ __gen_e_acsl_assert_data_27.pred_txt = "\\valid_read(&(*((int (*)[3])n))[__gen_e_acsl_iter_12])";
__gen_e_acsl_assert_data_27.file = "array.i";
__gen_e_acsl_assert_data_27.fct = "arrays";
__gen_e_acsl_assert_data_27.line = 56;
+ __gen_e_acsl_assert_data_27.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_10,
& __gen_e_acsl_assert_data_27);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_27);
@@ -751,17 +761,19 @@ void arrays(void)
{.values = (void *)0};
__gen_e_acsl_assert_data_30.blocking = 1;
__gen_e_acsl_assert_data_30.kind = "RTE";
- __gen_e_acsl_assert_data_30.pred_txt = "array_coercion: (int)3 <= (int)6";
+ __gen_e_acsl_assert_data_30.pred_txt = "(int)3 <= (int)6";
__gen_e_acsl_assert_data_30.file = "array.i";
__gen_e_acsl_assert_data_30.fct = "arrays";
__gen_e_acsl_assert_data_30.line = 59;
+ __gen_e_acsl_assert_data_30.name = "array_coercion";
__e_acsl_assert(1,& __gen_e_acsl_assert_data_30);
__gen_e_acsl_assert_data_29.blocking = 1;
__gen_e_acsl_assert_data_29.kind = "RTE";
- __gen_e_acsl_assert_data_29.pred_txt = "array_coercion: (int)3 <= (int)6";
+ __gen_e_acsl_assert_data_29.pred_txt = "(int)3 <= (int)6";
__gen_e_acsl_assert_data_29.file = "array.i";
__gen_e_acsl_assert_data_29.fct = "arrays";
__gen_e_acsl_assert_data_29.line = 59;
+ __gen_e_acsl_assert_data_29.name = "array_coercion";
__e_acsl_assert(1,& __gen_e_acsl_assert_data_29);
__gen_e_acsl_iter_13 = 0;
while (__gen_e_acsl_iter_13 < 3) {
@@ -800,17 +812,19 @@ void arrays(void)
{.values = (void *)0};
__gen_e_acsl_assert_data_33.blocking = 1;
__gen_e_acsl_assert_data_33.kind = "RTE";
- __gen_e_acsl_assert_data_33.pred_txt = "array_coercion: (int)3 <= (int)6";
+ __gen_e_acsl_assert_data_33.pred_txt = "(int)3 <= (int)6";
__gen_e_acsl_assert_data_33.file = "array.i";
__gen_e_acsl_assert_data_33.fct = "arrays";
__gen_e_acsl_assert_data_33.line = 60;
+ __gen_e_acsl_assert_data_33.name = "array_coercion";
__e_acsl_assert(1,& __gen_e_acsl_assert_data_33);
__gen_e_acsl_assert_data_32.blocking = 1;
__gen_e_acsl_assert_data_32.kind = "RTE";
- __gen_e_acsl_assert_data_32.pred_txt = "array_coercion: (int)3 <= (int)6";
+ __gen_e_acsl_assert_data_32.pred_txt = "(int)3 <= (int)6";
__gen_e_acsl_assert_data_32.file = "array.i";
__gen_e_acsl_assert_data_32.fct = "arrays";
__gen_e_acsl_assert_data_32.line = 60;
+ __gen_e_acsl_assert_data_32.name = "array_coercion";
__e_acsl_assert(1,& __gen_e_acsl_assert_data_32);
__gen_e_acsl_iter_14 = 0;
while (__gen_e_acsl_iter_14 < 3) {
@@ -863,10 +877,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_35.blocking = 1;
__gen_e_acsl_assert_data_35.kind = "RTE";
- __gen_e_acsl_assert_data_35.pred_txt = "mem_access: \\valid_read(&(*((int (*)[2])l))[__gen_e_acsl_iter_15])";
+ __gen_e_acsl_assert_data_35.pred_txt = "\\valid_read(&(*((int (*)[2])l))[__gen_e_acsl_iter_15])";
__gen_e_acsl_assert_data_35.file = "array.i";
__gen_e_acsl_assert_data_35.fct = "arrays";
__gen_e_acsl_assert_data_35.line = 61;
+ __gen_e_acsl_assert_data_35.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_11,
& __gen_e_acsl_assert_data_35);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_35);
@@ -883,10 +898,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_36.blocking = 1;
__gen_e_acsl_assert_data_36.kind = "RTE";
- __gen_e_acsl_assert_data_36.pred_txt = "mem_access: \\valid_read(&(*((int (*)[2])m))[__gen_e_acsl_iter_15])";
+ __gen_e_acsl_assert_data_36.pred_txt = "\\valid_read(&(*((int (*)[2])m))[__gen_e_acsl_iter_15])";
__gen_e_acsl_assert_data_36.file = "array.i";
__gen_e_acsl_assert_data_36.fct = "arrays";
__gen_e_acsl_assert_data_36.line = 61;
+ __gen_e_acsl_assert_data_36.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_12,
& __gen_e_acsl_assert_data_36);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_36);
@@ -940,10 +956,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_38.blocking = 1;
__gen_e_acsl_assert_data_38.kind = "RTE";
- __gen_e_acsl_assert_data_38.pred_txt = "mem_access: \\valid_read(&(*((int (*)[2])l))[__gen_e_acsl_iter_16])";
+ __gen_e_acsl_assert_data_38.pred_txt = "\\valid_read(&(*((int (*)[2])l))[__gen_e_acsl_iter_16])";
__gen_e_acsl_assert_data_38.file = "array.i";
__gen_e_acsl_assert_data_38.fct = "arrays";
__gen_e_acsl_assert_data_38.line = 62;
+ __gen_e_acsl_assert_data_38.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_13,
& __gen_e_acsl_assert_data_38);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_38);
@@ -960,10 +977,11 @@ void arrays(void)
(void *)0);
__gen_e_acsl_assert_data_39.blocking = 1;
__gen_e_acsl_assert_data_39.kind = "RTE";
- __gen_e_acsl_assert_data_39.pred_txt = "mem_access: \\valid_read(&(*((int (*)[2])n))[__gen_e_acsl_iter_16])";
+ __gen_e_acsl_assert_data_39.pred_txt = "\\valid_read(&(*((int (*)[2])n))[__gen_e_acsl_iter_16])";
__gen_e_acsl_assert_data_39.file = "array.i";
__gen_e_acsl_assert_data_39.fct = "arrays";
__gen_e_acsl_assert_data_39.line = 62;
+ __gen_e_acsl_assert_data_39.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_14,
& __gen_e_acsl_assert_data_39);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_39);
diff --git a/src/plugins/e-acsl/tests/arith/oracle/gen_at.c b/src/plugins/e-acsl/tests/arith/oracle/gen_at.c
index 066ff02534b01e2da3a06e7c3bbc41a7718a2f35..888d2c9fac9ba632c1a45380d70b369d72548fbe 100644
--- a/src/plugins/e-acsl/tests/arith/oracle/gen_at.c
+++ b/src/plugins/e-acsl/tests/arith/oracle/gen_at.c
@@ -116,10 +116,11 @@ void g(int *p, int *q)
(void *)(& q));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "mem_access: \\valid_read(q)";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read(q)";
__gen_e_acsl_assert_data_5.file = "at.i";
__gen_e_acsl_assert_data_5.fct = "g";
__gen_e_acsl_assert_data_5.line = 31;
+ __gen_e_acsl_assert_data_5.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__gen_e_acsl_at_3 = *q;
@@ -136,10 +137,11 @@ void g(int *p, int *q)
(void *)q,(void *)(& q));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(q)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(q)";
__gen_e_acsl_assert_data_2.file = "at.i";
__gen_e_acsl_assert_data_2.fct = "g";
__gen_e_acsl_assert_data_2.line = 29;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_at = *q;
@@ -168,10 +170,11 @@ void g(int *p, int *q)
(void *)(& p));
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(p + __gen_e_acsl_at)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(p + __gen_e_acsl_at)";
__gen_e_acsl_assert_data_3.file = "at.i";
__gen_e_acsl_assert_data_3.fct = "g";
__gen_e_acsl_assert_data_3.line = 29;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gen_e_acsl_at_2 = *(p + __gen_e_acsl_at);
@@ -213,10 +216,11 @@ void g(int *p, int *q)
(void *)(& p));
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "mem_access: \\valid_read(p + __gen_e_acsl_at_3)";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\valid_read(p + __gen_e_acsl_at_3)";
__gen_e_acsl_assert_data_6.file = "at.i";
__gen_e_acsl_assert_data_6.fct = "g";
__gen_e_acsl_assert_data_6.line = 31;
+ __gen_e_acsl_assert_data_6.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_4,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__gen_e_acsl_assert_data_4.blocking = 1;
diff --git a/src/plugins/e-acsl/tests/arith/oracle/gen_at_on-purely-logic-variables.c b/src/plugins/e-acsl/tests/arith/oracle/gen_at_on-purely-logic-variables.c
index 1699106744e35573412ee834ea018a959c57737b..9398cc676d2148b415c3b2fd7bf634e7274f861e 100644
--- a/src/plugins/e-acsl/tests/arith/oracle/gen_at_on-purely-logic-variables.c
+++ b/src/plugins/e-acsl/tests/arith/oracle/gen_at_on-purely-logic-variables.c
@@ -68,10 +68,11 @@ void g(void)
(void *)(& __gen_e_acsl_at));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at + (int)(__gen_e_acsl_w - 3))";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(__gen_e_acsl_at + (int)(__gen_e_acsl_w - 3))";
__gen_e_acsl_assert_data_2.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_2.fct = "g";
__gen_e_acsl_assert_data_2.line = 16;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
if (! *(__gen_e_acsl_at + (__gen_e_acsl_w - 3))) ;
@@ -249,10 +250,11 @@ int main(void)
(void *)(& __gen_e_acsl_at));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at + 0)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(__gen_e_acsl_at + 0)";
__gen_e_acsl_assert_data_2.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_2.fct = "main";
__gen_e_acsl_assert_data_2.line = 28;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_assert_data.blocking = 1;
@@ -292,10 +294,11 @@ int main(void)
(void *)(& __gen_e_acsl_at_2));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at_2 + (int)(__gen_e_acsl_j - 2))";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(__gen_e_acsl_at_2 + (int)(__gen_e_acsl_j - 2))";
__gen_e_acsl_assert_data_4.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_4.fct = "main";
__gen_e_acsl_assert_data_4.line = 29;
+ __gen_e_acsl_assert_data_4.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,
& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
@@ -363,10 +366,11 @@ int main(void)
(void *)(& __gen_e_acsl_at_3));
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "mem_access:\n \\valid_read(__gen_e_acsl_at_3 +\n (int)((int)((int)(__gen_e_acsl_u - 9) * 11) +\n (int)(__gen_e_acsl_v - -4)))";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\valid_read(__gen_e_acsl_at_3 +\n (int)((int)((int)(__gen_e_acsl_u - 9) * 11) +\n (int)(__gen_e_acsl_v - -4)))";
__gen_e_acsl_assert_data_6.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_6.fct = "main";
__gen_e_acsl_assert_data_6.line = 34;
+ __gen_e_acsl_assert_data_6.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,
& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
@@ -429,10 +433,11 @@ int main(void)
(void *)(& __gen_e_acsl_at_4));
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at_4 + 0)";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\valid_read(__gen_e_acsl_at_4 + 0)";
__gen_e_acsl_assert_data_8.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_8.fct = "main";
__gen_e_acsl_assert_data_8.line = 38;
+ __gen_e_acsl_assert_data_8.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_4,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__gen_e_acsl_assert_data_7.blocking = 1;
@@ -488,10 +493,11 @@ int main(void)
(void *)(& __gen_e_acsl_at_5));
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at_5 + (int)(__gen_e_acsl_k_3 - -8))";
+ __gen_e_acsl_assert_data_10.pred_txt = "\\valid_read(__gen_e_acsl_at_5 + (int)(__gen_e_acsl_k_3 - -8))";
__gen_e_acsl_assert_data_10.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_10.fct = "main";
__gen_e_acsl_assert_data_10.line = 42;
+ __gen_e_acsl_assert_data_10.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_5,
& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
@@ -565,10 +571,11 @@ int main(void)
(void *)(& __gen_e_acsl_at_6));
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "mem_access:\n \\valid_read(__gen_e_acsl_at_6 +\n (int)((int)((int)(__gen_e_acsl_u_3 - 9) * 32) +\n (int)(__gen_e_acsl_v_3 - -4)))";
+ __gen_e_acsl_assert_data_12.pred_txt = "\\valid_read(__gen_e_acsl_at_6 +\n (int)((int)((int)(__gen_e_acsl_u_3 - 9) * 32) +\n (int)(__gen_e_acsl_v_3 - -4)))";
__gen_e_acsl_assert_data_12.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_12.fct = "main";
__gen_e_acsl_assert_data_12.line = 46;
+ __gen_e_acsl_assert_data_12.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_6,
& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
@@ -681,10 +688,11 @@ int main(void)
(void *)(& __gen_e_acsl_at_7));
__gen_e_acsl_assert_data_14.blocking = 1;
__gen_e_acsl_assert_data_14.kind = "RTE";
- __gen_e_acsl_assert_data_14.pred_txt = "mem_access:\n \\valid_read(__gen_e_acsl_at_7 +\n (int)((int)((int)(__gen_e_acsl_u_5 - 10) * 300) +\n (int)((int)((int)(__gen_e_acsl_v_5 - -9) * 100) +\n (int)(__gen_e_acsl_w - 101))))";
+ __gen_e_acsl_assert_data_14.pred_txt = "\\valid_read(__gen_e_acsl_at_7 +\n (int)((int)((int)(__gen_e_acsl_u_5 - 10) * 300) +\n (int)((int)((int)(__gen_e_acsl_v_5 - -9) * 100) +\n (int)(__gen_e_acsl_w - 101))))";
__gen_e_acsl_assert_data_14.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_14.fct = "main";
__gen_e_acsl_assert_data_14.line = 59;
+ __gen_e_acsl_assert_data_14.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_7,
& __gen_e_acsl_assert_data_14);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_14);
@@ -794,10 +802,11 @@ void __gen_e_acsl_f(int *t)
(void *)(& t));
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "mem_access: \\valid_read(t + (int)(__gen_e_acsl_m_3 - 4))";
+ __gen_e_acsl_assert_data_9.pred_txt = "\\valid_read(t + (int)(__gen_e_acsl_m_3 - 4))";
__gen_e_acsl_assert_data_9.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_9.fct = "f";
__gen_e_acsl_assert_data_9.line = 8;
+ __gen_e_acsl_assert_data_9.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_7,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
*(__gen_e_acsl_at_4 + 0) = *(t + (__gen_e_acsl_m_3 - 4));
@@ -821,10 +830,11 @@ void __gen_e_acsl_f(int *t)
(void *)(& t));
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "mem_access: \\valid_read(t + __gen_e_acsl_m_2)";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\valid_read(t + __gen_e_acsl_m_2)";
__gen_e_acsl_assert_data_7.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_7.fct = "f";
__gen_e_acsl_assert_data_7.line = 8;
+ __gen_e_acsl_assert_data_7.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_5,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
*(__gen_e_acsl_at_3 + 0) = *(t + __gen_e_acsl_m_2) == -4;
@@ -852,10 +862,11 @@ void __gen_e_acsl_f(int *t)
(void *)(& t));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "mem_access: \\valid_read(t + (int)(__gen_e_acsl_n_3 - 1))";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(t + (int)(__gen_e_acsl_n_3 - 1))";
__gen_e_acsl_assert_data_4.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_4.fct = "f";
__gen_e_acsl_assert_data_4.line = 7;
+ __gen_e_acsl_assert_data_4.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,
& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
@@ -884,10 +895,11 @@ void __gen_e_acsl_f(int *t)
(void *)(& t));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(t + __gen_e_acsl_n_2)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(t + __gen_e_acsl_n_2)";
__gen_e_acsl_assert_data_2.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_2.fct = "f";
__gen_e_acsl_assert_data_2.line = 7;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
*(__gen_e_acsl_at + (__gen_e_acsl_n_2 - 2)) = *(t + __gen_e_acsl_n_2) == 12;
@@ -926,10 +938,11 @@ void __gen_e_acsl_f(int *t)
(void *)(& __gen_e_acsl_at));
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at + (int)(__gen_e_acsl_n - 2))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(__gen_e_acsl_at + (int)(__gen_e_acsl_n - 2))";
__gen_e_acsl_assert_data_3.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_3.fct = "f";
__gen_e_acsl_assert_data_3.line = 7;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,
& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
@@ -951,10 +964,11 @@ void __gen_e_acsl_f(int *t)
(void *)(& __gen_e_acsl_at_2));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at_2 + (int)(__gen_e_acsl_n - 2))";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read(__gen_e_acsl_at_2 + (int)(__gen_e_acsl_n - 2))";
__gen_e_acsl_assert_data_5.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_5.fct = "f";
__gen_e_acsl_assert_data_5.line = 7;
+ __gen_e_acsl_assert_data_5.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_4,
& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
@@ -1000,10 +1014,11 @@ void __gen_e_acsl_f(int *t)
(void *)(& __gen_e_acsl_at_3));
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at_3 + 0)";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\valid_read(__gen_e_acsl_at_3 + 0)";
__gen_e_acsl_assert_data_8.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_8.fct = "f";
__gen_e_acsl_assert_data_8.line = 8;
+ __gen_e_acsl_assert_data_8.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_6,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
if (*(__gen_e_acsl_at_3 + 0)) {
@@ -1024,10 +1039,11 @@ void __gen_e_acsl_f(int *t)
(void *)(& __gen_e_acsl_at_4));
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at_4 + 0)";
+ __gen_e_acsl_assert_data_10.pred_txt = "\\valid_read(__gen_e_acsl_at_4 + 0)";
__gen_e_acsl_assert_data_10.file = "at_on-purely-logic-variables.c";
__gen_e_acsl_assert_data_10.fct = "f";
__gen_e_acsl_assert_data_10.line = 8;
+ __gen_e_acsl_assert_data_10.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_8,
& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
diff --git a/src/plugins/e-acsl/tests/arith/oracle/gen_bitwise.c b/src/plugins/e-acsl/tests/arith/oracle/gen_bitwise.c
index 0b5a01d1e28f5de731368df4c7620c86e2329e65..262014a4609013613a0241ef1674eb31e7b9b168 100644
--- a/src/plugins/e-acsl/tests/arith/oracle/gen_bitwise.c
+++ b/src/plugins/e-acsl/tests/arith/oracle/gen_bitwise.c
@@ -20,10 +20,11 @@ void f_signed(int a, int b)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_2,"a",0,a);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "shift: 0 <= a";
+ __gen_e_acsl_assert_data_2.pred_txt = "0 <= a";
__gen_e_acsl_assert_data_2.file = "bitwise.c";
__gen_e_acsl_assert_data_2.fct = "f_signed";
__gen_e_acsl_assert_data_2.line = 14;
+ __gen_e_acsl_assert_data_2.name = "shift";
__e_acsl_assert(0 <= a,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_assert_data.blocking = 1;
@@ -47,10 +48,11 @@ void f_signed(int a, int b)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_4,"b",0,b);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "shift: 0 <= b";
+ __gen_e_acsl_assert_data_4.pred_txt = "0 <= b";
__gen_e_acsl_assert_data_4.file = "bitwise.c";
__gen_e_acsl_assert_data_4.fct = "f_signed";
__gen_e_acsl_assert_data_4.line = 16;
+ __gen_e_acsl_assert_data_4.name = "shift";
__e_acsl_assert(0 <= b,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_assert_data_3.blocking = 1;
@@ -240,10 +242,11 @@ void g_signed(int a, int b)
{
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "shiftl_rhs_fits_in_mp_bitcnt_t: 0 <= b <= 18446744073709551615";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= b <= 18446744073709551615";
__gen_e_acsl_assert_data_3.file = "bitwise.c";
__gen_e_acsl_assert_data_3.fct = "g_signed";
__gen_e_acsl_assert_data_3.line = 42;
+ __gen_e_acsl_assert_data_3.name = "shiftl_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_b_shiftl_guard,
& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
@@ -320,10 +323,11 @@ void g_signed(int a, int b)
{
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "shiftr_rhs_fits_in_mp_bitcnt_t: 0 <= b <= 18446744073709551615";
+ __gen_e_acsl_assert_data_6.pred_txt = "0 <= b <= 18446744073709551615";
__gen_e_acsl_assert_data_6.file = "bitwise.c";
__gen_e_acsl_assert_data_6.fct = "g_signed";
__gen_e_acsl_assert_data_6.line = 44;
+ __gen_e_acsl_assert_data_6.name = "shiftr_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_b_shiftr_guard,
& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
@@ -395,10 +399,11 @@ void g_signed(int a, int b)
{
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "shiftl_rhs_fits_in_mp_bitcnt_t: 0 <= 1 <= 18446744073709551615";
+ __gen_e_acsl_assert_data_9.pred_txt = "0 <= 1 <= 18446744073709551615";
__gen_e_acsl_assert_data_9.file = "bitwise.c";
__gen_e_acsl_assert_data_9.fct = "g_signed";
__gen_e_acsl_assert_data_9.line = 46;
+ __gen_e_acsl_assert_data_9.name = "shiftl_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_cst_shiftl_guard,
& __gen_e_acsl_assert_data_9);
}
@@ -467,10 +472,11 @@ void g_signed(int a, int b)
{
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "shiftr_rhs_fits_in_mp_bitcnt_t: 0 <= 1 <= 18446744073709551615";
+ __gen_e_acsl_assert_data_12.pred_txt = "0 <= 1 <= 18446744073709551615";
__gen_e_acsl_assert_data_12.file = "bitwise.c";
__gen_e_acsl_assert_data_12.fct = "g_signed";
__gen_e_acsl_assert_data_12.line = 47;
+ __gen_e_acsl_assert_data_12.name = "shiftr_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_cst_shiftr_guard,
& __gen_e_acsl_assert_data_12);
}
@@ -533,10 +539,11 @@ void g_signed(int a, int b)
{
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "RTE";
- __gen_e_acsl_assert_data_15.pred_txt = "shiftl_rhs_fits_in_mp_bitcnt_t: 0 <= 65 <= 18446744073709551615";
+ __gen_e_acsl_assert_data_15.pred_txt = "0 <= 65 <= 18446744073709551615";
__gen_e_acsl_assert_data_15.file = "bitwise.c";
__gen_e_acsl_assert_data_15.fct = "g_signed";
__gen_e_acsl_assert_data_15.line = 48;
+ __gen_e_acsl_assert_data_15.name = "shiftl_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_cst_shiftl_guard_2,
& __gen_e_acsl_assert_data_15);
}
@@ -714,10 +721,11 @@ void g_unsigned(unsigned int a, unsigned int b)
{
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "shiftl_rhs_fits_in_mp_bitcnt_t: 0 <= b <= 18446744073709551615";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= b <= 18446744073709551615";
__gen_e_acsl_assert_data_3.file = "bitwise.c";
__gen_e_acsl_assert_data_3.fct = "g_unsigned";
__gen_e_acsl_assert_data_3.line = 57;
+ __gen_e_acsl_assert_data_3.name = "shiftl_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_b_shiftl_guard,
& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
@@ -794,10 +802,11 @@ void g_unsigned(unsigned int a, unsigned int b)
{
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "shiftr_rhs_fits_in_mp_bitcnt_t: 0 <= b <= 18446744073709551615";
+ __gen_e_acsl_assert_data_6.pred_txt = "0 <= b <= 18446744073709551615";
__gen_e_acsl_assert_data_6.file = "bitwise.c";
__gen_e_acsl_assert_data_6.fct = "g_unsigned";
__gen_e_acsl_assert_data_6.line = 59;
+ __gen_e_acsl_assert_data_6.name = "shiftr_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_b_shiftr_guard,
& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
@@ -869,10 +878,11 @@ void g_unsigned(unsigned int a, unsigned int b)
{
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "shiftl_rhs_fits_in_mp_bitcnt_t: 0 <= 1u <= 18446744073709551615";
+ __gen_e_acsl_assert_data_9.pred_txt = "0 <= 1u <= 18446744073709551615";
__gen_e_acsl_assert_data_9.file = "bitwise.c";
__gen_e_acsl_assert_data_9.fct = "g_unsigned";
__gen_e_acsl_assert_data_9.line = 61;
+ __gen_e_acsl_assert_data_9.name = "shiftl_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_cst_shiftl_guard,
& __gen_e_acsl_assert_data_9);
}
@@ -941,10 +951,11 @@ void g_unsigned(unsigned int a, unsigned int b)
{
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "shiftr_rhs_fits_in_mp_bitcnt_t: 0 <= 1u <= 18446744073709551615";
+ __gen_e_acsl_assert_data_12.pred_txt = "0 <= 1u <= 18446744073709551615";
__gen_e_acsl_assert_data_12.file = "bitwise.c";
__gen_e_acsl_assert_data_12.fct = "g_unsigned";
__gen_e_acsl_assert_data_12.line = 62;
+ __gen_e_acsl_assert_data_12.name = "shiftr_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_cst_shiftr_guard,
& __gen_e_acsl_assert_data_12);
}
@@ -1007,10 +1018,11 @@ void g_unsigned(unsigned int a, unsigned int b)
{
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "RTE";
- __gen_e_acsl_assert_data_15.pred_txt = "shiftl_rhs_fits_in_mp_bitcnt_t: 0 <= 65u <= 18446744073709551615";
+ __gen_e_acsl_assert_data_15.pred_txt = "0 <= 65u <= 18446744073709551615";
__gen_e_acsl_assert_data_15.file = "bitwise.c";
__gen_e_acsl_assert_data_15.fct = "g_unsigned";
__gen_e_acsl_assert_data_15.line = 63;
+ __gen_e_acsl_assert_data_15.name = "shiftl_rhs_fits_in_mp_bitcnt_t";
__e_acsl_assert(__gen_e_acsl_cst_shiftl_guard_2,
& __gen_e_acsl_assert_data_15);
}
diff --git a/src/plugins/e-acsl/tests/arith/oracle/gen_functions_rec.c b/src/plugins/e-acsl/tests/arith/oracle/gen_functions_rec.c
index 17591b47b23fa4e3491951cca0958866517e46b8..ec0918b38258cc90d2a7551280e4bb1c60514c39 100644
--- a/src/plugins/e-acsl/tests/arith/oracle/gen_functions_rec.c
+++ b/src/plugins/e-acsl/tests/arith/oracle/gen_functions_rec.c
@@ -400,10 +400,11 @@ int __gen_e_acsl_f2(int n)
"__gen_e_acsl_f2_19",0,__gen_e_acsl_f2_19);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "division_by_zero: __gen_e_acsl_f2_19 != 0";
+ __gen_e_acsl_assert_data_7.pred_txt = "__gen_e_acsl_f2_19 != 0";
__gen_e_acsl_assert_data_7.file = "functions_rec.c";
__gen_e_acsl_assert_data_7.fct = "f2";
__gen_e_acsl_assert_data_7.line = 13;
+ __gen_e_acsl_assert_data_7.name = "division_by_zero";
__e_acsl_assert(__gen_e_acsl_f2_19 != 0,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
/*@ assert Eva: division_by_zero: __gen_e_acsl_f2_19 != 0; */
@@ -479,10 +480,11 @@ int __gen_e_acsl_f2_2(long n)
"__gen_e_acsl_f2_14",0,__gen_e_acsl_f2_14);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "division_by_zero: __gen_e_acsl_f2_14 != 0";
+ __gen_e_acsl_assert_data_6.pred_txt = "__gen_e_acsl_f2_14 != 0";
__gen_e_acsl_assert_data_6.file = "functions_rec.c";
__gen_e_acsl_assert_data_6.fct = "f2_2";
__gen_e_acsl_assert_data_6.line = 13;
+ __gen_e_acsl_assert_data_6.name = "division_by_zero";
__e_acsl_assert(__gen_e_acsl_f2_14 != 0,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
/*@ assert Eva: division_by_zero: __gen_e_acsl_f2_14 != 0; */
@@ -565,10 +567,11 @@ int __gen_e_acsl_f2_3(__e_acsl_mpz_struct * n)
"__gen_e_acsl_f2_9",0,__gen_e_acsl_f2_9);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "division_by_zero: __gen_e_acsl_f2_9 != 0";
+ __gen_e_acsl_assert_data_5.pred_txt = "__gen_e_acsl_f2_9 != 0";
__gen_e_acsl_assert_data_5.file = "functions_rec.c";
__gen_e_acsl_assert_data_5.fct = "f2_3";
__gen_e_acsl_assert_data_5.line = 13;
+ __gen_e_acsl_assert_data_5.name = "division_by_zero";
__e_acsl_assert(__gen_e_acsl_f2_9 != 0,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
/*@ assert Eva: division_by_zero: __gen_e_acsl_f2_9 != 0; */
diff --git a/src/plugins/e-acsl/tests/arith/oracle/gen_quantif.c b/src/plugins/e-acsl/tests/arith/oracle/gen_quantif.c
index 75abc2f33cc0be39d10d2846c99abacc103359a4..c930ac243e77ebfbba98efd7b00a17da97eb21e6 100644
--- a/src/plugins/e-acsl/tests/arith/oracle/gen_quantif.c
+++ b/src/plugins/e-acsl/tests/arith/oracle/gen_quantif.c
@@ -597,10 +597,11 @@ int main(void)
0,__gen_e_acsl_forall_13);
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "Assertion";
- __gen_e_acsl_assert_data_15.pred_txt = "forall_multiple_binders_1:\n \\forall integer i, integer j, integer k;\n 0 <= i < 10 && 1 < j <= 11 && 2 <= k <= 12 ==> p1(i, j, k)";
+ __gen_e_acsl_assert_data_15.pred_txt = "\\forall integer i, integer j, integer k;\n 0 <= i < 10 && 1 < j <= 11 && 2 <= k <= 12 ==> p1(i, j, k)";
__gen_e_acsl_assert_data_15.file = "quantif.i";
__gen_e_acsl_assert_data_15.fct = "main";
__gen_e_acsl_assert_data_15.line = 59;
+ __gen_e_acsl_assert_data_15.name = "forall_multiple_binders_1";
__e_acsl_assert(__gen_e_acsl_forall_13,& __gen_e_acsl_assert_data_15);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_15);
}
@@ -651,10 +652,11 @@ int main(void)
0,__gen_e_acsl_forall_14);
__gen_e_acsl_assert_data_16.blocking = 1;
__gen_e_acsl_assert_data_16.kind = "Assertion";
- __gen_e_acsl_assert_data_16.pred_txt = "forall_multiple_binders_2:\n \\forall integer i, integer j, integer k;\n 0 <= i <= j < k <= 10 ==> p2(i, j, k)";
+ __gen_e_acsl_assert_data_16.pred_txt = "\\forall integer i, integer j, integer k;\n 0 <= i <= j < k <= 10 ==> p2(i, j, k)";
__gen_e_acsl_assert_data_16.file = "quantif.i";
__gen_e_acsl_assert_data_16.fct = "main";
__gen_e_acsl_assert_data_16.line = 62;
+ __gen_e_acsl_assert_data_16.name = "forall_multiple_binders_2";
__e_acsl_assert(__gen_e_acsl_forall_14,& __gen_e_acsl_assert_data_16);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_16);
}
@@ -705,10 +707,11 @@ int main(void)
0,__gen_e_acsl_forall_15);
__gen_e_acsl_assert_data_17.blocking = 1;
__gen_e_acsl_assert_data_17.kind = "Assertion";
- __gen_e_acsl_assert_data_17.pred_txt = "forall_multiple_binders_3:\n \\forall integer i, integer j, integer k;\n 0 <= i < j <= 10 && 1 < k < 11 ==> p3(i, j, k)";
+ __gen_e_acsl_assert_data_17.pred_txt = "\\forall integer i, integer j, integer k;\n 0 <= i < j <= 10 && 1 < k < 11 ==> p3(i, j, k)";
__gen_e_acsl_assert_data_17.file = "quantif.i";
__gen_e_acsl_assert_data_17.fct = "main";
__gen_e_acsl_assert_data_17.line = 65;
+ __gen_e_acsl_assert_data_17.name = "forall_multiple_binders_3";
__e_acsl_assert(__gen_e_acsl_forall_15,& __gen_e_acsl_assert_data_17);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_17);
}
@@ -759,10 +762,11 @@ int main(void)
0,__gen_e_acsl_forall_16);
__gen_e_acsl_assert_data_18.blocking = 1;
__gen_e_acsl_assert_data_18.kind = "Assertion";
- __gen_e_acsl_assert_data_18.pred_txt = "forall_multiple_binders_4:\n \\forall integer i, integer j, integer k;\n 0 <= i < 10 ==> 1 < j <= 11 ==> 2 <= k <= 12 ==> p1(i, j, k)";
+ __gen_e_acsl_assert_data_18.pred_txt = "\\forall integer i, integer j, integer k;\n 0 <= i < 10 ==> 1 < j <= 11 ==> 2 <= k <= 12 ==> p1(i, j, k)";
__gen_e_acsl_assert_data_18.file = "quantif.i";
__gen_e_acsl_assert_data_18.fct = "main";
__gen_e_acsl_assert_data_18.line = 68;
+ __gen_e_acsl_assert_data_18.name = "forall_multiple_binders_4";
__e_acsl_assert(__gen_e_acsl_forall_16,& __gen_e_acsl_assert_data_18);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_18);
}
@@ -813,10 +817,11 @@ int main(void)
0,__gen_e_acsl_forall_17);
__gen_e_acsl_assert_data_19.blocking = 1;
__gen_e_acsl_assert_data_19.kind = "Assertion";
- __gen_e_acsl_assert_data_19.pred_txt = "forall_unordered_binders:\n \\forall integer i, integer j, integer k;\n 0 <= i <= k <= 10 && 1 <= j < k ==> p4(i, j, k)";
+ __gen_e_acsl_assert_data_19.pred_txt = "\\forall integer i, integer j, integer k;\n 0 <= i <= k <= 10 && 1 <= j < k ==> p4(i, j, k)";
__gen_e_acsl_assert_data_19.file = "quantif.i";
__gen_e_acsl_assert_data_19.fct = "main";
__gen_e_acsl_assert_data_19.line = 71;
+ __gen_e_acsl_assert_data_19.name = "forall_unordered_binders";
__e_acsl_assert(__gen_e_acsl_forall_17,& __gen_e_acsl_assert_data_19);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_19);
}
@@ -867,10 +872,11 @@ int main(void)
0,__gen_e_acsl_exists_3);
__gen_e_acsl_assert_data_20.blocking = 1;
__gen_e_acsl_assert_data_20.kind = "Assertion";
- __gen_e_acsl_assert_data_20.pred_txt = "exists_multiple_binders_1:\n \\exists integer i, integer j, integer k;\n 0 <= i < 10 && 1 < j <= 11 && 2 <= k <= 12 && p1(i, j, k)";
+ __gen_e_acsl_assert_data_20.pred_txt = "\\exists integer i, integer j, integer k;\n 0 <= i < 10 && 1 < j <= 11 && 2 <= k <= 12 && p1(i, j, k)";
__gen_e_acsl_assert_data_20.file = "quantif.i";
__gen_e_acsl_assert_data_20.fct = "main";
__gen_e_acsl_assert_data_20.line = 74;
+ __gen_e_acsl_assert_data_20.name = "exists_multiple_binders_1";
__e_acsl_assert(__gen_e_acsl_exists_3,& __gen_e_acsl_assert_data_20);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_20);
}
@@ -921,10 +927,11 @@ int main(void)
0,__gen_e_acsl_exists_4);
__gen_e_acsl_assert_data_21.blocking = 1;
__gen_e_acsl_assert_data_21.kind = "Assertion";
- __gen_e_acsl_assert_data_21.pred_txt = "exists_multiple_binders_2:\n \\exists integer i, integer j, integer k;\n 0 <= i <= j < k <= 10 && p2(i, j, k)";
+ __gen_e_acsl_assert_data_21.pred_txt = "\\exists integer i, integer j, integer k; 0 <= i <= j < k <= 10 && p2(i, j, k)";
__gen_e_acsl_assert_data_21.file = "quantif.i";
__gen_e_acsl_assert_data_21.fct = "main";
__gen_e_acsl_assert_data_21.line = 77;
+ __gen_e_acsl_assert_data_21.name = "exists_multiple_binders_2";
__e_acsl_assert(__gen_e_acsl_exists_4,& __gen_e_acsl_assert_data_21);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_21);
}
@@ -975,10 +982,11 @@ int main(void)
0,__gen_e_acsl_exists_5);
__gen_e_acsl_assert_data_22.blocking = 1;
__gen_e_acsl_assert_data_22.kind = "Assertion";
- __gen_e_acsl_assert_data_22.pred_txt = "exists_multiple_binders_3:\n \\exists integer i, integer j, integer k;\n 0 <= i < j <= 10 && 1 < k < 11 && p3(i, j, k)";
+ __gen_e_acsl_assert_data_22.pred_txt = "\\exists integer i, integer j, integer k;\n 0 <= i < j <= 10 && 1 < k < 11 && p3(i, j, k)";
__gen_e_acsl_assert_data_22.file = "quantif.i";
__gen_e_acsl_assert_data_22.fct = "main";
__gen_e_acsl_assert_data_22.line = 80;
+ __gen_e_acsl_assert_data_22.name = "exists_multiple_binders_3";
__e_acsl_assert(__gen_e_acsl_exists_5,& __gen_e_acsl_assert_data_22);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_22);
}
@@ -1029,10 +1037,11 @@ int main(void)
0,__gen_e_acsl_exists_6);
__gen_e_acsl_assert_data_23.blocking = 1;
__gen_e_acsl_assert_data_23.kind = "Assertion";
- __gen_e_acsl_assert_data_23.pred_txt = "exists_unordered_binders:\n \\exists integer i, integer j, integer k;\n 0 <= i <= k <= 10 && 1 <= j < k && p4(i, j, k)";
+ __gen_e_acsl_assert_data_23.pred_txt = "\\exists integer i, integer j, integer k;\n 0 <= i <= k <= 10 && 1 <= j < k && p4(i, j, k)";
__gen_e_acsl_assert_data_23.file = "quantif.i";
__gen_e_acsl_assert_data_23.fct = "main";
__gen_e_acsl_assert_data_23.line = 83;
+ __gen_e_acsl_assert_data_23.name = "exists_unordered_binders";
__e_acsl_assert(__gen_e_acsl_exists_6,& __gen_e_acsl_assert_data_23);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_23);
}
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1307.c b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1307.c
index a8d8958a0836921dd2a50bca4212d853b27f35f7..4683310c7c5aa6cb601f118d1a34e10cecb0c3e4 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1307.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1307.c
@@ -202,10 +202,11 @@ void __gen_e_acsl_bar(float *Mtmin_in, float *Mwmin, float *Mtmin_out)
(void *)(& __gen_e_acsl_at_2));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at_2)";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read(__gen_e_acsl_at_2)";
__gen_e_acsl_assert_data_5.file = "bts1307.i";
__gen_e_acsl_assert_data_5.fct = "bar";
__gen_e_acsl_assert_data_5.line = 26;
+ __gen_e_acsl_assert_data_5.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_6 =
@@ -220,10 +221,11 @@ void __gen_e_acsl_bar(float *Mtmin_in, float *Mwmin, float *Mtmin_out)
(void *)(& __gen_e_acsl_at));
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at)";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\valid_read(__gen_e_acsl_at)";
__gen_e_acsl_assert_data_6.file = "bts1307.i";
__gen_e_acsl_assert_data_6.fct = "bar";
__gen_e_acsl_assert_data_6.line = 26;
+ __gen_e_acsl_assert_data_6.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
if (*__gen_e_acsl_at == *__gen_e_acsl_at_2) {
@@ -272,10 +274,11 @@ void __gen_e_acsl_bar(float *Mtmin_in, float *Mwmin, float *Mtmin_out)
(void *)(& __gen_e_acsl_at_5));
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at_5)";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\valid_read(__gen_e_acsl_at_5)";
__gen_e_acsl_assert_data_7.file = "bts1307.i";
__gen_e_acsl_assert_data_7.fct = "bar";
__gen_e_acsl_assert_data_7.line = 26;
+ __gen_e_acsl_assert_data_7.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,
& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
@@ -309,10 +312,11 @@ void __gen_e_acsl_bar(float *Mtmin_in, float *Mwmin, float *Mtmin_out)
}
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "UnderEstimate_Motoring:\n *\\old(Mtmin_out) == *\\old(Mtmin_in) < 0.85 * *\\old(Mwmin)?\n *\\old(Mtmin_in) != 0.:\n 0.85 * *\\old(Mwmin) != 0.";
+ __gen_e_acsl_assert_data_4.pred_txt = "*\\old(Mtmin_out) == *\\old(Mtmin_in) < 0.85 * *\\old(Mwmin)?\n *\\old(Mtmin_in) != 0.:\n 0.85 * *\\old(Mwmin) != 0.";
__gen_e_acsl_assert_data_4.file = "bts1307.i";
__gen_e_acsl_assert_data_4.fct = "bar";
__gen_e_acsl_assert_data_4.line = 26;
+ __gen_e_acsl_assert_data_4.name = "UnderEstimate_Motoring";
__e_acsl_assert(__gen_e_acsl_if,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -473,10 +477,11 @@ void __gen_e_acsl_foo(float *Mtmax_in, float *Mwmax, float *Mtmax_out)
(__e_acsl_mpq_struct const *)(__gen_e_acsl_add));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "OverEstimate_Motoring:\n *\\old(Mtmax_out) != *\\old(Mtmax_in) + (5 - ((5 / 80) * *\\old(Mwmax)) * 0.4)";
+ __gen_e_acsl_assert_data_4.pred_txt = "*\\old(Mtmax_out) != *\\old(Mtmax_in) + (5 - ((5 / 80) * *\\old(Mwmax)) * 0.4)";
__gen_e_acsl_assert_data_4.file = "bts1307.i";
__gen_e_acsl_assert_data_4.fct = "foo";
__gen_e_acsl_assert_data_4.line = 11;
+ __gen_e_acsl_assert_data_4.name = "OverEstimate_Motoring";
__e_acsl_assert(__gen_e_acsl_ne != 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gmpq_clear(__gen_e_acsl_);
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1324.c b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1324.c
index 7cae1c93f16f23709220e231bce6b4b0b26548de..b666ed548a1ee4dffba65c1a4b0c4f2af1506137 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1324.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1324.c
@@ -94,10 +94,11 @@ int __gen_e_acsl_sorted(int *t, int n)
(void *)(& t));
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "RTE";
- __gen_e_acsl_assert_data.pred_txt = "mem_access: \\valid_read(t + __gen_e_acsl_i)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid_read(t + __gen_e_acsl_i)";
__gen_e_acsl_assert_data.file = "bts1324.i";
__gen_e_acsl_assert_data.fct = "sorted";
__gen_e_acsl_assert_data.line = 6;
+ __gen_e_acsl_assert_data.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -115,10 +116,11 @@ int __gen_e_acsl_sorted(int *t, int n)
(void *)(& t));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(t + (long)(__gen_e_acsl_i - 1))";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(t + (long)(__gen_e_acsl_i - 1))";
__gen_e_acsl_assert_data_2.file = "bts1324.i";
__gen_e_acsl_assert_data_2.fct = "sorted";
__gen_e_acsl_assert_data_2.line = 6;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,
& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
@@ -146,10 +148,11 @@ int __gen_e_acsl_sorted(int *t, int n)
__retres);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "yes: \\result == 1";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result == 1";
__gen_e_acsl_assert_data_3.file = "bts1324.i";
__gen_e_acsl_assert_data_3.fct = "sorted";
__gen_e_acsl_assert_data_3.line = 7;
+ __gen_e_acsl_assert_data_3.name = "yes";
__e_acsl_assert(__retres == 1,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
}
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1326.c b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1326.c
index 47aa6ede8b74bf374464abfae3ed8904b9bc878b..e48c777bf33ec8b67b026477260fdad73930a82d 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1326.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1326.c
@@ -110,10 +110,11 @@ void __gen_e_acsl_atp_NORMAL_computeAverageAccel(ArrayInt *Accel,
(void *)0);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read((int *)*__gen_e_acsl_at_6)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read((int *)*__gen_e_acsl_at_6)";
__gen_e_acsl_assert_data_2.file = "bts1326.i";
__gen_e_acsl_assert_data_2.fct = "atp_NORMAL_computeAverageAccel";
__gen_e_acsl_assert_data_2.line = 8;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -129,10 +130,11 @@ void __gen_e_acsl_atp_NORMAL_computeAverageAccel(ArrayInt *Accel,
(void *)0);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(&(*__gen_e_acsl_at_5)[1])";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(&(*__gen_e_acsl_at_5)[1])";
__gen_e_acsl_assert_data_3.file = "bts1326.i";
__gen_e_acsl_assert_data_3.fct = "atp_NORMAL_computeAverageAccel";
__gen_e_acsl_assert_data_3.line = 8;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -148,10 +150,11 @@ void __gen_e_acsl_atp_NORMAL_computeAverageAccel(ArrayInt *Accel,
(void *)0);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "mem_access: \\valid_read(&(*__gen_e_acsl_at_4)[2])";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(&(*__gen_e_acsl_at_4)[2])";
__gen_e_acsl_assert_data_4.file = "bts1326.i";
__gen_e_acsl_assert_data_4.fct = "atp_NORMAL_computeAverageAccel";
__gen_e_acsl_assert_data_4.line = 8;
+ __gen_e_acsl_assert_data_4.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -167,10 +170,11 @@ void __gen_e_acsl_atp_NORMAL_computeAverageAccel(ArrayInt *Accel,
(void *)0);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "mem_access: \\valid_read(&(*__gen_e_acsl_at_3)[3])";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read(&(*__gen_e_acsl_at_3)[3])";
__gen_e_acsl_assert_data_5.file = "bts1326.i";
__gen_e_acsl_assert_data_5.fct = "atp_NORMAL_computeAverageAccel";
__gen_e_acsl_assert_data_5.line = 8;
+ __gen_e_acsl_assert_data_5.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_4,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_6 =
@@ -186,10 +190,11 @@ void __gen_e_acsl_atp_NORMAL_computeAverageAccel(ArrayInt *Accel,
(void *)0);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "mem_access: \\valid_read(&(*__gen_e_acsl_at_2)[4])";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\valid_read(&(*__gen_e_acsl_at_2)[4])";
__gen_e_acsl_assert_data_6.file = "bts1326.i";
__gen_e_acsl_assert_data_6.fct = "atp_NORMAL_computeAverageAccel";
__gen_e_acsl_assert_data_6.line = 8;
+ __gen_e_acsl_assert_data_6.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_5,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_7 =
@@ -204,10 +209,11 @@ void __gen_e_acsl_atp_NORMAL_computeAverageAccel(ArrayInt *Accel,
(void *)(& __gen_e_acsl_at));
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "mem_access: \\valid_read(__gen_e_acsl_at)";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\valid_read(__gen_e_acsl_at)";
__gen_e_acsl_assert_data_7.file = "bts1326.i";
__gen_e_acsl_assert_data_7.fct = "atp_NORMAL_computeAverageAccel";
__gen_e_acsl_assert_data_7.line = 8;
+ __gen_e_acsl_assert_data_7.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_6,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__gen_e_acsl_assert_data.blocking = 1;
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1390.c b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1390.c
index 710fec08e42caa39f84a807d8956b3239843923d..18254b245ea74905f0a1daf93f8bc1869b91ae03 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1390.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1390.c
@@ -103,10 +103,11 @@ void *__gen_e_acsl_memchr(void const *buf, int c, size_t n)
(void *)(& buf));
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "RTE";
- __gen_e_acsl_assert_data.pred_txt = "mem_access: \\valid_read((char *)buf + __gen_e_acsl_i)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid_read((char *)buf + __gen_e_acsl_i)";
__gen_e_acsl_assert_data.file = "bts1390.c";
__gen_e_acsl_assert_data.fct = "memchr";
__gen_e_acsl_assert_data.line = 8;
+ __gen_e_acsl_assert_data.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
if (! ((int)*((char *)buf + __gen_e_acsl_i) == c)) ;
@@ -141,10 +142,11 @@ void *__gen_e_acsl_memchr(void const *buf, int c, size_t n)
(void *)(& buf));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read((char *)buf + __gen_e_acsl_k)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read((char *)buf + __gen_e_acsl_k)";
__gen_e_acsl_assert_data_2.file = "bts1390.c";
__gen_e_acsl_assert_data_2.fct = "memchr";
__gen_e_acsl_assert_data_2.line = 11;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,
& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
@@ -199,10 +201,11 @@ void *__gen_e_acsl_memchr(void const *buf, int c, size_t n)
(void *)(& __gen_e_acsl_at));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "mem_access: \\valid_read((char *)__gen_e_acsl_at + __gen_e_acsl_j)";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read((char *)__gen_e_acsl_at + __gen_e_acsl_j)";
__gen_e_acsl_assert_data_4.file = "bts1390.c";
__gen_e_acsl_assert_data_4.fct = "memchr";
__gen_e_acsl_assert_data_4.line = 9;
+ __gen_e_acsl_assert_data_4.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,
& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
@@ -221,10 +224,11 @@ void *__gen_e_acsl_memchr(void const *buf, int c, size_t n)
0,__gen_e_acsl_forall_2);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "exists:\n \\forall int j;\n 0 <= j < (int)\\offset((char *)\\result) ==>\n (int)*((char *)\\old(buf) + j) != \\old(c)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\forall int j;\n 0 <= j < (int)\\offset((char *)\\result) ==>\n (int)*((char *)\\old(buf) + j) != \\old(c)";
__gen_e_acsl_assert_data_3.file = "bts1390.c";
__gen_e_acsl_assert_data_3.fct = "memchr";
__gen_e_acsl_assert_data_3.line = 9;
+ __gen_e_acsl_assert_data_3.name = "exists";
__e_acsl_assert(__gen_e_acsl_forall_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
}
@@ -237,10 +241,11 @@ void *__gen_e_acsl_memchr(void const *buf, int c, size_t n)
__retres);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "not_exists: \\result == (void *)0";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result == (void *)0";
__gen_e_acsl_assert_data_5.file = "bts1390.c";
__gen_e_acsl_assert_data_5.fct = "memchr";
__gen_e_acsl_assert_data_5.line = 12;
+ __gen_e_acsl_assert_data_5.name = "not_exists";
__e_acsl_assert(__retres == (void *)0,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
}
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1399.c b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1399.c
index 7dc0ef31c0a22023b67914d2c638aac4b3715c57..2142ccecad26e627213e0a57a4a8cccf5b1be542 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_bts1399.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_bts1399.c
@@ -45,10 +45,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(&state->bitsInQueue)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(&state->bitsInQueue)";
__gen_e_acsl_assert_data_2.file = "bts1399.c";
__gen_e_acsl_assert_data_2.fct = "main";
__gen_e_acsl_assert_data_2.line = 19;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_bts2192.c b/src/plugins/e-acsl/tests/bts/oracle/gen_bts2192.c
index 227bd74e634a1ff44225cafd4f84bb8c7c6d4fa7..6ffc1e9e03c6ded886466f1459adbe2272666ed0 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_bts2192.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_bts2192.c
@@ -42,10 +42,11 @@ int __gen_e_acsl_atoi(char const *nptr)
__gen_e_acsl_valid_read);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_nptr: \\valid_read(nptr)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid_read(nptr)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "atoi";
__gen_e_acsl_assert_data.line = 78;
+ __gen_e_acsl_assert_data.name = "valid_nptr";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_bts2252.c b/src/plugins/e-acsl/tests/bts/oracle/gen_bts2252.c
index 5b56c7b5979771ac33f335e0a38890919c926440..3b16a3b2a4bfd4764b7766b41ff34b7858988009 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_bts2252.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_bts2252.c
@@ -129,10 +129,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "room_nstring: \\valid(dest + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid(dest + (0 .. n - 1))";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_2.fct = "strncpy";
__gen_e_acsl_assert_data_2.line = 380;
+ __gen_e_acsl_assert_data_2.name = "room_nstring";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -162,10 +163,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
(void *)(& dest));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "separated_guard: \\valid_read(dest + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(dest + (0 .. n - 1))";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "strncpy";
__gen_e_acsl_assert_data_4.line = 382;
+ __gen_e_acsl_assert_data_4.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -193,10 +195,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
(void *)(& src));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "separated_guard: \\valid_read(src + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read(src + (0 .. n - 1))";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_5.fct = "strncpy";
__gen_e_acsl_assert_data_5.line = 382;
+ __gen_e_acsl_assert_data_5.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ptr(& __gen_e_acsl_assert_data_3,"dest",
@@ -242,10 +245,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
0,__gen_e_acsl_separated);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "separation: \\separated(dest + (0 .. n - 1), src + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\separated(dest + (0 .. n - 1), src + (0 .. n - 1))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_3.fct = "strncpy";
__gen_e_acsl_assert_data_3.line = 382;
+ __gen_e_acsl_assert_data_3.name = "separation";
__e_acsl_assert(__gen_e_acsl_separated,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gmpz_clear(__gen_e_acsl_n);
@@ -284,10 +288,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
(void *)__gen_e_acsl_at);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "Postcondition";
- __gen_e_acsl_assert_data_6.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_6.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_6.fct = "strncpy";
__gen_e_acsl_assert_data_6.line = 385;
+ __gen_e_acsl_assert_data_6.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_7 =
@@ -332,10 +337,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
0,__gen_e_acsl_initialized);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "Postcondition";
- __gen_e_acsl_assert_data_7.pred_txt = "initialization: \\initialized(\\old(dest) + (0 .. \\old(n) - 1))";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\initialized(\\old(dest) + (0 .. \\old(n) - 1))";
__gen_e_acsl_assert_data_7.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_7.fct = "strncpy";
__gen_e_acsl_assert_data_7.line = 386;
+ __gen_e_acsl_assert_data_7.name = "initialization";
__e_acsl_assert(__gen_e_acsl_initialized,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_contract_clean(__gen_e_acsl_contract);
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-139.c b/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-139.c
index 5cbf4dba8918a54d942a4b1241e5171f0263c14e..a6466bb5a4cd839f0ff014b89c0080609e9786e8 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-139.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-139.c
@@ -55,10 +55,11 @@ void __gen_e_acsl_f(struct X *item)
(void *)(& item));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(item)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(item)";
__gen_e_acsl_assert_data_2.file = "issue-eacsl-139.c";
__gen_e_acsl_assert_data_2.fct = "f";
__gen_e_acsl_assert_data_2.line = 9;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_at_2 = *item;
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-172.c b/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-172.c
index b5bfe70ceb3555c37648c67d06eacd2a48c682c9..f32019a4288a74515f1ea5dcf876c9f6f44ebb24 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-172.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-172.c
@@ -21,10 +21,11 @@ int main(void)
__e_acsl_assert_register_double(& __gen_e_acsl_assert_data_2,"d2",d2);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "float_to_int: -2147483649 < d2";
+ __gen_e_acsl_assert_data_2.pred_txt = "-2147483649 < d2";
__gen_e_acsl_assert_data_2.file = "issue-eacsl-172.c";
__gen_e_acsl_assert_data_2.fct = "main";
__gen_e_acsl_assert_data_2.line = 7;
+ __gen_e_acsl_assert_data_2.name = "float_to_int";
__e_acsl_assert(-2147483649. < d2,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -32,10 +33,11 @@ int main(void)
__e_acsl_assert_register_double(& __gen_e_acsl_assert_data_3,"d2",d2);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "float_to_int: d2 < 2147483648";
+ __gen_e_acsl_assert_data_3.pred_txt = "d2 < 2147483648";
__gen_e_acsl_assert_data_3.file = "issue-eacsl-172.c";
__gen_e_acsl_assert_data_3.fct = "main";
__gen_e_acsl_assert_data_3.line = 7;
+ __gen_e_acsl_assert_data_3.name = "float_to_int";
__e_acsl_assert(d2 < 2147483648.,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gen_e_acsl_assert_data.blocking = 1;
diff --git a/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-40.c b/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-40.c
index 511fbd1ea646ed873f01ea969034ad032f918eaf..3e8074f9776e02e075d00ab8e2519445cb3f1f3b 100644
--- a/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-40.c
+++ b/src/plugins/e-acsl/tests/bts/oracle/gen_issue-eacsl-40.c
@@ -146,10 +146,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
(__e_acsl_mpz_struct const *)(__gen_e_acsl_if));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "offset_lesser_or_eq_than_SIZE_MAX:\n (\\let size = sizeof(char) * (((nmemb * size - 1) - 0) + 1);\n size <= 0? 0: size)\n <= 18446744073709551615";
+ __gen_e_acsl_assert_data_2.pred_txt = "(\\let size = sizeof(char) * (((nmemb * size - 1) - 0) + 1);\n size <= 0? 0: size)\n<= 18446744073709551615";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_2.fct = "fread";
__gen_e_acsl_assert_data_2.line = 351;
+ __gen_e_acsl_assert_data_2.name = "offset_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_2 <= 0,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_size_3 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_if));
@@ -161,10 +162,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_ptr_block: \\valid((char *)ptr + (0 .. nmemb * size - 1))";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid((char *)ptr + (0 .. nmemb * size - 1))";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data.fct = "fread";
__gen_e_acsl_assert_data.line = 351;
+ __gen_e_acsl_assert_data.name = "valid_ptr_block";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -179,10 +181,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
"\\valid(stream)",0,__gen_e_acsl_valid_2);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "valid_stream: \\valid(stream)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid(stream)";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_3.fct = "fread";
__gen_e_acsl_assert_data_3.line = 352;
+ __gen_e_acsl_assert_data_3.name = "valid_stream";
__e_acsl_assert(__gen_e_acsl_valid_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gmpz_clear(__gen_e_acsl_size);
@@ -233,10 +236,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
(__e_acsl_mpz_struct const *)(__gen_e_acsl__5));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "size_lesser_or_eq_than_SIZE_MAX: __retres * size <= 18446744073709551615";
+ __gen_e_acsl_assert_data_4.pred_txt = "__retres * size <= 18446744073709551615";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_4.fct = "fread";
__gen_e_acsl_assert_data_4.line = 350;
+ __gen_e_acsl_assert_data_4.name = "size_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_3 <= 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_size_5 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_mul_3));
@@ -271,10 +275,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
"\\old(nmemb)",0,__gen_e_acsl_at);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "size_read: \\result <= \\old(nmemb)";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result <= \\old(nmemb)";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_5.fct = "fread";
__gen_e_acsl_assert_data_5.line = 356;
+ __gen_e_acsl_assert_data_5.name = "size_read";
__e_acsl_assert(__retres <= __gen_e_acsl_at,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_6 =
@@ -346,10 +351,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
(__e_acsl_mpz_struct const *)(__gen_e_acsl_if_2));
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "offset_lesser_or_eq_than_SIZE_MAX:\n (\\let size = sizeof(char) * (((\\result * \\old(size) - 1) - 0) + 1);\n size <= 0? 0: size)\n <= 18446744073709551615";
+ __gen_e_acsl_assert_data_7.pred_txt = "(\\let size = sizeof(char) * (((\\result * \\old(size) - 1) - 0) + 1);\n size <= 0? 0: size)\n<= 18446744073709551615";
__gen_e_acsl_assert_data_7.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_7.fct = "fread";
__gen_e_acsl_assert_data_7.line = 357;
+ __gen_e_acsl_assert_data_7.name = "offset_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_5 <= 0,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__gen_e_acsl_size_8 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_if_2));
@@ -361,10 +367,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
0,__gen_e_acsl_initialized);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "Postcondition";
- __gen_e_acsl_assert_data_6.pred_txt = "initialization:\n \\initialized((char *)\\old(ptr) + (0 .. \\result * \\old(size) - 1))";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\initialized((char *)\\old(ptr) + (0 .. \\result * \\old(size) - 1))";
__gen_e_acsl_assert_data_6.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_6.fct = "fread";
__gen_e_acsl_assert_data_6.line = 357;
+ __gen_e_acsl_assert_data_6.name = "initialization";
__e_acsl_assert(__gen_e_acsl_initialized,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_delete_block((void *)(& stream));
diff --git a/src/plugins/e-acsl/tests/builtin/oracle/gen_strcat.c b/src/plugins/e-acsl/tests/builtin/oracle/gen_strcat.c
index 668633df81ecadb142ae0b99de4d18d2f2f53624..7423ad772d31fe769874a2b1c3100c41309c3e8a 100644
--- a/src/plugins/e-acsl/tests/builtin/oracle/gen_strcat.c
+++ b/src/plugins/e-acsl/tests/builtin/oracle/gen_strcat.c
@@ -669,10 +669,11 @@ pid_t __gen_e_acsl_fork(void)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "result_ok_child_or_error: \\result == 0 || \\result > 0 || \\result == -1";
+ __gen_e_acsl_assert_data.pred_txt = "\\result == 0 || \\result > 0 || \\result == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/unistd.h";
__gen_e_acsl_assert_data.fct = "fork";
__gen_e_acsl_assert_data.line = 846;
+ __gen_e_acsl_assert_data.name = "result_ok_child_or_error";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
return __retres;
@@ -728,10 +729,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
"\\valid(stat_loc)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "stat_loc_non_null: valid_stat_loc: \\valid(stat_loc)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(stat_loc)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data.fct = "waitpid";
__gen_e_acsl_assert_data.line = 95;
+ __gen_e_acsl_assert_data.name = "stat_loc_non_null/valid_stat_loc";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -755,10 +757,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "result_ok_or_error: \\result == -1 || \\result >= 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == -1 || \\result >= 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_2.fct = "waitpid";
__gen_e_acsl_assert_data_2.line = 87;
+ __gen_e_acsl_assert_data_2.name = "result_ok_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -788,10 +791,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: stat_loc_init_on_success:\n \\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_3.fct = "waitpid";
__gen_e_acsl_assert_data_3.line = 89;
+ __gen_e_acsl_assert_data_3.name = "initialization/stat_loc_init_on_success";
__e_acsl_assert(__gen_e_acsl_implies,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -812,10 +816,11 @@ void __gen_e_acsl_exit(int status)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "exit";
__gen_e_acsl_assert_data.line = 473;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
diff --git a/src/plugins/e-acsl/tests/builtin/oracle/gen_strcmp.c b/src/plugins/e-acsl/tests/builtin/oracle/gen_strcmp.c
index bea2c5f790925e1785e617be9e5d24b577c5cb1b..347be95252fe859c04523ce6b8dc37b9b9d57a5d 100644
--- a/src/plugins/e-acsl/tests/builtin/oracle/gen_strcmp.c
+++ b/src/plugins/e-acsl/tests/builtin/oracle/gen_strcmp.c
@@ -168,10 +168,11 @@ char *__gen_e_acsl_strdup(char const *s)
(void *)__retres);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "no_allocation: result_null: \\result == \\null";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\result == \\null";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "strdup";
__gen_e_acsl_assert_data_4.line = 498;
+ __gen_e_acsl_assert_data_4.name = "no_allocation/result_null";
__e_acsl_assert(__retres == (char *)0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -209,10 +210,11 @@ pid_t __gen_e_acsl_fork(void)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "result_ok_child_or_error: \\result == 0 || \\result > 0 || \\result == -1";
+ __gen_e_acsl_assert_data.pred_txt = "\\result == 0 || \\result > 0 || \\result == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/unistd.h";
__gen_e_acsl_assert_data.fct = "fork";
__gen_e_acsl_assert_data.line = 846;
+ __gen_e_acsl_assert_data.name = "result_ok_child_or_error";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
return __retres;
@@ -268,10 +270,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
"\\valid(stat_loc)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "stat_loc_non_null: valid_stat_loc: \\valid(stat_loc)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(stat_loc)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data.fct = "waitpid";
__gen_e_acsl_assert_data.line = 95;
+ __gen_e_acsl_assert_data.name = "stat_loc_non_null/valid_stat_loc";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -295,10 +298,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "result_ok_or_error: \\result == -1 || \\result >= 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == -1 || \\result >= 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_2.fct = "waitpid";
__gen_e_acsl_assert_data_2.line = 87;
+ __gen_e_acsl_assert_data_2.name = "result_ok_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -328,10 +332,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: stat_loc_init_on_success:\n \\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_3.fct = "waitpid";
__gen_e_acsl_assert_data_3.line = 89;
+ __gen_e_acsl_assert_data_3.name = "initialization/stat_loc_init_on_success";
__e_acsl_assert(__gen_e_acsl_implies,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -352,10 +357,11 @@ void __gen_e_acsl_exit(int status)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "exit";
__gen_e_acsl_assert_data.line = 473;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
@@ -373,10 +379,11 @@ void __gen_e_acsl_abort(void)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "abort";
__gen_e_acsl_assert_data.line = 460;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
diff --git a/src/plugins/e-acsl/tests/builtin/oracle/gen_strcpy.c b/src/plugins/e-acsl/tests/builtin/oracle/gen_strcpy.c
index 3a7d9c056021dd1e8b3bd2b767a21f50c4b2da2c..893f81a67edabdfab1dd017663cbb56506f5b5db 100644
--- a/src/plugins/e-acsl/tests/builtin/oracle/gen_strcpy.c
+++ b/src/plugins/e-acsl/tests/builtin/oracle/gen_strcpy.c
@@ -602,10 +602,11 @@ char *__gen_e_acsl_strdup(char const *s)
(void *)__retres);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "no_allocation: result_null: \\result == \\null";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\result == \\null";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "strdup";
__gen_e_acsl_assert_data_4.line = 498;
+ __gen_e_acsl_assert_data_4.name = "no_allocation/result_null";
__e_acsl_assert(__retres == (char *)0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -643,10 +644,11 @@ pid_t __gen_e_acsl_fork(void)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "result_ok_child_or_error: \\result == 0 || \\result > 0 || \\result == -1";
+ __gen_e_acsl_assert_data.pred_txt = "\\result == 0 || \\result > 0 || \\result == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/unistd.h";
__gen_e_acsl_assert_data.fct = "fork";
__gen_e_acsl_assert_data.line = 846;
+ __gen_e_acsl_assert_data.name = "result_ok_child_or_error";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
return __retres;
@@ -702,10 +704,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
"\\valid(stat_loc)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "stat_loc_non_null: valid_stat_loc: \\valid(stat_loc)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(stat_loc)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data.fct = "waitpid";
__gen_e_acsl_assert_data.line = 95;
+ __gen_e_acsl_assert_data.name = "stat_loc_non_null/valid_stat_loc";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -729,10 +732,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "result_ok_or_error: \\result == -1 || \\result >= 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == -1 || \\result >= 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_2.fct = "waitpid";
__gen_e_acsl_assert_data_2.line = 87;
+ __gen_e_acsl_assert_data_2.name = "result_ok_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -762,10 +766,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: stat_loc_init_on_success:\n \\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_3.fct = "waitpid";
__gen_e_acsl_assert_data_3.line = 89;
+ __gen_e_acsl_assert_data_3.name = "initialization/stat_loc_init_on_success";
__e_acsl_assert(__gen_e_acsl_implies,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -786,10 +791,11 @@ void __gen_e_acsl_exit(int status)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "exit";
__gen_e_acsl_assert_data.line = 473;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
diff --git a/src/plugins/e-acsl/tests/builtin/oracle/gen_strlen.c b/src/plugins/e-acsl/tests/builtin/oracle/gen_strlen.c
index 9db1342beab0234cb08980195ca1b789f405f9ae..4de9c149b4f9efd18cd257d98779f06afcc729d8 100644
--- a/src/plugins/e-acsl/tests/builtin/oracle/gen_strlen.c
+++ b/src/plugins/e-acsl/tests/builtin/oracle/gen_strlen.c
@@ -142,10 +142,11 @@ char *__gen_e_acsl_strdup(char const *s)
(void *)__retres);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "no_allocation: result_null: \\result == \\null";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\result == \\null";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "strdup";
__gen_e_acsl_assert_data_4.line = 498;
+ __gen_e_acsl_assert_data_4.name = "no_allocation/result_null";
__e_acsl_assert(__retres == (char *)0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -183,10 +184,11 @@ pid_t __gen_e_acsl_fork(void)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "result_ok_child_or_error: \\result == 0 || \\result > 0 || \\result == -1";
+ __gen_e_acsl_assert_data.pred_txt = "\\result == 0 || \\result > 0 || \\result == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/unistd.h";
__gen_e_acsl_assert_data.fct = "fork";
__gen_e_acsl_assert_data.line = 846;
+ __gen_e_acsl_assert_data.name = "result_ok_child_or_error";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
return __retres;
@@ -242,10 +244,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
"\\valid(stat_loc)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "stat_loc_non_null: valid_stat_loc: \\valid(stat_loc)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(stat_loc)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data.fct = "waitpid";
__gen_e_acsl_assert_data.line = 95;
+ __gen_e_acsl_assert_data.name = "stat_loc_non_null/valid_stat_loc";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -269,10 +272,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "result_ok_or_error: \\result == -1 || \\result >= 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == -1 || \\result >= 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_2.fct = "waitpid";
__gen_e_acsl_assert_data_2.line = 87;
+ __gen_e_acsl_assert_data_2.name = "result_ok_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -302,10 +306,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: stat_loc_init_on_success:\n \\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_3.fct = "waitpid";
__gen_e_acsl_assert_data_3.line = 89;
+ __gen_e_acsl_assert_data_3.name = "initialization/stat_loc_init_on_success";
__e_acsl_assert(__gen_e_acsl_implies,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -326,10 +331,11 @@ void __gen_e_acsl_exit(int status)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "exit";
__gen_e_acsl_assert_data.line = 473;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
@@ -347,10 +353,11 @@ void __gen_e_acsl_abort(void)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "abort";
__gen_e_acsl_assert_data.line = 460;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
diff --git a/src/plugins/e-acsl/tests/concurrency/oracle/gen_parallel_threads.c b/src/plugins/e-acsl/tests/concurrency/oracle/gen_parallel_threads.c
index f9f9cc90b23dca264000398bf076e305fc938793..76ac158551f5a3b2cc9eb53a5e30b94dbd22ecf4 100644
--- a/src/plugins/e-acsl/tests/concurrency/oracle/gen_parallel_threads.c
+++ b/src/plugins/e-acsl/tests/concurrency/oracle/gen_parallel_threads.c
@@ -268,10 +268,11 @@ void *read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_2.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_2.file = "parallel_threads.c";
__gen_e_acsl_assert_data_2.fct = "read_value";
__gen_e_acsl_assert_data_2.line = 82;
+ __gen_e_acsl_assert_data_2.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -280,10 +281,11 @@ void *read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_3.file = "parallel_threads.c";
__gen_e_acsl_assert_data_3.fct = "read_value";
__gen_e_acsl_assert_data_3.line = 82;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -308,10 +310,11 @@ void *read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_4.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_4.file = "parallel_threads.c";
__gen_e_acsl_assert_data_4.fct = "read_value";
__gen_e_acsl_assert_data_4.line = 82;
+ __gen_e_acsl_assert_data_4.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -320,10 +323,11 @@ void *read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_5.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_5.file = "parallel_threads.c";
__gen_e_acsl_assert_data_5.fct = "read_value";
__gen_e_acsl_assert_data_5.line = 82;
+ __gen_e_acsl_assert_data_5.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -379,10 +383,11 @@ void *read_value(void *arg)
idx);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "index_bound: idx < 10";
+ __gen_e_acsl_assert_data_8.pred_txt = "idx < 10";
__gen_e_acsl_assert_data_8.file = "parallel_threads.c";
__gen_e_acsl_assert_data_8.fct = "read_value";
__gen_e_acsl_assert_data_8.line = 85;
+ __gen_e_acsl_assert_data_8.name = "index_bound";
__e_acsl_assert(idx < 10,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_9 =
@@ -391,10 +396,11 @@ void *read_value(void *arg)
idx);
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "index_bound: 0 <= idx";
+ __gen_e_acsl_assert_data_9.pred_txt = "0 <= idx";
__gen_e_acsl_assert_data_9.file = "parallel_threads.c";
__gen_e_acsl_assert_data_9.fct = "read_value";
__gen_e_acsl_assert_data_9.line = 85;
+ __gen_e_acsl_assert_data_9.name = "index_bound";
__e_acsl_assert(0 <= idx,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_7,
@@ -408,10 +414,11 @@ void *read_value(void *arg)
else __gen_e_acsl_and_3 = 0;
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "mem_access: \\valid_read(values[idx])";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\valid_read(values[idx])";
__gen_e_acsl_assert_data_7.file = "parallel_threads.c";
__gen_e_acsl_assert_data_7.fct = "read_value";
__gen_e_acsl_assert_data_7.line = 85;
+ __gen_e_acsl_assert_data_7.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_3,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_10 =
@@ -419,10 +426,11 @@ void *read_value(void *arg)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_10,"idx",0,idx);
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "index_bound: idx < 10";
+ __gen_e_acsl_assert_data_10.pred_txt = "idx < 10";
__gen_e_acsl_assert_data_10.file = "parallel_threads.c";
__gen_e_acsl_assert_data_10.fct = "read_value";
__gen_e_acsl_assert_data_10.line = 85;
+ __gen_e_acsl_assert_data_10.name = "index_bound";
__e_acsl_assert(idx < 10,& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_11 =
@@ -430,10 +438,11 @@ void *read_value(void *arg)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_11,"idx",0,idx);
__gen_e_acsl_assert_data_11.blocking = 1;
__gen_e_acsl_assert_data_11.kind = "RTE";
- __gen_e_acsl_assert_data_11.pred_txt = "index_bound: 0 <= idx";
+ __gen_e_acsl_assert_data_11.pred_txt = "0 <= idx";
__gen_e_acsl_assert_data_11.file = "parallel_threads.c";
__gen_e_acsl_assert_data_11.fct = "read_value";
__gen_e_acsl_assert_data_11.line = 85;
+ __gen_e_acsl_assert_data_11.name = "index_bound";
__e_acsl_assert(0 <= idx,& __gen_e_acsl_assert_data_11);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_11);
__gen_e_acsl_assert_data_6.blocking = 1;
@@ -499,10 +508,11 @@ void *__gen_e_acsl_read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_2.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_2.file = "parallel_threads.c";
__gen_e_acsl_assert_data_2.fct = "read_value";
__gen_e_acsl_assert_data_2.line = 61;
+ __gen_e_acsl_assert_data_2.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -511,10 +521,11 @@ void *__gen_e_acsl_read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_3.file = "parallel_threads.c";
__gen_e_acsl_assert_data_3.fct = "read_value";
__gen_e_acsl_assert_data_3.line = 61;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -539,10 +550,11 @@ void *__gen_e_acsl_read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_4.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_4.file = "parallel_threads.c";
__gen_e_acsl_assert_data_4.fct = "read_value";
__gen_e_acsl_assert_data_4.line = 61;
+ __gen_e_acsl_assert_data_4.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -551,10 +563,11 @@ void *__gen_e_acsl_read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_5.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_5.file = "parallel_threads.c";
__gen_e_acsl_assert_data_5.fct = "read_value";
__gen_e_acsl_assert_data_5.line = 61;
+ __gen_e_acsl_assert_data_5.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -623,10 +636,11 @@ void *__gen_e_acsl_write_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_2.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_2.file = "parallel_threads.c";
__gen_e_acsl_assert_data_2.fct = "write_value";
__gen_e_acsl_assert_data_2.line = 32;
+ __gen_e_acsl_assert_data_2.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -635,10 +649,11 @@ void *__gen_e_acsl_write_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_3.file = "parallel_threads.c";
__gen_e_acsl_assert_data_3.fct = "write_value";
__gen_e_acsl_assert_data_3.line = 32;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -663,10 +678,11 @@ void *__gen_e_acsl_write_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_4.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_4.file = "parallel_threads.c";
__gen_e_acsl_assert_data_4.fct = "write_value";
__gen_e_acsl_assert_data_4.line = 32;
+ __gen_e_acsl_assert_data_4.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -675,10 +691,11 @@ void *__gen_e_acsl_write_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_5.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_5.file = "parallel_threads.c";
__gen_e_acsl_assert_data_5.fct = "write_value";
__gen_e_acsl_assert_data_5.line = 32;
+ __gen_e_acsl_assert_data_5.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -730,10 +747,11 @@ int __gen_e_acsl_usleep(useconds_t usec)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "result_ok_or_error: \\result == 0 || \\result == -1";
+ __gen_e_acsl_assert_data.pred_txt = "\\result == 0 || \\result == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/unistd.h";
__gen_e_acsl_assert_data.fct = "usleep";
__gen_e_acsl_assert_data.line = 1119;
+ __gen_e_acsl_assert_data.name = "result_ok_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_delete_block((void *)(& usec));
@@ -755,10 +773,11 @@ void __gen_e_acsl_exit(int status)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "exit";
__gen_e_acsl_assert_data.line = 473;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
__e_acsl_delete_block((void *)(& status));
return;
@@ -803,10 +822,11 @@ int __gen_e_acsl_pthread_mutex_unlock(pthread_mutex_t *mutex)
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "mutex_valid: \\valid(mutex)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(mutex)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_mutex_unlock";
__gen_e_acsl_assert_data.line = 313;
+ __gen_e_acsl_assert_data.name = "mutex_valid";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -825,10 +845,11 @@ int __gen_e_acsl_pthread_mutex_unlock(pthread_mutex_t *mutex)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "success_or_error: \\result == 0 || \\result == 1";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == 1";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_mutex_unlock";
__gen_e_acsl_assert_data_2.line = 316;
+ __gen_e_acsl_assert_data_2.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_delete_block((void *)(& mutex));
@@ -865,10 +886,11 @@ int __gen_e_acsl_pthread_mutex_lock(pthread_mutex_t *mutex)
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "mutex_valid: \\valid(mutex)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(mutex)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_mutex_lock";
__gen_e_acsl_assert_data.line = 295;
+ __gen_e_acsl_assert_data.name = "mutex_valid";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -901,10 +923,11 @@ int __gen_e_acsl_pthread_mutex_lock(pthread_mutex_t *mutex)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "success_or_error:\n \\result == 0 || \\result == 11 || \\result == 22 || \\result == 35";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == 11 || \\result == 22 || \\result == 35";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_mutex_lock";
__gen_e_acsl_assert_data_2.line = 299;
+ __gen_e_acsl_assert_data_2.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_3,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_delete_block((void *)(& mutex));
@@ -947,10 +970,11 @@ int __gen_e_acsl_pthread_mutex_init(pthread_mutex_t * restrict mutex,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "mutex_valid: \\valid(mutex)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(mutex)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_mutex_init";
__gen_e_acsl_assert_data.line = 279;
+ __gen_e_acsl_assert_data.name = "mutex_valid";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -976,10 +1000,11 @@ int __gen_e_acsl_pthread_mutex_init(pthread_mutex_t * restrict mutex,
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "attrs_valid_or_null: attrs == \\null || \\valid_read(attrs)";
+ __gen_e_acsl_assert_data_2.pred_txt = "attrs == \\null || \\valid_read(attrs)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_mutex_init";
__gen_e_acsl_assert_data_2.line = 280;
+ __gen_e_acsl_assert_data_2.name = "attrs_valid_or_null";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -1036,10 +1061,11 @@ int __gen_e_acsl_pthread_mutex_init(pthread_mutex_t * restrict mutex,
}
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: success_or_error:\n (\\result == 0 && \\initialized(\\old(mutex))) || \\result == 11 ||\n \\result == 12 || \\result == 1 || \\result == 22";
+ __gen_e_acsl_assert_data_3.pred_txt = "(\\result == 0 && \\initialized(\\old(mutex))) || \\result == 11 || \\result == 12 ||\n\\result == 1 || \\result == 22";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_3.fct = "pthread_mutex_init";
__gen_e_acsl_assert_data_3.line = 285;
+ __gen_e_acsl_assert_data_3.name = "initialization/success_or_error";
__e_acsl_assert(__gen_e_acsl_or_5,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_delete_block((void *)(& attrs));
@@ -1097,10 +1123,11 @@ int __gen_e_acsl_pthread_join(pthread_t thread, void **retval)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_or_null_retval: retval == \\null || \\valid(retval)";
+ __gen_e_acsl_assert_data.pred_txt = "retval == \\null || \\valid(retval)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_join";
__gen_e_acsl_assert_data.line = 247;
+ __gen_e_acsl_assert_data.name = "valid_or_null_retval";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_contract_set_behavior_assumes(__gen_e_acsl_contract,(size_t)0,
@@ -1139,10 +1166,11 @@ int __gen_e_acsl_pthread_join(pthread_t thread, void **retval)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "success_or_error:\n \\result == 0 || \\result == 35 || \\result == 22 || \\result == 3";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == 35 || \\result == 22 || \\result == 3";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_join";
__gen_e_acsl_assert_data_2.line = 251;
+ __gen_e_acsl_assert_data_2.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_4,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -1190,10 +1218,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
"\\valid(thread)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_thread: \\valid(thread)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(thread)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_create";
__gen_e_acsl_assert_data.line = 223;
+ __gen_e_acsl_assert_data.name = "valid_thread";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -1219,10 +1248,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "valid_null_attr: attr == \\null || \\valid_read(attr)";
+ __gen_e_acsl_assert_data_2.pred_txt = "attr == \\null || \\valid_read(attr)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_create";
__gen_e_acsl_assert_data_2.line = 224;
+ __gen_e_acsl_assert_data_2.name = "valid_null_attr";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -1243,10 +1273,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Precondition";
- __gen_e_acsl_assert_data_4.pred_txt = "valid_null_arg: arg == \\null || \\valid((char *)arg)";
+ __gen_e_acsl_assert_data_4.pred_txt = "arg == \\null || \\valid((char *)arg)";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_4.fct = "pthread_create";
__gen_e_acsl_assert_data_4.line = 226;
+ __gen_e_acsl_assert_data_4.name = "valid_null_arg";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -1279,10 +1310,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "success_or_error:\n \\result == 0 || \\result == 11 || \\result == 22 || \\result == 1";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result == 0 || \\result == 11 || \\result == 22 || \\result == 1";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_5.fct = "pthread_create";
__gen_e_acsl_assert_data_5.line = 230;
+ __gen_e_acsl_assert_data_5.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_5,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_delete_block((void *)(& arg));
@@ -1322,10 +1354,11 @@ int __gen_e_acsl_pthread_cond_wait(pthread_cond_t * restrict cond,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_cond: \\valid(cond)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(cond)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_cond_wait";
__gen_e_acsl_assert_data.line = 203;
+ __gen_e_acsl_assert_data.name = "valid_cond";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -1342,10 +1375,11 @@ int __gen_e_acsl_pthread_cond_wait(pthread_cond_t * restrict cond,
"\\valid(mutex)",0,__gen_e_acsl_valid_2);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "valid_mutex: \\valid(mutex)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid(mutex)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_cond_wait";
__gen_e_acsl_assert_data_2.line = 204;
+ __gen_e_acsl_assert_data_2.name = "valid_mutex";
__e_acsl_assert(__gen_e_acsl_valid_2,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -1357,10 +1391,11 @@ int __gen_e_acsl_pthread_cond_wait(pthread_cond_t * restrict cond,
__retres);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "success: \\result == 0";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_3.fct = "pthread_cond_wait";
__gen_e_acsl_assert_data_3.line = 206;
+ __gen_e_acsl_assert_data_3.name = "success";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_delete_block((void *)(& mutex));
@@ -1401,10 +1436,11 @@ int __gen_e_acsl_pthread_cond_init(pthread_cond_t * restrict cond,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_cond: \\valid(cond)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(cond)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_cond_init";
__gen_e_acsl_assert_data.line = 187;
+ __gen_e_acsl_assert_data.name = "valid_cond";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -1430,10 +1466,11 @@ int __gen_e_acsl_pthread_cond_init(pthread_cond_t * restrict cond,
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "valid_null_attr: attr == \\null || \\valid_read(attr)";
+ __gen_e_acsl_assert_data_2.pred_txt = "attr == \\null || \\valid_read(attr)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_cond_init";
__gen_e_acsl_assert_data_2.line = 188;
+ __gen_e_acsl_assert_data_2.name = "valid_null_attr";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -1455,10 +1492,11 @@ int __gen_e_acsl_pthread_cond_init(pthread_cond_t * restrict cond,
0,__gen_e_acsl_initialized);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: cond: \\initialized(\\old(cond))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\initialized(\\old(cond))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_3.fct = "pthread_cond_init";
__gen_e_acsl_assert_data_3.line = 191;
+ __gen_e_acsl_assert_data_3.name = "initialization/cond";
__e_acsl_assert(__gen_e_acsl_initialized,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -1467,10 +1505,11 @@ int __gen_e_acsl_pthread_cond_init(pthread_cond_t * restrict cond,
__retres);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "success: \\result == 0";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_4.fct = "pthread_cond_init";
__gen_e_acsl_assert_data_4.line = 192;
+ __gen_e_acsl_assert_data_4.name = "success";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_delete_block((void *)(& attr));
@@ -1504,10 +1543,11 @@ int __gen_e_acsl_pthread_cond_broadcast(pthread_cond_t *cond)
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_cond: \\valid(cond)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(cond)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_cond_broadcast";
__gen_e_acsl_assert_data.line = 173;
+ __gen_e_acsl_assert_data.name = "valid_cond";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -1519,10 +1559,11 @@ int __gen_e_acsl_pthread_cond_broadcast(pthread_cond_t *cond)
__retres);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "sucess: \\result == 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_cond_broadcast";
__gen_e_acsl_assert_data_2.line = 175;
+ __gen_e_acsl_assert_data_2.name = "sucess";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_delete_block((void *)(& cond));
diff --git a/src/plugins/e-acsl/tests/concurrency/oracle/gen_sequential_threads.c b/src/plugins/e-acsl/tests/concurrency/oracle/gen_sequential_threads.c
index 7f1c616d434e934b4beb8b79bbc409ce4c68140f..bd02dd0355d18779644cfa6ea9c40c16c4c1ff1d 100644
--- a/src/plugins/e-acsl/tests/concurrency/oracle/gen_sequential_threads.c
+++ b/src/plugins/e-acsl/tests/concurrency/oracle/gen_sequential_threads.c
@@ -99,10 +99,11 @@ void *read_value(void *arg)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_3,"idx",0,idx);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: idx < 10";
+ __gen_e_acsl_assert_data_3.pred_txt = "idx < 10";
__gen_e_acsl_assert_data_3.file = "sequential_threads.c";
__gen_e_acsl_assert_data_3.fct = "read_value";
__gen_e_acsl_assert_data_3.line = 17;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(idx < 10,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -110,10 +111,11 @@ void *read_value(void *arg)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_4,"idx",0,idx);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "index_bound: 0 <= idx";
+ __gen_e_acsl_assert_data_4.pred_txt = "0 <= idx";
__gen_e_acsl_assert_data_4.file = "sequential_threads.c";
__gen_e_acsl_assert_data_4.fct = "read_value";
__gen_e_acsl_assert_data_4.line = 17;
+ __gen_e_acsl_assert_data_4.name = "index_bound";
__e_acsl_assert(0 <= idx,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_2,
@@ -127,10 +129,11 @@ void *read_value(void *arg)
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(values[idx])";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(values[idx])";
__gen_e_acsl_assert_data_2.file = "sequential_threads.c";
__gen_e_acsl_assert_data_2.fct = "read_value";
__gen_e_acsl_assert_data_2.line = 17;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -138,10 +141,11 @@ void *read_value(void *arg)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_5,"idx",0,idx);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "index_bound: idx < 10";
+ __gen_e_acsl_assert_data_5.pred_txt = "idx < 10";
__gen_e_acsl_assert_data_5.file = "sequential_threads.c";
__gen_e_acsl_assert_data_5.fct = "read_value";
__gen_e_acsl_assert_data_5.line = 17;
+ __gen_e_acsl_assert_data_5.name = "index_bound";
__e_acsl_assert(idx < 10,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_6 =
@@ -149,10 +153,11 @@ void *read_value(void *arg)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_6,"idx",0,idx);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "index_bound: 0 <= idx";
+ __gen_e_acsl_assert_data_6.pred_txt = "0 <= idx";
__gen_e_acsl_assert_data_6.file = "sequential_threads.c";
__gen_e_acsl_assert_data_6.fct = "read_value";
__gen_e_acsl_assert_data_6.line = 17;
+ __gen_e_acsl_assert_data_6.name = "index_bound";
__e_acsl_assert(0 <= idx,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__gen_e_acsl_assert_data.blocking = 1;
@@ -222,10 +227,11 @@ int __gen_e_acsl_pthread_join(pthread_t thread, void **retval)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_or_null_retval: retval == \\null || \\valid(retval)";
+ __gen_e_acsl_assert_data.pred_txt = "retval == \\null || \\valid(retval)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_join";
__gen_e_acsl_assert_data.line = 247;
+ __gen_e_acsl_assert_data.name = "valid_or_null_retval";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_contract_set_behavior_assumes(__gen_e_acsl_contract,(size_t)0,
@@ -264,10 +270,11 @@ int __gen_e_acsl_pthread_join(pthread_t thread, void **retval)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "success_or_error:\n \\result == 0 || \\result == 35 || \\result == 22 || \\result == 3";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == 35 || \\result == 22 || \\result == 3";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_join";
__gen_e_acsl_assert_data_2.line = 251;
+ __gen_e_acsl_assert_data_2.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_4,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -315,10 +322,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
"\\valid(thread)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_thread: \\valid(thread)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(thread)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_create";
__gen_e_acsl_assert_data.line = 223;
+ __gen_e_acsl_assert_data.name = "valid_thread";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -344,10 +352,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "valid_null_attr: attr == \\null || \\valid_read(attr)";
+ __gen_e_acsl_assert_data_2.pred_txt = "attr == \\null || \\valid_read(attr)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_create";
__gen_e_acsl_assert_data_2.line = 224;
+ __gen_e_acsl_assert_data_2.name = "valid_null_attr";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -368,10 +377,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Precondition";
- __gen_e_acsl_assert_data_4.pred_txt = "valid_null_arg: arg == \\null || \\valid((char *)arg)";
+ __gen_e_acsl_assert_data_4.pred_txt = "arg == \\null || \\valid((char *)arg)";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_4.fct = "pthread_create";
__gen_e_acsl_assert_data_4.line = 226;
+ __gen_e_acsl_assert_data_4.name = "valid_null_arg";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -404,10 +414,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "success_or_error:\n \\result == 0 || \\result == 11 || \\result == 22 || \\result == 1";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result == 0 || \\result == 11 || \\result == 22 || \\result == 1";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_5.fct = "pthread_create";
__gen_e_acsl_assert_data_5.line = 230;
+ __gen_e_acsl_assert_data_5.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_5,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_delete_block((void *)(& arg));
diff --git a/src/plugins/e-acsl/tests/concurrency/oracle/gen_threads_debug.c b/src/plugins/e-acsl/tests/concurrency/oracle/gen_threads_debug.c
index 5de16ad24bdc0e94a269f0bc95a9dca462817215..4b07a6a1478adaa2271cee811f1d544ef83202a4 100644
--- a/src/plugins/e-acsl/tests/concurrency/oracle/gen_threads_debug.c
+++ b/src/plugins/e-acsl/tests/concurrency/oracle/gen_threads_debug.c
@@ -190,10 +190,11 @@ void *__gen_e_acsl_read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_2.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_2.file = "parallel_threads.c";
__gen_e_acsl_assert_data_2.fct = "read_value";
__gen_e_acsl_assert_data_2.line = 61;
+ __gen_e_acsl_assert_data_2.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -202,10 +203,11 @@ void *__gen_e_acsl_read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_3.file = "parallel_threads.c";
__gen_e_acsl_assert_data_3.fct = "read_value";
__gen_e_acsl_assert_data_3.line = 61;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -230,10 +232,11 @@ void *__gen_e_acsl_read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_4.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_4.file = "parallel_threads.c";
__gen_e_acsl_assert_data_4.fct = "read_value";
__gen_e_acsl_assert_data_4.line = 61;
+ __gen_e_acsl_assert_data_4.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -242,10 +245,11 @@ void *__gen_e_acsl_read_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_5.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_5.file = "parallel_threads.c";
__gen_e_acsl_assert_data_5.fct = "read_value";
__gen_e_acsl_assert_data_5.line = 61;
+ __gen_e_acsl_assert_data_5.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -314,10 +318,11 @@ void *__gen_e_acsl_write_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_2.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_2.file = "parallel_threads.c";
__gen_e_acsl_assert_data_2.fct = "write_value";
__gen_e_acsl_assert_data_2.line = 32;
+ __gen_e_acsl_assert_data_2.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -326,10 +331,11 @@ void *__gen_e_acsl_write_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_3.file = "parallel_threads.c";
__gen_e_acsl_assert_data_3.fct = "write_value";
__gen_e_acsl_assert_data_3.line = 32;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -354,10 +360,11 @@ void *__gen_e_acsl_write_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "index_bound: __gen_e_acsl_idx < 10";
+ __gen_e_acsl_assert_data_4.pred_txt = "__gen_e_acsl_idx < 10";
__gen_e_acsl_assert_data_4.file = "parallel_threads.c";
__gen_e_acsl_assert_data_4.fct = "write_value";
__gen_e_acsl_assert_data_4.line = 32;
+ __gen_e_acsl_assert_data_4.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_idx < 10,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -366,10 +373,11 @@ void *__gen_e_acsl_write_value(void *arg)
"__gen_e_acsl_idx",0,__gen_e_acsl_idx);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "index_bound: 0 <= __gen_e_acsl_idx";
+ __gen_e_acsl_assert_data_5.pred_txt = "0 <= __gen_e_acsl_idx";
__gen_e_acsl_assert_data_5.file = "parallel_threads.c";
__gen_e_acsl_assert_data_5.fct = "write_value";
__gen_e_acsl_assert_data_5.line = 32;
+ __gen_e_acsl_assert_data_5.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_idx,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -421,10 +429,11 @@ int __gen_e_acsl_usleep(useconds_t usec)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "result_ok_or_error: \\result == 0 || \\result == -1";
+ __gen_e_acsl_assert_data.pred_txt = "\\result == 0 || \\result == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/unistd.h";
__gen_e_acsl_assert_data.fct = "usleep";
__gen_e_acsl_assert_data.line = 1119;
+ __gen_e_acsl_assert_data.name = "result_ok_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_delete_block((void *)(& usec));
@@ -446,10 +455,11 @@ void __gen_e_acsl_exit(int status)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "exit";
__gen_e_acsl_assert_data.line = 473;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
__e_acsl_delete_block((void *)(& status));
return;
@@ -494,10 +504,11 @@ int __gen_e_acsl_pthread_mutex_unlock(pthread_mutex_t *mutex)
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "mutex_valid: \\valid(mutex)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(mutex)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_mutex_unlock";
__gen_e_acsl_assert_data.line = 313;
+ __gen_e_acsl_assert_data.name = "mutex_valid";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -516,10 +527,11 @@ int __gen_e_acsl_pthread_mutex_unlock(pthread_mutex_t *mutex)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "success_or_error: \\result == 0 || \\result == 1";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == 1";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_mutex_unlock";
__gen_e_acsl_assert_data_2.line = 316;
+ __gen_e_acsl_assert_data_2.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_delete_block((void *)(& mutex));
@@ -556,10 +568,11 @@ int __gen_e_acsl_pthread_mutex_lock(pthread_mutex_t *mutex)
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "mutex_valid: \\valid(mutex)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(mutex)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_mutex_lock";
__gen_e_acsl_assert_data.line = 295;
+ __gen_e_acsl_assert_data.name = "mutex_valid";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -592,10 +605,11 @@ int __gen_e_acsl_pthread_mutex_lock(pthread_mutex_t *mutex)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "success_or_error:\n \\result == 0 || \\result == 11 || \\result == 22 || \\result == 35";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == 11 || \\result == 22 || \\result == 35";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_mutex_lock";
__gen_e_acsl_assert_data_2.line = 299;
+ __gen_e_acsl_assert_data_2.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_3,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_delete_block((void *)(& mutex));
@@ -638,10 +652,11 @@ int __gen_e_acsl_pthread_mutex_init(pthread_mutex_t * restrict mutex,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "mutex_valid: \\valid(mutex)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(mutex)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_mutex_init";
__gen_e_acsl_assert_data.line = 279;
+ __gen_e_acsl_assert_data.name = "mutex_valid";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -667,10 +682,11 @@ int __gen_e_acsl_pthread_mutex_init(pthread_mutex_t * restrict mutex,
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "attrs_valid_or_null: attrs == \\null || \\valid_read(attrs)";
+ __gen_e_acsl_assert_data_2.pred_txt = "attrs == \\null || \\valid_read(attrs)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_mutex_init";
__gen_e_acsl_assert_data_2.line = 280;
+ __gen_e_acsl_assert_data_2.name = "attrs_valid_or_null";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -727,10 +743,11 @@ int __gen_e_acsl_pthread_mutex_init(pthread_mutex_t * restrict mutex,
}
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: success_or_error:\n (\\result == 0 && \\initialized(\\old(mutex))) || \\result == 11 ||\n \\result == 12 || \\result == 1 || \\result == 22";
+ __gen_e_acsl_assert_data_3.pred_txt = "(\\result == 0 && \\initialized(\\old(mutex))) || \\result == 11 || \\result == 12 ||\n\\result == 1 || \\result == 22";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_3.fct = "pthread_mutex_init";
__gen_e_acsl_assert_data_3.line = 285;
+ __gen_e_acsl_assert_data_3.name = "initialization/success_or_error";
__e_acsl_assert(__gen_e_acsl_or_5,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_delete_block((void *)(& attrs));
@@ -788,10 +805,11 @@ int __gen_e_acsl_pthread_join(pthread_t thread, void **retval)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_or_null_retval: retval == \\null || \\valid(retval)";
+ __gen_e_acsl_assert_data.pred_txt = "retval == \\null || \\valid(retval)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_join";
__gen_e_acsl_assert_data.line = 247;
+ __gen_e_acsl_assert_data.name = "valid_or_null_retval";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_contract_set_behavior_assumes(__gen_e_acsl_contract,(size_t)0,
@@ -830,10 +848,11 @@ int __gen_e_acsl_pthread_join(pthread_t thread, void **retval)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "success_or_error:\n \\result == 0 || \\result == 35 || \\result == 22 || \\result == 3";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == 35 || \\result == 22 || \\result == 3";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_join";
__gen_e_acsl_assert_data_2.line = 251;
+ __gen_e_acsl_assert_data_2.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_4,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -881,10 +900,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
"\\valid(thread)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_thread: \\valid(thread)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(thread)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_create";
__gen_e_acsl_assert_data.line = 223;
+ __gen_e_acsl_assert_data.name = "valid_thread";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -910,10 +930,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "valid_null_attr: attr == \\null || \\valid_read(attr)";
+ __gen_e_acsl_assert_data_2.pred_txt = "attr == \\null || \\valid_read(attr)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_create";
__gen_e_acsl_assert_data_2.line = 224;
+ __gen_e_acsl_assert_data_2.name = "valid_null_attr";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -934,10 +955,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Precondition";
- __gen_e_acsl_assert_data_4.pred_txt = "valid_null_arg: arg == \\null || \\valid((char *)arg)";
+ __gen_e_acsl_assert_data_4.pred_txt = "arg == \\null || \\valid((char *)arg)";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_4.fct = "pthread_create";
__gen_e_acsl_assert_data_4.line = 226;
+ __gen_e_acsl_assert_data_4.name = "valid_null_arg";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -970,10 +992,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "success_or_error:\n \\result == 0 || \\result == 11 || \\result == 22 || \\result == 1";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result == 0 || \\result == 11 || \\result == 22 || \\result == 1";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_5.fct = "pthread_create";
__gen_e_acsl_assert_data_5.line = 230;
+ __gen_e_acsl_assert_data_5.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_5,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_delete_block((void *)(& arg));
@@ -1013,10 +1036,11 @@ int __gen_e_acsl_pthread_cond_wait(pthread_cond_t * restrict cond,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_cond: \\valid(cond)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(cond)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_cond_wait";
__gen_e_acsl_assert_data.line = 203;
+ __gen_e_acsl_assert_data.name = "valid_cond";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -1033,10 +1057,11 @@ int __gen_e_acsl_pthread_cond_wait(pthread_cond_t * restrict cond,
"\\valid(mutex)",0,__gen_e_acsl_valid_2);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "valid_mutex: \\valid(mutex)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid(mutex)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_cond_wait";
__gen_e_acsl_assert_data_2.line = 204;
+ __gen_e_acsl_assert_data_2.name = "valid_mutex";
__e_acsl_assert(__gen_e_acsl_valid_2,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -1048,10 +1073,11 @@ int __gen_e_acsl_pthread_cond_wait(pthread_cond_t * restrict cond,
__retres);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "success: \\result == 0";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_3.fct = "pthread_cond_wait";
__gen_e_acsl_assert_data_3.line = 206;
+ __gen_e_acsl_assert_data_3.name = "success";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_delete_block((void *)(& mutex));
@@ -1092,10 +1118,11 @@ int __gen_e_acsl_pthread_cond_init(pthread_cond_t * restrict cond,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_cond: \\valid(cond)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(cond)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_cond_init";
__gen_e_acsl_assert_data.line = 187;
+ __gen_e_acsl_assert_data.name = "valid_cond";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -1121,10 +1148,11 @@ int __gen_e_acsl_pthread_cond_init(pthread_cond_t * restrict cond,
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "valid_null_attr: attr == \\null || \\valid_read(attr)";
+ __gen_e_acsl_assert_data_2.pred_txt = "attr == \\null || \\valid_read(attr)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_cond_init";
__gen_e_acsl_assert_data_2.line = 188;
+ __gen_e_acsl_assert_data_2.name = "valid_null_attr";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -1146,10 +1174,11 @@ int __gen_e_acsl_pthread_cond_init(pthread_cond_t * restrict cond,
0,__gen_e_acsl_initialized);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: cond: \\initialized(\\old(cond))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\initialized(\\old(cond))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_3.fct = "pthread_cond_init";
__gen_e_acsl_assert_data_3.line = 191;
+ __gen_e_acsl_assert_data_3.name = "initialization/cond";
__e_acsl_assert(__gen_e_acsl_initialized,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -1158,10 +1187,11 @@ int __gen_e_acsl_pthread_cond_init(pthread_cond_t * restrict cond,
__retres);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "success: \\result == 0";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_4.fct = "pthread_cond_init";
__gen_e_acsl_assert_data_4.line = 192;
+ __gen_e_acsl_assert_data_4.name = "success";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_delete_block((void *)(& attr));
@@ -1195,10 +1225,11 @@ int __gen_e_acsl_pthread_cond_broadcast(pthread_cond_t *cond)
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_cond: \\valid(cond)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(cond)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_cond_broadcast";
__gen_e_acsl_assert_data.line = 173;
+ __gen_e_acsl_assert_data.name = "valid_cond";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -1210,10 +1241,11 @@ int __gen_e_acsl_pthread_cond_broadcast(pthread_cond_t *cond)
__retres);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "sucess: \\result == 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_cond_broadcast";
__gen_e_acsl_assert_data_2.line = 175;
+ __gen_e_acsl_assert_data_2.name = "sucess";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_delete_block((void *)(& cond));
diff --git a/src/plugins/e-acsl/tests/concurrency/oracle/gen_threads_safe_locations.c b/src/plugins/e-acsl/tests/concurrency/oracle/gen_threads_safe_locations.c
index 504891d5736895c459fd6a7e1efec8baafee5109..025b3fb3ba9b21ea7af65525383814d002fc43a8 100644
--- a/src/plugins/e-acsl/tests/concurrency/oracle/gen_threads_safe_locations.c
+++ b/src/plugins/e-acsl/tests/concurrency/oracle/gen_threads_safe_locations.c
@@ -276,10 +276,11 @@ int __gen_e_acsl_pthread_join(pthread_t thread, void **retval)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_or_null_retval: retval == \\null || \\valid(retval)";
+ __gen_e_acsl_assert_data.pred_txt = "retval == \\null || \\valid(retval)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_join";
__gen_e_acsl_assert_data.line = 247;
+ __gen_e_acsl_assert_data.name = "valid_or_null_retval";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_contract_set_behavior_assumes(__gen_e_acsl_contract,(size_t)0,
@@ -318,10 +319,11 @@ int __gen_e_acsl_pthread_join(pthread_t thread, void **retval)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "success_or_error:\n \\result == 0 || \\result == 35 || \\result == 22 || \\result == 3";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == 35 || \\result == 22 || \\result == 3";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_join";
__gen_e_acsl_assert_data_2.line = 251;
+ __gen_e_acsl_assert_data_2.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_4,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -369,10 +371,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
"\\valid(thread)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_thread: \\valid(thread)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(thread)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data.fct = "pthread_create";
__gen_e_acsl_assert_data.line = 223;
+ __gen_e_acsl_assert_data.name = "valid_thread";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -398,10 +401,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "valid_null_attr: attr == \\null || \\valid_read(attr)";
+ __gen_e_acsl_assert_data_2.pred_txt = "attr == \\null || \\valid_read(attr)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_2.fct = "pthread_create";
__gen_e_acsl_assert_data_2.line = 224;
+ __gen_e_acsl_assert_data_2.name = "valid_null_attr";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -422,10 +426,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Precondition";
- __gen_e_acsl_assert_data_4.pred_txt = "valid_null_arg: arg == \\null || \\valid((char *)arg)";
+ __gen_e_acsl_assert_data_4.pred_txt = "arg == \\null || \\valid((char *)arg)";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_4.fct = "pthread_create";
__gen_e_acsl_assert_data_4.line = 226;
+ __gen_e_acsl_assert_data_4.name = "valid_null_arg";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -458,10 +463,11 @@ int __gen_e_acsl_pthread_create(pthread_t * restrict thread,
}
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "success_or_error:\n \\result == 0 || \\result == 11 || \\result == 22 || \\result == 1";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result == 0 || \\result == 11 || \\result == 22 || \\result == 1";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/pthread.h";
__gen_e_acsl_assert_data_5.fct = "pthread_create";
__gen_e_acsl_assert_data_5.line = 230;
+ __gen_e_acsl_assert_data_5.name = "success_or_error";
__e_acsl_assert(__gen_e_acsl_or_5,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_delete_block((void *)(& arg));
diff --git a/src/plugins/e-acsl/tests/concurrency/oracle_dev/threads_debug.e-acsl.err.log b/src/plugins/e-acsl/tests/concurrency/oracle_dev/threads_debug.e-acsl.err.log
index b45ae94e6e9788debb50c86503a6b334446fdf17..e338b6d403c5a5e10843cf71d93df93272621992 100644
--- a/src/plugins/e-acsl/tests/concurrency/oracle_dev/threads_debug.e-acsl.err.log
+++ b/src/plugins/e-acsl/tests/concurrency/oracle_dev/threads_debug.e-acsl.err.log
@@ -179,3 +179,4 @@
Application: 2 MB [0x0000-0000-0000, 0x0000-0000-0000]
Primary : 2 MB [0x0000-0000-0000, 0x0000-0000-0000]{ Offset:xxxxx }
Secondary : 2 MB [0x0000-0000-0000, 0x0000-0000-0000]{ Offset:xxxxx }
+ *** WARNING: Leakedxxxbytes of heap memory in 2 blocks
diff --git a/src/plugins/e-acsl/tests/concurrency/threads_debug.c b/src/plugins/e-acsl/tests/concurrency/threads_debug.c
index ff3efa65c7079e0dfd67ff7ffc16802ad76dbf77..8630415fad3675c3412d809501778d4542d7c43a 100644
--- a/src/plugins/e-acsl/tests/concurrency/threads_debug.c
+++ b/src/plugins/e-acsl/tests/concurrency/threads_debug.c
@@ -4,7 +4,7 @@
MACRO: ROOT_EACSL_GCC_OPTS_EXT --rt-debug --rt-verbose --concurrency
COMMENT: Filter the addresses of the output so that the test is deterministic.
- MACRO: ROOT_EACSL_EXEC_FILTER @SEDCMD@ -e s_0x[0-9a-f-]*_0x0000-0000-0000_g | @SEDCMD@ -e s_Offset:\s[0-9-]*_Offset:xxxxx_g | @SEDCMD@ -e s/[0-9]*\skB/xxxkB/g
+ MACRO: ROOT_EACSL_EXEC_FILTER @SEDCMD@ -e s_0x[0-9a-f-]*_0x0000-0000-0000_g | @SEDCMD@ -e s_Offset:\s[0-9-]*_Offset:xxxxx_g | @SEDCMD@ -e s/[0-9]*\skB/xxxkB/g | @SEDCMD@ -e s/Leaked.*bytes/Leakedxxxbytes/g
*/
// Include existing test
diff --git a/src/plugins/e-acsl/tests/constructs/oracle/gen_acsl_check.c b/src/plugins/e-acsl/tests/constructs/oracle/gen_acsl_check.c
index a2d7766cd3504a9883416a671dd37272f3bdb77f..24b9305c4e783385a9808c33cd52ccd89b80a92f 100644
--- a/src/plugins/e-acsl/tests/constructs/oracle/gen_acsl_check.c
+++ b/src/plugins/e-acsl/tests/constructs/oracle/gen_acsl_check.c
@@ -33,10 +33,11 @@ void g(int a, int *b)
*(b + 1));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "division_by_zero: (long)*(b + 1) != 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "(long)*(b + 1) != 0";
__gen_e_acsl_assert_data_2.file = "acsl_check.c";
__gen_e_acsl_assert_data_2.fct = "g";
__gen_e_acsl_assert_data_2.line = 15;
+ __gen_e_acsl_assert_data_2.name = "division_by_zero";
__e_acsl_assert((long)*(b + 1) != 0L,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -49,10 +50,11 @@ void g(int a, int *b)
(void *)(& b));
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(b + 1)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(b + 1)";
__gen_e_acsl_assert_data_3.file = "acsl_check.c";
__gen_e_acsl_assert_data_3.fct = "g";
__gen_e_acsl_assert_data_3.line = 15;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gen_e_acsl_assert_data.blocking = 0;
diff --git a/src/plugins/e-acsl/tests/constructs/oracle/gen_function_contract.c b/src/plugins/e-acsl/tests/constructs/oracle/gen_function_contract.c
index 96c261c12a93e3a1237c3c979ac579d50b3acac4..1cf003981e3405f102571e9fdc71d96845960180 100644
--- a/src/plugins/e-acsl/tests/constructs/oracle/gen_function_contract.c
+++ b/src/plugins/e-acsl/tests/constructs/oracle/gen_function_contract.c
@@ -264,10 +264,11 @@ void __gen_e_acsl_o(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_2,"Y",0,Y);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "neg: Y < 1";
+ __gen_e_acsl_assert_data_2.pred_txt = "Y < 1";
__gen_e_acsl_assert_data_2.file = "function_contract.i";
__gen_e_acsl_assert_data_2.fct = "o";
__gen_e_acsl_assert_data_2.line = 98;
+ __gen_e_acsl_assert_data_2.name = "neg";
__e_acsl_assert(Y < 1,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -279,10 +280,11 @@ void __gen_e_acsl_o(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_3,"Y",0,Y);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "pos: Y > -1";
+ __gen_e_acsl_assert_data_3.pred_txt = "Y > -1";
__gen_e_acsl_assert_data_3.file = "function_contract.i";
__gen_e_acsl_assert_data_3.fct = "o";
__gen_e_acsl_assert_data_3.line = 103;
+ __gen_e_acsl_assert_data_3.name = "pos";
__e_acsl_assert(Y > -1,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
}
@@ -294,10 +296,11 @@ void __gen_e_acsl_o(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_4,"Y",0,Y);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Precondition";
- __gen_e_acsl_assert_data_4.pred_txt = "odd: Y % 2 - 1 == 0";
+ __gen_e_acsl_assert_data_4.pred_txt = "Y % 2 - 1 == 0";
__gen_e_acsl_assert_data_4.file = "function_contract.i";
__gen_e_acsl_assert_data_4.fct = "o";
__gen_e_acsl_assert_data_4.line = 108;
+ __gen_e_acsl_assert_data_4.name = "odd";
__e_acsl_assert(Y % 2 - 1 == 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -309,10 +312,11 @@ void __gen_e_acsl_o(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_5,"Y",0,Y);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Precondition";
- __gen_e_acsl_assert_data_5.pred_txt = "even: Y % 2 + 1 == 1";
+ __gen_e_acsl_assert_data_5.pred_txt = "Y % 2 + 1 == 1";
__gen_e_acsl_assert_data_5.file = "function_contract.i";
__gen_e_acsl_assert_data_5.fct = "o";
__gen_e_acsl_assert_data_5.line = 113;
+ __gen_e_acsl_assert_data_5.name = "even";
__e_acsl_assert(Y % 2 + 1 == 1,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
}
@@ -433,10 +437,11 @@ void __gen_e_acsl_o(void)
0,__gen_e_acsl_at_2);
__gen_e_acsl_assert_data_13.blocking = 1;
__gen_e_acsl_assert_data_13.kind = "Postcondition";
- __gen_e_acsl_assert_data_13.pred_txt = "neg: X == \\old(Y)";
+ __gen_e_acsl_assert_data_13.pred_txt = "X == \\old(Y)";
__gen_e_acsl_assert_data_13.file = "function_contract.i";
__gen_e_acsl_assert_data_13.fct = "o";
__gen_e_acsl_assert_data_13.line = 99;
+ __gen_e_acsl_assert_data_13.name = "neg";
__e_acsl_assert(X == __gen_e_acsl_at_2,& __gen_e_acsl_assert_data_13);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_13);
}
@@ -450,10 +455,11 @@ void __gen_e_acsl_o(void)
0,__gen_e_acsl_at_3);
__gen_e_acsl_assert_data_14.blocking = 1;
__gen_e_acsl_assert_data_14.kind = "Postcondition";
- __gen_e_acsl_assert_data_14.pred_txt = "pos: X == \\old(Y)";
+ __gen_e_acsl_assert_data_14.pred_txt = "X == \\old(Y)";
__gen_e_acsl_assert_data_14.file = "function_contract.i";
__gen_e_acsl_assert_data_14.fct = "o";
__gen_e_acsl_assert_data_14.line = 104;
+ __gen_e_acsl_assert_data_14.name = "pos";
__e_acsl_assert(X == __gen_e_acsl_at_3,& __gen_e_acsl_assert_data_14);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_14);
}
@@ -467,10 +473,11 @@ void __gen_e_acsl_o(void)
0,__gen_e_acsl_at_4);
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "Postcondition";
- __gen_e_acsl_assert_data_15.pred_txt = "odd: X == \\old(Y)";
+ __gen_e_acsl_assert_data_15.pred_txt = "X == \\old(Y)";
__gen_e_acsl_assert_data_15.file = "function_contract.i";
__gen_e_acsl_assert_data_15.fct = "o";
__gen_e_acsl_assert_data_15.line = 109;
+ __gen_e_acsl_assert_data_15.name = "odd";
__e_acsl_assert(X == __gen_e_acsl_at_4,& __gen_e_acsl_assert_data_15);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_15);
}
@@ -484,10 +491,11 @@ void __gen_e_acsl_o(void)
0,__gen_e_acsl_at_5);
__gen_e_acsl_assert_data_16.blocking = 1;
__gen_e_acsl_assert_data_16.kind = "Postcondition";
- __gen_e_acsl_assert_data_16.pred_txt = "even: X == \\old(Y)";
+ __gen_e_acsl_assert_data_16.pred_txt = "X == \\old(Y)";
__gen_e_acsl_assert_data_16.file = "function_contract.i";
__gen_e_acsl_assert_data_16.fct = "o";
__gen_e_acsl_assert_data_16.line = 114;
+ __gen_e_acsl_assert_data_16.name = "even";
__e_acsl_assert(X == __gen_e_acsl_at_5,& __gen_e_acsl_assert_data_16);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_16);
}
@@ -549,10 +557,11 @@ void __gen_e_acsl_n(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_3,"X",0,X);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "b1: X == 8";
+ __gen_e_acsl_assert_data_3.pred_txt = "X == 8";
__gen_e_acsl_assert_data_3.file = "function_contract.i";
__gen_e_acsl_assert_data_3.fct = "n";
__gen_e_acsl_assert_data_3.line = 83;
+ __gen_e_acsl_assert_data_3.name = "b1";
__e_acsl_assert(X == 8,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
}
@@ -564,10 +573,11 @@ void __gen_e_acsl_n(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_4,"X",0,X);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "b2: X == 98";
+ __gen_e_acsl_assert_data_4.pred_txt = "X == 98";
__gen_e_acsl_assert_data_4.file = "function_contract.i";
__gen_e_acsl_assert_data_4.fct = "n";
__gen_e_acsl_assert_data_4.line = 86;
+ __gen_e_acsl_assert_data_4.name = "b2";
__e_acsl_assert(X == 98,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -611,10 +621,11 @@ void __gen_e_acsl_m(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data,"X",0,X);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "b1: X == 95";
+ __gen_e_acsl_assert_data.pred_txt = "X == 95";
__gen_e_acsl_assert_data.file = "function_contract.i";
__gen_e_acsl_assert_data.fct = "m";
__gen_e_acsl_assert_data.line = 68;
+ __gen_e_acsl_assert_data.name = "b1";
__e_acsl_assert(X == 95,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -632,19 +643,21 @@ void __gen_e_acsl_m(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_3,"Y",0,Y);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "b2: X == \\old(X) + Y";
+ __gen_e_acsl_assert_data_3.pred_txt = "X == \\old(X) + Y";
__gen_e_acsl_assert_data_3.file = "function_contract.i";
__gen_e_acsl_assert_data_3.fct = "m";
__gen_e_acsl_assert_data_3.line = 73;
+ __gen_e_acsl_assert_data_3.name = "b2";
__e_acsl_assert((long)X == __gen_e_acsl_at + Y,
& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "b2: X == 7";
+ __gen_e_acsl_assert_data_2.pred_txt = "X == 7";
__gen_e_acsl_assert_data_2.file = "function_contract.i";
__gen_e_acsl_assert_data_2.fct = "m";
__gen_e_acsl_assert_data_2.line = 72;
+ __gen_e_acsl_assert_data_2.name = "b2";
__e_acsl_assert(X == 7,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -703,10 +716,11 @@ void __gen_e_acsl_k(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data,"X",0,X);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "b1: X == 0";
+ __gen_e_acsl_assert_data.pred_txt = "X == 0";
__gen_e_acsl_assert_data.file = "function_contract.i";
__gen_e_acsl_assert_data.fct = "k";
__gen_e_acsl_assert_data.line = 48;
+ __gen_e_acsl_assert_data.name = "b1";
__e_acsl_assert(X == 0,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -722,18 +736,20 @@ void __gen_e_acsl_k(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_3,"Y",0,Y);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "b2: X + Y == 5";
+ __gen_e_acsl_assert_data_3.pred_txt = "X + Y == 5";
__gen_e_acsl_assert_data_3.file = "function_contract.i";
__gen_e_acsl_assert_data_3.fct = "k";
__gen_e_acsl_assert_data_3.line = 53;
+ __gen_e_acsl_assert_data_3.name = "b2";
__e_acsl_assert(X + (long)Y == 5L,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "b2: X == 3";
+ __gen_e_acsl_assert_data_2.pred_txt = "X == 3";
__gen_e_acsl_assert_data_2.file = "function_contract.i";
__gen_e_acsl_assert_data_2.fct = "k";
__gen_e_acsl_assert_data_2.line = 52;
+ __gen_e_acsl_assert_data_2.name = "b2";
__e_acsl_assert(X == 3,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -768,10 +784,11 @@ void __gen_e_acsl_j(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data,"X",0,X);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "b1: X == 5";
+ __gen_e_acsl_assert_data.pred_txt = "X == 5";
__gen_e_acsl_assert_data.file = "function_contract.i";
__gen_e_acsl_assert_data.fct = "j";
__gen_e_acsl_assert_data.line = 35;
+ __gen_e_acsl_assert_data.name = "b1";
__e_acsl_assert(X == 5,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -787,18 +804,20 @@ void __gen_e_acsl_j(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_3,"Y",0,Y);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "b2: Y == 2";
+ __gen_e_acsl_assert_data_3.pred_txt = "Y == 2";
__gen_e_acsl_assert_data_3.file = "function_contract.i";
__gen_e_acsl_assert_data_3.fct = "j";
__gen_e_acsl_assert_data_3.line = 39;
+ __gen_e_acsl_assert_data_3.name = "b2";
__e_acsl_assert(Y == 2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "b2: X == 3 + Y";
+ __gen_e_acsl_assert_data_2.pred_txt = "X == 3 + Y";
__gen_e_acsl_assert_data_2.file = "function_contract.i";
__gen_e_acsl_assert_data_2.fct = "j";
__gen_e_acsl_assert_data_2.line = 38;
+ __gen_e_acsl_assert_data_2.name = "b2";
__e_acsl_assert((long)X == 3L + Y,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -814,10 +833,11 @@ void __gen_e_acsl_j(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_4,"X",0,X);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "b1: X == 3";
+ __gen_e_acsl_assert_data_4.pred_txt = "X == 3";
__gen_e_acsl_assert_data_4.file = "function_contract.i";
__gen_e_acsl_assert_data_4.fct = "j";
__gen_e_acsl_assert_data_4.line = 36;
+ __gen_e_acsl_assert_data_4.name = "b1";
__e_acsl_assert(X == 3,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -830,10 +850,11 @@ void __gen_e_acsl_j(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_5,"Y",0,Y);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "b2: X == Y + 1";
+ __gen_e_acsl_assert_data_5.pred_txt = "X == Y + 1";
__gen_e_acsl_assert_data_5.file = "function_contract.i";
__gen_e_acsl_assert_data_5.fct = "j";
__gen_e_acsl_assert_data_5.line = 40;
+ __gen_e_acsl_assert_data_5.name = "b2";
__e_acsl_assert((long)X == Y + 1L,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
}
diff --git a/src/plugins/e-acsl/tests/constructs/oracle/gen_ghost.c b/src/plugins/e-acsl/tests/constructs/oracle/gen_ghost.c
index 8b56c962f015d149c61123a5496c474503f04638..182446f1eafb675f195411c4b2ba7962a90fbee2 100644
--- a/src/plugins/e-acsl/tests/constructs/oracle/gen_ghost.c
+++ b/src/plugins/e-acsl/tests/constructs/oracle/gen_ghost.c
@@ -51,10 +51,11 @@ int main(void)
(void *)P,(void *)(& P));
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "RTE";
- __gen_e_acsl_assert_data.pred_txt = "mem_access: \\valid_read(P)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid_read(P)";
__gen_e_acsl_assert_data.file = "ghost.i";
__gen_e_acsl_assert_data.fct = "main";
__gen_e_acsl_assert_data.line = 13;
+ __gen_e_acsl_assert_data.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -66,10 +67,11 @@ int main(void)
(void *)(& P));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid(P)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid(P)";
__gen_e_acsl_assert_data_2.file = "ghost.i";
__gen_e_acsl_assert_data_2.fct = "main";
__gen_e_acsl_assert_data_2.line = 13;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -103,10 +105,11 @@ int main(void)
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "mem_access: \\valid_read(q)";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(q)";
__gen_e_acsl_assert_data_4.file = "ghost.i";
__gen_e_acsl_assert_data_4.fct = "main";
__gen_e_acsl_assert_data_4.line = 14;
+ __gen_e_acsl_assert_data_4.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_assert_data_3.blocking = 1;
diff --git a/src/plugins/e-acsl/tests/constructs/oracle/gen_lazy.c b/src/plugins/e-acsl/tests/constructs/oracle/gen_lazy.c
index c2bef02ac47ab5bffefc44d73e9757a4e711b171..daa81b382920eadd2bfcfd1e6411b5533a0f85d1 100644
--- a/src/plugins/e-acsl/tests/constructs/oracle/gen_lazy.c
+++ b/src/plugins/e-acsl/tests/constructs/oracle/gen_lazy.c
@@ -44,10 +44,11 @@ int main(void)
{.values = (void *)0};
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "division_by_zero: 0 != 0";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 != 0";
__gen_e_acsl_assert_data_3.file = "lazy.i";
__gen_e_acsl_assert_data_3.fct = "main";
__gen_e_acsl_assert_data_3.line = 10;
+ __gen_e_acsl_assert_data_3.name = "division_by_zero";
__e_acsl_assert(0,& __gen_e_acsl_assert_data_3);
__gen_e_acsl_and_2 = y == 1 / 0;
}
@@ -94,10 +95,11 @@ int main(void)
{.values = (void *)0};
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "division_by_zero: 0 != 0";
+ __gen_e_acsl_assert_data_6.pred_txt = "0 != 0";
__gen_e_acsl_assert_data_6.file = "lazy.i";
__gen_e_acsl_assert_data_6.fct = "main";
__gen_e_acsl_assert_data_6.line = 12;
+ __gen_e_acsl_assert_data_6.name = "division_by_zero";
__e_acsl_assert(0,& __gen_e_acsl_assert_data_6);
__gen_e_acsl_or_2 = y == 1 / 0;
}
@@ -143,10 +145,11 @@ int main(void)
{.values = (void *)0};
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "division_by_zero: 0 != 0";
+ __gen_e_acsl_assert_data_9.pred_txt = "0 != 0";
__gen_e_acsl_assert_data_9.file = "lazy.i";
__gen_e_acsl_assert_data_9.fct = "main";
__gen_e_acsl_assert_data_9.line = 14;
+ __gen_e_acsl_assert_data_9.name = "division_by_zero";
__e_acsl_assert(0,& __gen_e_acsl_assert_data_9);
__gen_e_acsl_implies_2 = y == 1 / 0;
}
diff --git a/src/plugins/e-acsl/tests/constructs/oracle/gen_loop.c b/src/plugins/e-acsl/tests/constructs/oracle/gen_loop.c
index 54814a5b538a77adeaf47984e095a9877007f242..3277c9121c0013e0006ef1c9ab35c200fdd5532f 100644
--- a/src/plugins/e-acsl/tests/constructs/oracle/gen_loop.c
+++ b/src/plugins/e-acsl/tests/constructs/oracle/gen_loop.c
@@ -107,10 +107,11 @@ void nested_loops(void)
"__gen_e_acsl_l",0,__gen_e_acsl_l);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: __gen_e_acsl_l < 8";
+ __gen_e_acsl_assert_data_3.pred_txt = "__gen_e_acsl_l < 8";
__gen_e_acsl_assert_data_3.file = "loop.i";
__gen_e_acsl_assert_data_3.fct = "nested_loops";
__gen_e_acsl_assert_data_3.line = 19;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_l < 8,
& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
@@ -120,10 +121,11 @@ void nested_loops(void)
"__gen_e_acsl_l",0,__gen_e_acsl_l);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "index_bound: 0 <= __gen_e_acsl_l";
+ __gen_e_acsl_assert_data_4.pred_txt = "0 <= __gen_e_acsl_l";
__gen_e_acsl_assert_data_4.file = "loop.i";
__gen_e_acsl_assert_data_4.fct = "nested_loops";
__gen_e_acsl_assert_data_4.line = 19;
+ __gen_e_acsl_assert_data_4.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_l,
& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
@@ -133,10 +135,11 @@ void nested_loops(void)
"__gen_e_acsl_k",0,__gen_e_acsl_k);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "index_bound: __gen_e_acsl_k < 4";
+ __gen_e_acsl_assert_data_5.pred_txt = "__gen_e_acsl_k < 4";
__gen_e_acsl_assert_data_5.file = "loop.i";
__gen_e_acsl_assert_data_5.fct = "nested_loops";
__gen_e_acsl_assert_data_5.line = 19;
+ __gen_e_acsl_assert_data_5.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_k < 4,
& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
@@ -146,10 +149,11 @@ void nested_loops(void)
"__gen_e_acsl_k",0,__gen_e_acsl_k);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "index_bound: 0 <= __gen_e_acsl_k";
+ __gen_e_acsl_assert_data_6.pred_txt = "0 <= __gen_e_acsl_k";
__gen_e_acsl_assert_data_6.file = "loop.i";
__gen_e_acsl_assert_data_6.fct = "nested_loops";
__gen_e_acsl_assert_data_6.line = 19;
+ __gen_e_acsl_assert_data_6.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_k,
& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
@@ -240,10 +244,11 @@ void nested_loops(void)
__gen_e_acsl_l_2);
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "index_bound: __gen_e_acsl_l_2 < 8";
+ __gen_e_acsl_assert_data_10.pred_txt = "__gen_e_acsl_l_2 < 8";
__gen_e_acsl_assert_data_10.file = "loop.i";
__gen_e_acsl_assert_data_10.fct = "nested_loops";
__gen_e_acsl_assert_data_10.line = 19;
+ __gen_e_acsl_assert_data_10.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_l_2 < 8,
& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
@@ -254,10 +259,11 @@ void nested_loops(void)
__gen_e_acsl_l_2);
__gen_e_acsl_assert_data_11.blocking = 1;
__gen_e_acsl_assert_data_11.kind = "RTE";
- __gen_e_acsl_assert_data_11.pred_txt = "index_bound: 0 <= __gen_e_acsl_l_2";
+ __gen_e_acsl_assert_data_11.pred_txt = "0 <= __gen_e_acsl_l_2";
__gen_e_acsl_assert_data_11.file = "loop.i";
__gen_e_acsl_assert_data_11.fct = "nested_loops";
__gen_e_acsl_assert_data_11.line = 19;
+ __gen_e_acsl_assert_data_11.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_l_2,
& __gen_e_acsl_assert_data_11);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_11);
@@ -268,10 +274,11 @@ void nested_loops(void)
__gen_e_acsl_k_2);
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "index_bound: __gen_e_acsl_k_2 < 4";
+ __gen_e_acsl_assert_data_12.pred_txt = "__gen_e_acsl_k_2 < 4";
__gen_e_acsl_assert_data_12.file = "loop.i";
__gen_e_acsl_assert_data_12.fct = "nested_loops";
__gen_e_acsl_assert_data_12.line = 19;
+ __gen_e_acsl_assert_data_12.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_k_2 < 4,
& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
@@ -282,10 +289,11 @@ void nested_loops(void)
__gen_e_acsl_k_2);
__gen_e_acsl_assert_data_13.blocking = 1;
__gen_e_acsl_assert_data_13.kind = "RTE";
- __gen_e_acsl_assert_data_13.pred_txt = "index_bound: 0 <= __gen_e_acsl_k_2";
+ __gen_e_acsl_assert_data_13.pred_txt = "0 <= __gen_e_acsl_k_2";
__gen_e_acsl_assert_data_13.file = "loop.i";
__gen_e_acsl_assert_data_13.fct = "nested_loops";
__gen_e_acsl_assert_data_13.line = 19;
+ __gen_e_acsl_assert_data_13.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_k_2,
& __gen_e_acsl_assert_data_13);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_13);
diff --git a/src/plugins/e-acsl/tests/constructs/oracle/gen_rte.c b/src/plugins/e-acsl/tests/constructs/oracle/gen_rte.c
index 24275e968184d862756130fdadacff599656bb9a..d541359143b02d5e336ac2d54af2faa7864a2451 100644
--- a/src/plugins/e-acsl/tests/constructs/oracle/gen_rte.c
+++ b/src/plugins/e-acsl/tests/constructs/oracle/gen_rte.c
@@ -69,10 +69,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_2,"a",0,a);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "division_by_zero: a != 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "a != 0";
__gen_e_acsl_assert_data_2.file = "rte.i";
__gen_e_acsl_assert_data_2.fct = "test";
__gen_e_acsl_assert_data_2.line = 7;
+ __gen_e_acsl_assert_data_2.name = "division_by_zero";
__e_acsl_assert(a != 0,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_assert_data.blocking = 1;
@@ -88,10 +89,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_3,"c",0,c);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "division_by_zero: c != 0";
+ __gen_e_acsl_assert_data_3.pred_txt = "c != 0";
__gen_e_acsl_assert_data_3.file = "rte.i";
__gen_e_acsl_assert_data_3.fct = "test";
__gen_e_acsl_assert_data_3.line = 11;
+ __gen_e_acsl_assert_data_3.name = "division_by_zero";
__e_acsl_assert(c != 0,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_contract_set_behavior_assumes(__gen_e_acsl_contract,(size_t)0,
@@ -114,10 +116,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_5,"d",0,d);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "division_by_zero: d != 0";
+ __gen_e_acsl_assert_data_5.pred_txt = "d != 0";
__gen_e_acsl_assert_data_5.file = "rte.i";
__gen_e_acsl_assert_data_5.fct = "test";
__gen_e_acsl_assert_data_5.line = 12;
+ __gen_e_acsl_assert_data_5.name = "division_by_zero";
__e_acsl_assert(d != 0,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_6 =
@@ -128,10 +131,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_7,"f",0,f);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "division_by_zero: f != 0";
+ __gen_e_acsl_assert_data_7.pred_txt = "f != 0";
__gen_e_acsl_assert_data_7.file = "rte.i";
__gen_e_acsl_assert_data_7.fct = "test";
__gen_e_acsl_assert_data_7.line = 13;
+ __gen_e_acsl_assert_data_7.name = "division_by_zero";
__e_acsl_assert(f != 0,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
if (1 % f == 1) __gen_e_acsl_or = 1;
@@ -142,10 +146,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_8,"g",0,g);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "division_by_zero: g != 0";
+ __gen_e_acsl_assert_data_8.pred_txt = "g != 0";
__gen_e_acsl_assert_data_8.file = "rte.i";
__gen_e_acsl_assert_data_8.fct = "test";
__gen_e_acsl_assert_data_8.line = 13;
+ __gen_e_acsl_assert_data_8.name = "division_by_zero";
__e_acsl_assert(g != 0,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__gen_e_acsl_or = 1 % g == 1;
@@ -158,10 +163,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_10,"h",0,h);
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "division_by_zero: h != 0";
+ __gen_e_acsl_assert_data_10.pred_txt = "h != 0";
__gen_e_acsl_assert_data_10.file = "rte.i";
__gen_e_acsl_assert_data_10.fct = "test";
__gen_e_acsl_assert_data_10.line = 14;
+ __gen_e_acsl_assert_data_10.name = "division_by_zero";
__e_acsl_assert(h != 0,& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
if (1 % h == 1) {
@@ -171,10 +177,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_11,"i",0,i);
__gen_e_acsl_assert_data_11.blocking = 1;
__gen_e_acsl_assert_data_11.kind = "RTE";
- __gen_e_acsl_assert_data_11.pred_txt = "division_by_zero: i != 0";
+ __gen_e_acsl_assert_data_11.pred_txt = "i != 0";
__gen_e_acsl_assert_data_11.file = "rte.i";
__gen_e_acsl_assert_data_11.fct = "test";
__gen_e_acsl_assert_data_11.line = 14;
+ __gen_e_acsl_assert_data_11.name = "division_by_zero";
__e_acsl_assert(i != 0,& __gen_e_acsl_assert_data_11);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_11);
__gen_e_acsl_and = 1 % i == 1;
@@ -191,10 +198,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_13,"j",0,j);
__gen_e_acsl_assert_data_13.blocking = 1;
__gen_e_acsl_assert_data_13.kind = "RTE";
- __gen_e_acsl_assert_data_13.pred_txt = "division_by_zero: j != 0";
+ __gen_e_acsl_assert_data_13.pred_txt = "j != 0";
__gen_e_acsl_assert_data_13.file = "rte.i";
__gen_e_acsl_assert_data_13.fct = "test";
__gen_e_acsl_assert_data_13.line = 15;
+ __gen_e_acsl_assert_data_13.name = "division_by_zero";
__e_acsl_assert(j != 0,& __gen_e_acsl_assert_data_13);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_13);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_14 =
@@ -209,10 +217,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_15,"k",0,k);
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "RTE";
- __gen_e_acsl_assert_data_15.pred_txt = "division_by_zero: k != 0";
+ __gen_e_acsl_assert_data_15.pred_txt = "k != 0";
__gen_e_acsl_assert_data_15.file = "rte.i";
__gen_e_acsl_assert_data_15.fct = "test";
__gen_e_acsl_assert_data_15.line = 16;
+ __gen_e_acsl_assert_data_15.name = "division_by_zero";
__e_acsl_assert(k != 0,& __gen_e_acsl_assert_data_15);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_15);
if (__gen_e_acsl_var_2 % k == __gen_e_acsl_var_2) ;
@@ -239,10 +248,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_17,"l",0,l);
__gen_e_acsl_assert_data_17.blocking = 1;
__gen_e_acsl_assert_data_17.kind = "RTE";
- __gen_e_acsl_assert_data_17.pred_txt = "division_by_zero: l != 0";
+ __gen_e_acsl_assert_data_17.pred_txt = "l != 0";
__gen_e_acsl_assert_data_17.file = "rte.i";
__gen_e_acsl_assert_data_17.fct = "test";
__gen_e_acsl_assert_data_17.line = 17;
+ __gen_e_acsl_assert_data_17.name = "division_by_zero";
__e_acsl_assert(l != 0,& __gen_e_acsl_assert_data_17);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_17);
if (! (__gen_e_acsl_var_3 % l == __gen_e_acsl_var_3)) ;
@@ -259,51 +269,57 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
0,__gen_e_acsl_exists);
__gen_e_acsl_assert_data_16.blocking = 1;
__gen_e_acsl_assert_data_16.kind = "Precondition";
- __gen_e_acsl_assert_data_16.pred_txt = "bhvr: \\exists integer var; 0 <= var < l && var % l == var";
+ __gen_e_acsl_assert_data_16.pred_txt = "\\exists integer var; 0 <= var < l && var % l == var";
__gen_e_acsl_assert_data_16.file = "rte.i";
__gen_e_acsl_assert_data_16.fct = "test";
__gen_e_acsl_assert_data_16.line = 17;
+ __gen_e_acsl_assert_data_16.name = "bhvr";
__e_acsl_assert(__gen_e_acsl_exists,& __gen_e_acsl_assert_data_16);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_16);
__gen_e_acsl_assert_data_14.blocking = 1;
__gen_e_acsl_assert_data_14.kind = "Precondition";
- __gen_e_acsl_assert_data_14.pred_txt = "bhvr: \\forall integer var; 0 <= var < k ==> var % k == var";
+ __gen_e_acsl_assert_data_14.pred_txt = "\\forall integer var; 0 <= var < k ==> var % k == var";
__gen_e_acsl_assert_data_14.file = "rte.i";
__gen_e_acsl_assert_data_14.fct = "test";
__gen_e_acsl_assert_data_14.line = 16;
+ __gen_e_acsl_assert_data_14.name = "bhvr";
__e_acsl_assert(__gen_e_acsl_forall,& __gen_e_acsl_assert_data_14);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_14);
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "Precondition";
- __gen_e_acsl_assert_data_12.pred_txt = "bhvr: \\let var = 1; var % j == 1";
+ __gen_e_acsl_assert_data_12.pred_txt = "\\let var = 1; var % j == 1";
__gen_e_acsl_assert_data_12.file = "rte.i";
__gen_e_acsl_assert_data_12.fct = "test";
__gen_e_acsl_assert_data_12.line = 15;
+ __gen_e_acsl_assert_data_12.name = "bhvr";
__e_acsl_assert(__gen_e_acsl_var % j == 1,
& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "Precondition";
- __gen_e_acsl_assert_data_9.pred_txt = "bhvr: 1 % h == 1 && 1 % i == 1";
+ __gen_e_acsl_assert_data_9.pred_txt = "1 % h == 1 && 1 % i == 1";
__gen_e_acsl_assert_data_9.file = "rte.i";
__gen_e_acsl_assert_data_9.fct = "test";
__gen_e_acsl_assert_data_9.line = 14;
+ __gen_e_acsl_assert_data_9.name = "bhvr";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "Precondition";
- __gen_e_acsl_assert_data_6.pred_txt = "bhvr: 1 % f == 1 || 1 % g == 1";
+ __gen_e_acsl_assert_data_6.pred_txt = "1 % f == 1 || 1 % g == 1";
__gen_e_acsl_assert_data_6.file = "rte.i";
__gen_e_acsl_assert_data_6.fct = "test";
__gen_e_acsl_assert_data_6.line = 13;
+ __gen_e_acsl_assert_data_6.name = "bhvr";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Precondition";
- __gen_e_acsl_assert_data_4.pred_txt = "bhvr: 1 % d == 1";
+ __gen_e_acsl_assert_data_4.pred_txt = "1 % d == 1";
__gen_e_acsl_assert_data_4.file = "rte.i";
__gen_e_acsl_assert_data_4.fct = "test";
__gen_e_acsl_assert_data_4.line = 12;
+ __gen_e_acsl_assert_data_4.name = "bhvr";
__e_acsl_assert(1 % d == 1,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -323,10 +339,11 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
"__gen_e_acsl_at",0,__gen_e_acsl_at);
__gen_e_acsl_assert_data_19.blocking = 1;
__gen_e_acsl_assert_data_19.kind = "RTE";
- __gen_e_acsl_assert_data_19.pred_txt = "division_by_zero: __gen_e_acsl_at != 0";
+ __gen_e_acsl_assert_data_19.pred_txt = "__gen_e_acsl_at != 0";
__gen_e_acsl_assert_data_19.file = "rte.i";
__gen_e_acsl_assert_data_19.fct = "test";
__gen_e_acsl_assert_data_19.line = 8;
+ __gen_e_acsl_assert_data_19.name = "division_by_zero";
__e_acsl_assert(__gen_e_acsl_at != 0,& __gen_e_acsl_assert_data_19);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_19);
__gen_e_acsl_assert_data_18.blocking = 1;
@@ -350,18 +367,20 @@ void __gen_e_acsl_test(int a, int b, int c, int d, int e, int f, int g,
"__gen_e_acsl_at_2",0,__gen_e_acsl_at_2);
__gen_e_acsl_assert_data_21.blocking = 1;
__gen_e_acsl_assert_data_21.kind = "RTE";
- __gen_e_acsl_assert_data_21.pred_txt = "division_by_zero: __gen_e_acsl_at_2 != 0";
+ __gen_e_acsl_assert_data_21.pred_txt = "__gen_e_acsl_at_2 != 0";
__gen_e_acsl_assert_data_21.file = "rte.i";
__gen_e_acsl_assert_data_21.fct = "test";
__gen_e_acsl_assert_data_21.line = 18;
+ __gen_e_acsl_assert_data_21.name = "division_by_zero";
__e_acsl_assert(__gen_e_acsl_at_2 != 0,& __gen_e_acsl_assert_data_21);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_21);
__gen_e_acsl_assert_data_20.blocking = 1;
__gen_e_acsl_assert_data_20.kind = "Postcondition";
- __gen_e_acsl_assert_data_20.pred_txt = "bhvr: 1 % \\old(e) == 1";
+ __gen_e_acsl_assert_data_20.pred_txt = "1 % \\old(e) == 1";
__gen_e_acsl_assert_data_20.file = "rte.i";
__gen_e_acsl_assert_data_20.fct = "test";
__gen_e_acsl_assert_data_20.line = 18;
+ __gen_e_acsl_assert_data_20.name = "bhvr";
__e_acsl_assert(1 % __gen_e_acsl_at_2 == 1,
& __gen_e_acsl_assert_data_20);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_20);
diff --git a/src/plugins/e-acsl/tests/constructs/oracle/gen_stmt_contract.c b/src/plugins/e-acsl/tests/constructs/oracle/gen_stmt_contract.c
index 38f76c10b3783e62d17e74e331013959a755f086..e13f6933a714b7ca16dccf5892f3cbe45b753e7a 100644
--- a/src/plugins/e-acsl/tests/constructs/oracle/gen_stmt_contract.c
+++ b/src/plugins/e-acsl/tests/constructs/oracle/gen_stmt_contract.c
@@ -136,10 +136,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_8,"x",0,x);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "Precondition";
- __gen_e_acsl_assert_data_8.pred_txt = "b1: x == 5";
+ __gen_e_acsl_assert_data_8.pred_txt = "x == 5";
__gen_e_acsl_assert_data_8.file = "stmt_contract.i";
__gen_e_acsl_assert_data_8.fct = "main";
__gen_e_acsl_assert_data_8.line = 25;
+ __gen_e_acsl_assert_data_8.name = "b1";
__e_acsl_assert(x == 5,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
}
@@ -155,18 +156,20 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_10,"y",0,y);
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "Precondition";
- __gen_e_acsl_assert_data_10.pred_txt = "b2: y == 2";
+ __gen_e_acsl_assert_data_10.pred_txt = "y == 2";
__gen_e_acsl_assert_data_10.file = "stmt_contract.i";
__gen_e_acsl_assert_data_10.fct = "main";
__gen_e_acsl_assert_data_10.line = 29;
+ __gen_e_acsl_assert_data_10.name = "b2";
__e_acsl_assert(y == 2,& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "Precondition";
- __gen_e_acsl_assert_data_9.pred_txt = "b2: x == 3 + y";
+ __gen_e_acsl_assert_data_9.pred_txt = "x == 3 + y";
__gen_e_acsl_assert_data_9.file = "stmt_contract.i";
__gen_e_acsl_assert_data_9.fct = "main";
__gen_e_acsl_assert_data_9.line = 28;
+ __gen_e_acsl_assert_data_9.name = "b2";
__e_acsl_assert((long)x == 3L + y,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
}
@@ -189,10 +192,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_11,"x",0,x);
__gen_e_acsl_assert_data_11.blocking = 1;
__gen_e_acsl_assert_data_11.kind = "Postcondition";
- __gen_e_acsl_assert_data_11.pred_txt = "b1: x == 3";
+ __gen_e_acsl_assert_data_11.pred_txt = "x == 3";
__gen_e_acsl_assert_data_11.file = "stmt_contract.i";
__gen_e_acsl_assert_data_11.fct = "main";
__gen_e_acsl_assert_data_11.line = 26;
+ __gen_e_acsl_assert_data_11.name = "b1";
__e_acsl_assert(x == 3,& __gen_e_acsl_assert_data_11);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_11);
}
@@ -205,10 +209,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_12,"y",0,y);
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "Postcondition";
- __gen_e_acsl_assert_data_12.pred_txt = "b2: x == y + 1";
+ __gen_e_acsl_assert_data_12.pred_txt = "x == y + 1";
__gen_e_acsl_assert_data_12.file = "stmt_contract.i";
__gen_e_acsl_assert_data_12.fct = "main";
__gen_e_acsl_assert_data_12.line = 30;
+ __gen_e_acsl_assert_data_12.name = "b2";
__e_acsl_assert((long)x == y + 1L,& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
}
@@ -231,10 +236,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_13,"x",0,x);
__gen_e_acsl_assert_data_13.blocking = 1;
__gen_e_acsl_assert_data_13.kind = "Precondition";
- __gen_e_acsl_assert_data_13.pred_txt = "b1: x == 0";
+ __gen_e_acsl_assert_data_13.pred_txt = "x == 0";
__gen_e_acsl_assert_data_13.file = "stmt_contract.i";
__gen_e_acsl_assert_data_13.fct = "main";
__gen_e_acsl_assert_data_13.line = 35;
+ __gen_e_acsl_assert_data_13.name = "b1";
__e_acsl_assert(x == 0,& __gen_e_acsl_assert_data_13);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_13);
}
@@ -250,18 +256,20 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_15,"y",0,y);
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "Precondition";
- __gen_e_acsl_assert_data_15.pred_txt = "b2: x + y == 5";
+ __gen_e_acsl_assert_data_15.pred_txt = "x + y == 5";
__gen_e_acsl_assert_data_15.file = "stmt_contract.i";
__gen_e_acsl_assert_data_15.fct = "main";
__gen_e_acsl_assert_data_15.line = 40;
+ __gen_e_acsl_assert_data_15.name = "b2";
__e_acsl_assert(x + (long)y == 5L,& __gen_e_acsl_assert_data_15);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_15);
__gen_e_acsl_assert_data_14.blocking = 1;
__gen_e_acsl_assert_data_14.kind = "Precondition";
- __gen_e_acsl_assert_data_14.pred_txt = "b2: x == 3";
+ __gen_e_acsl_assert_data_14.pred_txt = "x == 3";
__gen_e_acsl_assert_data_14.file = "stmt_contract.i";
__gen_e_acsl_assert_data_14.fct = "main";
__gen_e_acsl_assert_data_14.line = 39;
+ __gen_e_acsl_assert_data_14.name = "b2";
__e_acsl_assert(x == 3,& __gen_e_acsl_assert_data_14);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_14);
}
@@ -398,10 +406,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_22,"x",0,x);
__gen_e_acsl_assert_data_22.blocking = 1;
__gen_e_acsl_assert_data_22.kind = "Postcondition";
- __gen_e_acsl_assert_data_22.pred_txt = "pos: z == x";
+ __gen_e_acsl_assert_data_22.pred_txt = "z == x";
__gen_e_acsl_assert_data_22.file = "stmt_contract.i";
__gen_e_acsl_assert_data_22.fct = "main";
__gen_e_acsl_assert_data_22.line = 55;
+ __gen_e_acsl_assert_data_22.name = "pos";
__e_acsl_assert(z == x,& __gen_e_acsl_assert_data_22);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_22);
}
@@ -414,10 +423,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_23,"x",0,x);
__gen_e_acsl_assert_data_23.blocking = 1;
__gen_e_acsl_assert_data_23.kind = "Postcondition";
- __gen_e_acsl_assert_data_23.pred_txt = "neg: z == -x";
+ __gen_e_acsl_assert_data_23.pred_txt = "z == -x";
__gen_e_acsl_assert_data_23.file = "stmt_contract.i";
__gen_e_acsl_assert_data_23.fct = "main";
__gen_e_acsl_assert_data_23.line = 59;
+ __gen_e_acsl_assert_data_23.name = "neg";
__e_acsl_assert((long)z == - ((long)x),& __gen_e_acsl_assert_data_23);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_23);
}
diff --git a/src/plugins/e-acsl/tests/examples/oracle/gen_linear_search.c b/src/plugins/e-acsl/tests/examples/oracle/gen_linear_search.c
index f390ae24347c9fd48b076756cd1f06a8811c30c2..dfad48ef0b898528e819ea327ebd631801fe31c8 100644
--- a/src/plugins/e-acsl/tests/examples/oracle/gen_linear_search.c
+++ b/src/plugins/e-acsl/tests/examples/oracle/gen_linear_search.c
@@ -42,10 +42,11 @@ int search(int elt)
"__gen_e_acsl_i",0,__gen_e_acsl_i);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "index_bound: __gen_e_acsl_i < 10";
+ __gen_e_acsl_assert_data_2.pred_txt = "__gen_e_acsl_i < 10";
__gen_e_acsl_assert_data_2.file = "linear_search.i";
__gen_e_acsl_assert_data_2.fct = "search";
__gen_e_acsl_assert_data_2.line = 18;
+ __gen_e_acsl_assert_data_2.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_i < 10,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -54,10 +55,11 @@ int search(int elt)
"__gen_e_acsl_i",0,__gen_e_acsl_i);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: 0 <= __gen_e_acsl_i";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= __gen_e_acsl_i";
__gen_e_acsl_assert_data_3.file = "linear_search.i";
__gen_e_acsl_assert_data_3.fct = "search";
__gen_e_acsl_assert_data_3.line = 18;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_i,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
if (A[__gen_e_acsl_i] < elt) ;
@@ -144,10 +146,11 @@ int search(int elt)
"__gen_e_acsl_i_2",0,__gen_e_acsl_i_2);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "index_bound: __gen_e_acsl_i_2 < 10";
+ __gen_e_acsl_assert_data_7.pred_txt = "__gen_e_acsl_i_2 < 10";
__gen_e_acsl_assert_data_7.file = "linear_search.i";
__gen_e_acsl_assert_data_7.fct = "search";
__gen_e_acsl_assert_data_7.line = 18;
+ __gen_e_acsl_assert_data_7.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_i_2 < 10,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_8 =
@@ -156,10 +159,11 @@ int search(int elt)
"__gen_e_acsl_i_2",0,__gen_e_acsl_i_2);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "index_bound: 0 <= __gen_e_acsl_i_2";
+ __gen_e_acsl_assert_data_8.pred_txt = "0 <= __gen_e_acsl_i_2";
__gen_e_acsl_assert_data_8.file = "linear_search.i";
__gen_e_acsl_assert_data_8.fct = "search";
__gen_e_acsl_assert_data_8.line = 18;
+ __gen_e_acsl_assert_data_8.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_i_2,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
if (A[__gen_e_acsl_i_2] < elt) ;
@@ -269,10 +273,11 @@ int __gen_e_acsl_search(int elt)
"__gen_e_acsl_i",0,__gen_e_acsl_i);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "index_bound: (int)(__gen_e_acsl_i + 1) < 10";
+ __gen_e_acsl_assert_data_2.pred_txt = "(int)(__gen_e_acsl_i + 1) < 10";
__gen_e_acsl_assert_data_2.file = "linear_search.i";
__gen_e_acsl_assert_data_2.fct = "search";
__gen_e_acsl_assert_data_2.line = 7;
+ __gen_e_acsl_assert_data_2.name = "index_bound";
__e_acsl_assert((int)(__gen_e_acsl_i + 1L) < 10,
& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
@@ -282,10 +287,11 @@ int __gen_e_acsl_search(int elt)
"__gen_e_acsl_i",0,__gen_e_acsl_i);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "index_bound: 0 <= (int)(__gen_e_acsl_i + 1)";
+ __gen_e_acsl_assert_data_3.pred_txt = "0 <= (int)(__gen_e_acsl_i + 1)";
__gen_e_acsl_assert_data_3.file = "linear_search.i";
__gen_e_acsl_assert_data_3.fct = "search";
__gen_e_acsl_assert_data_3.line = 7;
+ __gen_e_acsl_assert_data_3.name = "index_bound";
__e_acsl_assert(0 <= (int)(__gen_e_acsl_i + 1L),
& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
@@ -295,10 +301,11 @@ int __gen_e_acsl_search(int elt)
"__gen_e_acsl_i",0,__gen_e_acsl_i);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "index_bound: __gen_e_acsl_i < 10";
+ __gen_e_acsl_assert_data_4.pred_txt = "__gen_e_acsl_i < 10";
__gen_e_acsl_assert_data_4.file = "linear_search.i";
__gen_e_acsl_assert_data_4.fct = "search";
__gen_e_acsl_assert_data_4.line = 7;
+ __gen_e_acsl_assert_data_4.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_i < 10,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -307,10 +314,11 @@ int __gen_e_acsl_search(int elt)
"__gen_e_acsl_i",0,__gen_e_acsl_i);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "index_bound: 0 <= __gen_e_acsl_i";
+ __gen_e_acsl_assert_data_5.pred_txt = "0 <= __gen_e_acsl_i";
__gen_e_acsl_assert_data_5.file = "linear_search.i";
__gen_e_acsl_assert_data_5.fct = "search";
__gen_e_acsl_assert_data_5.line = 7;
+ __gen_e_acsl_assert_data_5.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_i,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
if (A[__gen_e_acsl_i] <= A[__gen_e_acsl_i + 1]) ;
@@ -344,10 +352,11 @@ int __gen_e_acsl_search(int elt)
"__gen_e_acsl_j",0,__gen_e_acsl_j);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "index_bound: __gen_e_acsl_j < 10";
+ __gen_e_acsl_assert_data_6.pred_txt = "__gen_e_acsl_j < 10";
__gen_e_acsl_assert_data_6.file = "linear_search.i";
__gen_e_acsl_assert_data_6.fct = "search";
__gen_e_acsl_assert_data_6.line = 9;
+ __gen_e_acsl_assert_data_6.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_j < 10,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_7 =
@@ -356,10 +365,11 @@ int __gen_e_acsl_search(int elt)
"__gen_e_acsl_j",0,__gen_e_acsl_j);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "index_bound: 0 <= __gen_e_acsl_j";
+ __gen_e_acsl_assert_data_7.pred_txt = "0 <= __gen_e_acsl_j";
__gen_e_acsl_assert_data_7.file = "linear_search.i";
__gen_e_acsl_assert_data_7.fct = "search";
__gen_e_acsl_assert_data_7.line = 9;
+ __gen_e_acsl_assert_data_7.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_j,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
if (! (A[__gen_e_acsl_j] == elt)) ;
@@ -384,10 +394,11 @@ int __gen_e_acsl_search(int elt)
"__gen_e_acsl_j_2",0,__gen_e_acsl_j_2);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "index_bound: __gen_e_acsl_j_2 < 10";
+ __gen_e_acsl_assert_data_8.pred_txt = "__gen_e_acsl_j_2 < 10";
__gen_e_acsl_assert_data_8.file = "linear_search.i";
__gen_e_acsl_assert_data_8.fct = "search";
__gen_e_acsl_assert_data_8.line = 12;
+ __gen_e_acsl_assert_data_8.name = "index_bound";
__e_acsl_assert(__gen_e_acsl_j_2 < 10,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_9 =
@@ -396,10 +407,11 @@ int __gen_e_acsl_search(int elt)
"__gen_e_acsl_j_2",0,__gen_e_acsl_j_2);
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "index_bound: 0 <= __gen_e_acsl_j_2";
+ __gen_e_acsl_assert_data_9.pred_txt = "0 <= __gen_e_acsl_j_2";
__gen_e_acsl_assert_data_9.file = "linear_search.i";
__gen_e_acsl_assert_data_9.fct = "search";
__gen_e_acsl_assert_data_9.line = 12;
+ __gen_e_acsl_assert_data_9.name = "index_bound";
__e_acsl_assert(0 <= __gen_e_acsl_j_2,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
if (A[__gen_e_acsl_j_2] != elt) ;
@@ -426,10 +438,11 @@ int __gen_e_acsl_search(int elt)
0,__retres);
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "Postcondition";
- __gen_e_acsl_assert_data_10.pred_txt = "exists: \\result == 1";
+ __gen_e_acsl_assert_data_10.pred_txt = "\\result == 1";
__gen_e_acsl_assert_data_10.file = "linear_search.i";
__gen_e_acsl_assert_data_10.fct = "search";
__gen_e_acsl_assert_data_10.line = 10;
+ __gen_e_acsl_assert_data_10.name = "exists";
__e_acsl_assert(__retres == 1,& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
}
@@ -442,10 +455,11 @@ int __gen_e_acsl_search(int elt)
0,__retres);
__gen_e_acsl_assert_data_11.blocking = 1;
__gen_e_acsl_assert_data_11.kind = "Postcondition";
- __gen_e_acsl_assert_data_11.pred_txt = "not_exists: \\result == 0";
+ __gen_e_acsl_assert_data_11.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_11.file = "linear_search.i";
__gen_e_acsl_assert_data_11.fct = "search";
__gen_e_acsl_assert_data_11.line = 13;
+ __gen_e_acsl_assert_data_11.name = "not_exists";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_11);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_11);
}
diff --git a/src/plugins/e-acsl/tests/format/oracle/gen_fprintf.c b/src/plugins/e-acsl/tests/format/oracle/gen_fprintf.c
index a20d48aaf6467bb7b7dc9c0858f19601320172b9..6f72b40c111a225647a22a74e7662b92ffc9e4d5 100644
--- a/src/plugins/e-acsl/tests/format/oracle/gen_fprintf.c
+++ b/src/plugins/e-acsl/tests/format/oracle/gen_fprintf.c
@@ -123,10 +123,11 @@ pid_t __gen_e_acsl_fork(void)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "result_ok_child_or_error: \\result == 0 || \\result > 0 || \\result == -1";
+ __gen_e_acsl_assert_data.pred_txt = "\\result == 0 || \\result > 0 || \\result == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/unistd.h";
__gen_e_acsl_assert_data.fct = "fork";
__gen_e_acsl_assert_data.line = 846;
+ __gen_e_acsl_assert_data.name = "result_ok_child_or_error";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
return __retres;
@@ -182,10 +183,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
"\\valid(stat_loc)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "stat_loc_non_null: valid_stat_loc: \\valid(stat_loc)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(stat_loc)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data.fct = "waitpid";
__gen_e_acsl_assert_data.line = 95;
+ __gen_e_acsl_assert_data.name = "stat_loc_non_null/valid_stat_loc";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -209,10 +211,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "result_ok_or_error: \\result == -1 || \\result >= 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == -1 || \\result >= 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_2.fct = "waitpid";
__gen_e_acsl_assert_data_2.line = 87;
+ __gen_e_acsl_assert_data_2.name = "result_ok_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -242,10 +245,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: stat_loc_init_on_success:\n \\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_3.fct = "waitpid";
__gen_e_acsl_assert_data_3.line = 89;
+ __gen_e_acsl_assert_data_3.name = "initialization/stat_loc_init_on_success";
__e_acsl_assert(__gen_e_acsl_implies,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -266,10 +270,11 @@ void __gen_e_acsl_exit(int status)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "exit";
__gen_e_acsl_assert_data.line = 473;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
@@ -297,10 +302,11 @@ int __gen_e_acsl_fclose(FILE *stream)
"\\valid(stream)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_stream: \\valid(stream)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(stream)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data.fct = "fclose";
__gen_e_acsl_assert_data.line = 120;
+ __gen_e_acsl_assert_data.name = "valid_stream";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -319,10 +325,11 @@ int __gen_e_acsl_fclose(FILE *stream)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "result_zero_or_EOF: \\result == 0 || \\result == -1";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == 0 || \\result == -1";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_2.fct = "fclose";
__gen_e_acsl_assert_data_2.line = 122;
+ __gen_e_acsl_assert_data_2.name = "result_zero_or_EOF";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_delete_block((void *)(& stream));
diff --git a/src/plugins/e-acsl/tests/format/oracle/gen_printf.c b/src/plugins/e-acsl/tests/format/oracle/gen_printf.c
index 49821bd7fab20317861c14a3f7d89ac977c9de5d..ca8765b8f2703ec3458a2925a0d5fed15bbcd41c 100644
--- a/src/plugins/e-acsl/tests/format/oracle/gen_printf.c
+++ b/src/plugins/e-acsl/tests/format/oracle/gen_printf.c
@@ -640,10 +640,11 @@ void test_specifier_application(char const *allowed, char const *fmt,
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Assertion";
- __gen_e_acsl_assert_data.pred_txt = "alloca_bounds: 0 < sizeof(char) * (int)(len + 1) <= 18446744073709551615";
+ __gen_e_acsl_assert_data.pred_txt = "0 < sizeof(char) * (int)(len + 1) <= 18446744073709551615";
__gen_e_acsl_assert_data.file = "printf.c";
__gen_e_acsl_assert_data.fct = "test_specifier_application";
__gen_e_acsl_assert_data.line = 55;
+ __gen_e_acsl_assert_data.name = "alloca_bounds";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -766,10 +767,11 @@ char *__gen_e_acsl_strcpy(char * restrict dest, char const * restrict src)
(__e_acsl_mpz_struct const *)(__gen_e_acsl__2));
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "size_lesser_or_eq_than_SIZE_MAX:\n __gen_e_acsl_strcpy_src_size + 1 <= 18446744073709551615";
+ __gen_e_acsl_assert_data_6.pred_txt = "__gen_e_acsl_strcpy_src_size + 1 <= 18446744073709551615";
__gen_e_acsl_assert_data_6.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_6.fct = "strcpy";
__gen_e_acsl_assert_data_6.line = 367;
+ __gen_e_acsl_assert_data_6.name = "size_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le <= 0,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__gen_e_acsl_size = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_add));
@@ -788,10 +790,11 @@ char *__gen_e_acsl_strcpy(char * restrict dest, char const * restrict src)
(void *)__gen_e_acsl_at);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "Postcondition";
- __gen_e_acsl_assert_data_8.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_8.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_8.fct = "strcpy";
__gen_e_acsl_assert_data_8.line = 374;
+ __gen_e_acsl_assert_data_8.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__e_acsl_delete_block((void *)(& src));
@@ -879,10 +882,11 @@ char *__gen_e_acsl_strchr(char const *s, int c)
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(__retres)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(__retres)";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_3.fct = "strchr";
__gen_e_acsl_assert_data_3.line = 177;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -897,19 +901,21 @@ char *__gen_e_acsl_strchr(char const *s, int c)
__gen_e_acsl_base_addr_2);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "found: result_same_base: \\base_addr(\\result) == \\base_addr(\\old(s))";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\base_addr(\\result) == \\base_addr(\\old(s))";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "strchr";
__gen_e_acsl_assert_data_4.line = 178;
+ __gen_e_acsl_assert_data_4.name = "found/result_same_base";
__e_acsl_assert(__gen_e_acsl_base_addr == __gen_e_acsl_base_addr_2,
& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "found: result_char: *\\result == (char)\\old(c)";
+ __gen_e_acsl_assert_data_2.pred_txt = "*\\result == (char)\\old(c)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_2.fct = "strchr";
__gen_e_acsl_assert_data_2.line = 177;
+ __gen_e_acsl_assert_data_2.name = "found/result_char";
__e_acsl_assert((int)*__retres == (int)((char)__gen_e_acsl_at),
& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
@@ -923,10 +929,11 @@ char *__gen_e_acsl_strchr(char const *s, int c)
(void *)__retres);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "Postcondition";
- __gen_e_acsl_assert_data_8.pred_txt = "not_found: result_null: \\result == \\null";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\result == \\null";
__gen_e_acsl_assert_data_8.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_8.fct = "strchr";
__gen_e_acsl_assert_data_8.line = 184;
+ __gen_e_acsl_assert_data_8.name = "not_found/result_null";
__e_acsl_assert(__retres == (char *)0,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
}
@@ -954,10 +961,11 @@ char *__gen_e_acsl_strchr(char const *s, int c)
}
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "Postcondition";
- __gen_e_acsl_assert_data_9.pred_txt = "default: result_null_or_same_base:\n \\result == \\null || \\base_addr(\\result) == \\base_addr(\\old(s))";
+ __gen_e_acsl_assert_data_9.pred_txt = "\\result == \\null || \\base_addr(\\result) == \\base_addr(\\old(s))";
__gen_e_acsl_assert_data_9.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_9.fct = "strchr";
__gen_e_acsl_assert_data_9.line = 187;
+ __gen_e_acsl_assert_data_9.name = "default/result_null_or_same_base";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
}
@@ -1011,10 +1019,11 @@ pid_t __gen_e_acsl_fork(void)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "result_ok_child_or_error: \\result == 0 || \\result > 0 || \\result == -1";
+ __gen_e_acsl_assert_data.pred_txt = "\\result == 0 || \\result > 0 || \\result == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/unistd.h";
__gen_e_acsl_assert_data.fct = "fork";
__gen_e_acsl_assert_data.line = 846;
+ __gen_e_acsl_assert_data.name = "result_ok_child_or_error";
__e_acsl_assert(__gen_e_acsl_or_2,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
return __retres;
@@ -1070,10 +1079,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
"\\valid(stat_loc)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "stat_loc_non_null: valid_stat_loc: \\valid(stat_loc)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(stat_loc)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data.fct = "waitpid";
__gen_e_acsl_assert_data.line = 95;
+ __gen_e_acsl_assert_data.name = "stat_loc_non_null/valid_stat_loc";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -1097,10 +1107,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "result_ok_or_error: \\result == -1 || \\result >= 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == -1 || \\result >= 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_2.fct = "waitpid";
__gen_e_acsl_assert_data_2.line = 87;
+ __gen_e_acsl_assert_data_2.name = "result_ok_or_error";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -1130,10 +1141,11 @@ pid_t __gen_e_acsl_waitpid(pid_t pid, int *stat_loc, int options)
}
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "initialization: stat_loc_init_on_success:\n \\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result >= 0 && \\old(stat_loc) != \\null ==> \\initialized(\\old(stat_loc))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/sys/wait.h";
__gen_e_acsl_assert_data_3.fct = "waitpid";
__gen_e_acsl_assert_data_3.line = 89;
+ __gen_e_acsl_assert_data_3.name = "initialization/stat_loc_init_on_success";
__e_acsl_assert(__gen_e_acsl_implies,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -1154,10 +1166,11 @@ void __gen_e_acsl_exit(int status)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "exit";
__gen_e_acsl_assert_data.line = 473;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
@@ -1175,10 +1188,11 @@ void __gen_e_acsl_abort(void)
__e_acsl_assert_data_t __gen_e_acsl_assert_data = {.values = (void *)0};
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Postcondition";
- __gen_e_acsl_assert_data.pred_txt = "never_terminates: \\false";
+ __gen_e_acsl_assert_data.pred_txt = "\\false";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "abort";
__gen_e_acsl_assert_data.line = 460;
+ __gen_e_acsl_assert_data.name = "never_terminates";
__e_acsl_assert(0,& __gen_e_acsl_assert_data);
return;
}
diff --git a/src/plugins/e-acsl/tests/libc/oracle/gen_file.c b/src/plugins/e-acsl/tests/libc/oracle/gen_file.c
index 3bb8d905552aba07b763ba872ff9473caf954d53..06f88c63176372a599aefcc0d772d00e1ebd6a57 100644
--- a/src/plugins/e-acsl/tests/libc/oracle/gen_file.c
+++ b/src/plugins/e-acsl/tests/libc/oracle/gen_file.c
@@ -146,10 +146,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
(__e_acsl_mpz_struct const *)(__gen_e_acsl_if));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "offset_lesser_or_eq_than_SIZE_MAX:\n (\\let size = sizeof(char) * (((nmemb * size - 1) - 0) + 1);\n size <= 0? 0: size)\n <= 18446744073709551615";
+ __gen_e_acsl_assert_data_2.pred_txt = "(\\let size = sizeof(char) * (((nmemb * size - 1) - 0) + 1);\n size <= 0? 0: size)\n<= 18446744073709551615";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_2.fct = "fread";
__gen_e_acsl_assert_data_2.line = 351;
+ __gen_e_acsl_assert_data_2.name = "offset_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_2 <= 0,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_size_3 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_if));
@@ -161,10 +162,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_ptr_block: \\valid((char *)ptr + (0 .. nmemb * size - 1))";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid((char *)ptr + (0 .. nmemb * size - 1))";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data.fct = "fread";
__gen_e_acsl_assert_data.line = 351;
+ __gen_e_acsl_assert_data.name = "valid_ptr_block";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -179,10 +181,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
"\\valid(stream)",0,__gen_e_acsl_valid_2);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "valid_stream: \\valid(stream)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid(stream)";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_3.fct = "fread";
__gen_e_acsl_assert_data_3.line = 352;
+ __gen_e_acsl_assert_data_3.name = "valid_stream";
__e_acsl_assert(__gen_e_acsl_valid_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gmpz_clear(__gen_e_acsl_size);
@@ -233,10 +236,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
(__e_acsl_mpz_struct const *)(__gen_e_acsl__5));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "size_lesser_or_eq_than_SIZE_MAX: __retres * size <= 18446744073709551615";
+ __gen_e_acsl_assert_data_4.pred_txt = "__retres * size <= 18446744073709551615";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_4.fct = "fread";
__gen_e_acsl_assert_data_4.line = 350;
+ __gen_e_acsl_assert_data_4.name = "size_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_3 <= 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_size_5 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_mul_3));
@@ -271,10 +275,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
"\\old(nmemb)",0,__gen_e_acsl_at);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "size_read: \\result <= \\old(nmemb)";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result <= \\old(nmemb)";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_5.fct = "fread";
__gen_e_acsl_assert_data_5.line = 356;
+ __gen_e_acsl_assert_data_5.name = "size_read";
__e_acsl_assert(__retres <= __gen_e_acsl_at,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_6 =
@@ -346,10 +351,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
(__e_acsl_mpz_struct const *)(__gen_e_acsl_if_2));
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "offset_lesser_or_eq_than_SIZE_MAX:\n (\\let size = sizeof(char) * (((\\result * \\old(size) - 1) - 0) + 1);\n size <= 0? 0: size)\n <= 18446744073709551615";
+ __gen_e_acsl_assert_data_7.pred_txt = "(\\let size = sizeof(char) * (((\\result * \\old(size) - 1) - 0) + 1);\n size <= 0? 0: size)\n<= 18446744073709551615";
__gen_e_acsl_assert_data_7.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_7.fct = "fread";
__gen_e_acsl_assert_data_7.line = 357;
+ __gen_e_acsl_assert_data_7.name = "offset_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_5 <= 0,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__gen_e_acsl_size_8 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_if_2));
@@ -361,10 +367,11 @@ size_t __gen_e_acsl_fread(void * restrict ptr, size_t size, size_t nmemb,
0,__gen_e_acsl_initialized);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "Postcondition";
- __gen_e_acsl_assert_data_6.pred_txt = "initialization:\n \\initialized((char *)\\old(ptr) + (0 .. \\result * \\old(size) - 1))";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\initialized((char *)\\old(ptr) + (0 .. \\result * \\old(size) - 1))";
__gen_e_acsl_assert_data_6.file = "FRAMAC_SHARE/libc/stdio.h";
__gen_e_acsl_assert_data_6.fct = "fread";
__gen_e_acsl_assert_data_6.line = 357;
+ __gen_e_acsl_assert_data_6.name = "initialization";
__e_acsl_assert(__gen_e_acsl_initialized,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_delete_block((void *)(& stream));
diff --git a/src/plugins/e-acsl/tests/libc/oracle/gen_mem.c b/src/plugins/e-acsl/tests/libc/oracle/gen_mem.c
index 9ab927677560a25941b69033274241d1c9e0d621..503f06d93716cae46b39b2d05307255839b19039 100644
--- a/src/plugins/e-acsl/tests/libc/oracle/gen_mem.c
+++ b/src/plugins/e-acsl/tests/libc/oracle/gen_mem.c
@@ -419,10 +419,11 @@ void *__gen_e_acsl_memset(void *s, int c, size_t n)
__gen_e_acsl_at);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "result_ptr: \\result == \\old(s)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result == \\old(s)";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_3.fct = "memset";
__gen_e_acsl_assert_data_3.line = 135;
+ __gen_e_acsl_assert_data_3.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_delete_block((void *)(& s));
@@ -460,10 +461,11 @@ void *__gen_e_acsl_memmove(void *dest, void const *src, size_t n)
__gen_e_acsl_at);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "memmove";
__gen_e_acsl_assert_data_4.line = 125;
+ __gen_e_acsl_assert_data_4.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_delete_block((void *)(& src));
@@ -557,10 +559,11 @@ void *__gen_e_acsl_memcpy(void * restrict dest, void const * restrict src,
(void *)(& dest));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "separated_guard: \\valid_read((char *)dest + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read((char *)dest + (0 .. n - 1))";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "memcpy";
__gen_e_acsl_assert_data_4.line = 98;
+ __gen_e_acsl_assert_data_4.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -589,10 +592,11 @@ void *__gen_e_acsl_memcpy(void * restrict dest, void const * restrict src,
(void *)(& src));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "separated_guard: \\valid_read((char *)src + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read((char *)src + (0 .. n - 1))";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_5.fct = "memcpy";
__gen_e_acsl_assert_data_5.line = 98;
+ __gen_e_acsl_assert_data_5.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ptr(& __gen_e_acsl_assert_data_3,"dest",dest);
@@ -638,10 +642,11 @@ void *__gen_e_acsl_memcpy(void * restrict dest, void const * restrict src,
0,__gen_e_acsl_separated);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "separation:\n \\separated((char *)dest + (0 .. n - 1), (char *)src + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\separated((char *)dest + (0 .. n - 1), (char *)src + (0 .. n - 1))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_3.fct = "memcpy";
__gen_e_acsl_assert_data_3.line = 98;
+ __gen_e_acsl_assert_data_3.name = "separation";
__e_acsl_assert(__gen_e_acsl_separated,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gmpz_clear(__gen_e_acsl_n);
@@ -663,10 +668,11 @@ void *__gen_e_acsl_memcpy(void * restrict dest, void const * restrict src,
__gen_e_acsl_at);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "Postcondition";
- __gen_e_acsl_assert_data_7.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_7.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_7.fct = "memcpy";
__gen_e_acsl_assert_data_7.line = 102;
+ __gen_e_acsl_assert_data_7.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_delete_block((void *)(& src));
diff --git a/src/plugins/e-acsl/tests/libc/oracle/gen_str.c b/src/plugins/e-acsl/tests/libc/oracle/gen_str.c
index 9a5c9cb64577e8610537624d0f9219c807fc194b..3b7660e1a3ebbb5388edb7a40c3b91b86d786ae9 100644
--- a/src/plugins/e-acsl/tests/libc/oracle/gen_str.c
+++ b/src/plugins/e-acsl/tests/libc/oracle/gen_str.c
@@ -196,10 +196,11 @@ char *__gen_e_acsl_strncat(char * restrict dest, char const * restrict src,
(__e_acsl_mpz_struct const *)(__gen_e_acsl__2));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "size_lesser_or_eq_than_SIZE_MAX:\n (__gen_e_acsl_strcat_src_size + __gen_e_acsl_strcat_dest_size) + 1 <=\n 18446744073709551615";
+ __gen_e_acsl_assert_data_5.pred_txt = "(__gen_e_acsl_strcat_src_size + __gen_e_acsl_strcat_dest_size) + 1 <=\n18446744073709551615";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_5.fct = "strncat";
__gen_e_acsl_assert_data_5.line = 438;
+ __gen_e_acsl_assert_data_5.name = "size_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le <= 0,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__gen_e_acsl_size = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_add_2));
@@ -220,10 +221,11 @@ char *__gen_e_acsl_strncat(char * restrict dest, char const * restrict src,
(void *)__gen_e_acsl_at);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "Postcondition";
- __gen_e_acsl_assert_data_6.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_6.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_6.fct = "strncat";
__gen_e_acsl_assert_data_6.line = 443;
+ __gen_e_acsl_assert_data_6.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -299,10 +301,11 @@ char *__gen_e_acsl_strcat(char * restrict dest, char const * restrict src)
(__e_acsl_mpz_struct const *)(__gen_e_acsl__2));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "size_lesser_or_eq_than_SIZE_MAX:\n (__gen_e_acsl_strcat_src_size + __gen_e_acsl_strcat_dest_size) + 1 <=\n 18446744073709551615";
+ __gen_e_acsl_assert_data_4.pred_txt = "(__gen_e_acsl_strcat_src_size + __gen_e_acsl_strcat_dest_size) + 1 <=\n18446744073709551615";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "strcat";
__gen_e_acsl_assert_data_4.line = 423;
+ __gen_e_acsl_assert_data_4.name = "size_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le <= 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_size = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_add_2));
@@ -323,10 +326,11 @@ char *__gen_e_acsl_strcat(char * restrict dest, char const * restrict src)
(void *)__gen_e_acsl_at_2);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "Postcondition";
- __gen_e_acsl_assert_data_8.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_8.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_8.fct = "strcat";
__gen_e_acsl_assert_data_8.line = 434;
+ __gen_e_acsl_assert_data_8.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at_2,
& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
@@ -432,10 +436,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "room_nstring: \\valid(dest + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid(dest + (0 .. n - 1))";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_2.fct = "strncpy";
__gen_e_acsl_assert_data_2.line = 380;
+ __gen_e_acsl_assert_data_2.name = "room_nstring";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -465,10 +470,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
(void *)(& dest));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "separated_guard: \\valid_read(dest + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(dest + (0 .. n - 1))";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "strncpy";
__gen_e_acsl_assert_data_4.line = 382;
+ __gen_e_acsl_assert_data_4.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -496,10 +502,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
(void *)(& src));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "separated_guard: \\valid_read(src + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read(src + (0 .. n - 1))";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_5.fct = "strncpy";
__gen_e_acsl_assert_data_5.line = 382;
+ __gen_e_acsl_assert_data_5.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ptr(& __gen_e_acsl_assert_data_3,"dest",
@@ -545,10 +552,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
0,__gen_e_acsl_separated);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "separation: \\separated(dest + (0 .. n - 1), src + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\separated(dest + (0 .. n - 1), src + (0 .. n - 1))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_3.fct = "strncpy";
__gen_e_acsl_assert_data_3.line = 382;
+ __gen_e_acsl_assert_data_3.name = "separation";
__e_acsl_assert(__gen_e_acsl_separated,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gmpz_clear(__gen_e_acsl_n);
@@ -587,10 +595,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
(void *)__gen_e_acsl_at);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "Postcondition";
- __gen_e_acsl_assert_data_6.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_6.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_6.fct = "strncpy";
__gen_e_acsl_assert_data_6.line = 385;
+ __gen_e_acsl_assert_data_6.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_7 =
@@ -635,10 +644,11 @@ char *__gen_e_acsl_strncpy(char * restrict dest, char const * restrict src,
0,__gen_e_acsl_initialized);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "Postcondition";
- __gen_e_acsl_assert_data_7.pred_txt = "initialization: \\initialized(\\old(dest) + (0 .. \\old(n) - 1))";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\initialized(\\old(dest) + (0 .. \\old(n) - 1))";
__gen_e_acsl_assert_data_7.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_7.fct = "strncpy";
__gen_e_acsl_assert_data_7.line = 386;
+ __gen_e_acsl_assert_data_7.name = "initialization";
__e_acsl_assert(__gen_e_acsl_initialized,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_contract_clean(__gen_e_acsl_contract);
@@ -700,10 +710,11 @@ char *__gen_e_acsl_strcpy(char * restrict dest, char const * restrict src)
(__e_acsl_mpz_struct const *)(__gen_e_acsl__2));
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "size_lesser_or_eq_than_SIZE_MAX:\n __gen_e_acsl_strcpy_src_size + 1 <= 18446744073709551615";
+ __gen_e_acsl_assert_data_6.pred_txt = "__gen_e_acsl_strcpy_src_size + 1 <= 18446744073709551615";
__gen_e_acsl_assert_data_6.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_6.fct = "strcpy";
__gen_e_acsl_assert_data_6.line = 367;
+ __gen_e_acsl_assert_data_6.name = "size_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le <= 0,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__gen_e_acsl_size = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_add));
@@ -722,10 +733,11 @@ char *__gen_e_acsl_strcpy(char * restrict dest, char const * restrict src)
(void *)__gen_e_acsl_at);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "Postcondition";
- __gen_e_acsl_assert_data_8.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_8.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_8.fct = "strcpy";
__gen_e_acsl_assert_data_8.line = 374;
+ __gen_e_acsl_assert_data_8.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__e_acsl_delete_block((void *)(& src));
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_ctype_macros.c b/src/plugins/e-acsl/tests/memory/oracle/gen_ctype_macros.c
index 748ac1693558af156c58f32a99f57525c83e7250..6831a80ad797eb20547600972a33a96a3b8cd068 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_ctype_macros.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_ctype_macros.c
@@ -119,10 +119,11 @@ int __gen_e_acsl_isupper(int c)
}
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "c_uchar_or_eof: (0 <= c <= 255) || c == -1";
+ __gen_e_acsl_assert_data.pred_txt = "(0 <= c <= 255) || c == -1";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/ctype.h";
__gen_e_acsl_assert_data.fct = "isupper";
__gen_e_acsl_assert_data.line = 174;
+ __gen_e_acsl_assert_data.name = "c_uchar_or_eof";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
if (65 <= c) __gen_e_acsl_and_2 = c <= 90; else __gen_e_acsl_and_2 = 0;
@@ -183,10 +184,11 @@ int __gen_e_acsl_isupper(int c)
}
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "definitely_match: nonzero_result: \\result < 0 || \\result > 0";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\result < 0 || \\result > 0";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/ctype.h";
__gen_e_acsl_assert_data_4.fct = "isupper";
__gen_e_acsl_assert_data_4.line = 178;
+ __gen_e_acsl_assert_data_4.name = "definitely_match/nonzero_result";
__e_acsl_assert(__gen_e_acsl_or_4,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -199,10 +201,11 @@ int __gen_e_acsl_isupper(int c)
__retres);
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "definitely_not_match: zero_result: \\result == 0";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/ctype.h";
__gen_e_acsl_assert_data_5.fct = "isupper";
__gen_e_acsl_assert_data_5.line = 181;
+ __gen_e_acsl_assert_data_5.name = "definitely_not_match/zero_result";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
}
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_literal_string.c b/src/plugins/e-acsl/tests/memory/oracle/gen_literal_string.c
index ae25b453493ac39d0a9689444aacdd4ee7ba9782..f2c14f3d7a878ddcc615713bd3ae5e0c099a81b7 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_literal_string.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_literal_string.c
@@ -36,10 +36,11 @@ void f(void)
(void *)(& T));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(T + G)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(T + G)";
__gen_e_acsl_assert_data_2.file = "literal_string.i";
__gen_e_acsl_assert_data_2.fct = "f";
__gen_e_acsl_assert_data_2.line = 11;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_assert_data.blocking = 1;
@@ -143,10 +144,11 @@ int main(void)
(void *)(& S));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(S + G2)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(S + G2)";
__gen_e_acsl_assert_data_2.file = "literal_string.i";
__gen_e_acsl_assert_data_2.fct = "main";
__gen_e_acsl_assert_data_2.line = 25;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_assert_data.blocking = 1;
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_mainargs.c b/src/plugins/e-acsl/tests/memory/oracle/gen_mainargs.c
index 18836d02090e3ed43878b3e6658f52230952c198..8f9f0b16081beb021b3c86b3cae4341506d752b0 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_mainargs.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_mainargs.c
@@ -112,10 +112,11 @@ int __gen_e_acsl_main(int argc, char **argv)
(void *)(& argv));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "mem_access: \\valid_read(argv + argc)";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(argv + argc)";
__gen_e_acsl_assert_data_4.file = "mainargs.c";
__gen_e_acsl_assert_data_4.fct = "main";
__gen_e_acsl_assert_data_4.line = 15;
+ __gen_e_acsl_assert_data_4.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_assert_data_3.blocking = 1;
@@ -164,10 +165,11 @@ int __gen_e_acsl_main(int argc, char **argv)
(void *)(& argv));
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "mem_access: \\valid_read(argv + argc)";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\valid_read(argv + argc)";
__gen_e_acsl_assert_data_6.file = "mainargs.c";
__gen_e_acsl_assert_data_6.fct = "main";
__gen_e_acsl_assert_data_6.line = 16;
+ __gen_e_acsl_assert_data_6.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_5,
@@ -232,10 +234,11 @@ int __gen_e_acsl_main(int argc, char **argv)
(void *)(& argv));
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "mem_access: \\valid_read(argv + i)";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\valid_read(argv + i)";
__gen_e_acsl_assert_data_8.file = "mainargs.c";
__gen_e_acsl_assert_data_8.fct = "main";
__gen_e_acsl_assert_data_8.line = 19;
+ __gen_e_acsl_assert_data_8.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,
& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
@@ -288,10 +291,11 @@ int __gen_e_acsl_main(int argc, char **argv)
(void *)(& argv));
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "mem_access: \\valid_read(argv + i)";
+ __gen_e_acsl_assert_data_10.pred_txt = "\\valid_read(argv + i)";
__gen_e_acsl_assert_data_10.file = "mainargs.c";
__gen_e_acsl_assert_data_10.fct = "main";
__gen_e_acsl_assert_data_10.line = 20;
+ __gen_e_acsl_assert_data_10.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_4,
& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_memalign.c b/src/plugins/e-acsl/tests/memory/oracle/gen_memalign.c
index 4b9a6d6578bc17ec454d1f67a8d108dca76774ae..89f3520d16eaa67dd584f194de65f2e40dbf34a2 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_memalign.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_memalign.c
@@ -418,10 +418,11 @@ int __gen_e_acsl_posix_memalign(void **memptr, size_t alignment, size_t size)
"\\valid(memptr)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "valid_memptr: \\valid(memptr)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(memptr)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data.fct = "posix_memalign";
__gen_e_acsl_assert_data.line = 666;
+ __gen_e_acsl_assert_data.name = "valid_memptr";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_2 =
@@ -460,10 +461,11 @@ int __gen_e_acsl_posix_memalign(void **memptr, size_t alignment, size_t size)
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Precondition";
- __gen_e_acsl_assert_data_2.pred_txt = "alignment_is_a_suitable_power_of_two:\n alignment >= sizeof(void *) &&\n ((size_t)alignment & ((size_t)alignment - 1)) == 0";
+ __gen_e_acsl_assert_data_2.pred_txt = "alignment >= sizeof(void *) &&\n((size_t)alignment & ((size_t)alignment - 1)) == 0";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data_2.fct = "posix_memalign";
__gen_e_acsl_assert_data_2.line = 668;
+ __gen_e_acsl_assert_data_2.name = "alignment_is_a_suitable_power_of_two";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
@@ -479,10 +481,11 @@ int __gen_e_acsl_posix_memalign(void **memptr, size_t alignment, size_t size)
__retres);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "allocation: result_zero: \\result == 0";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\result == 0";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data_4.fct = "posix_memalign";
__gen_e_acsl_assert_data_4.line = 680;
+ __gen_e_acsl_assert_data_4.name = "allocation/result_zero";
__e_acsl_assert(__retres == 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
@@ -502,10 +505,11 @@ int __gen_e_acsl_posix_memalign(void **memptr, size_t alignment, size_t size)
}
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "Postcondition";
- __gen_e_acsl_assert_data_5.pred_txt = "no_allocation: result_non_zero: \\result < 0 || \\result > 0";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\result < 0 || \\result > 0";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data_5.fct = "posix_memalign";
__gen_e_acsl_assert_data_5.line = 685;
+ __gen_e_acsl_assert_data_5.name = "no_allocation/result_non_zero";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
}
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_ptr.c b/src/plugins/e-acsl/tests/memory/oracle/gen_ptr.c
index 88bda500b3e1c2448c69bc0fb927b66dbeda92b1..ff00f4a06ecf01e67319c17d2e2890456b992aea 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_ptr.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_ptr.c
@@ -47,10 +47,11 @@ int main(void)
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_2.file = "ptr.i";
__gen_e_acsl_assert_data_2.fct = "main";
__gen_e_acsl_assert_data_2.line = 12;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_assert_data.blocking = 1;
@@ -121,10 +122,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_7,"i",0,i);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "index_bound: i < 3";
+ __gen_e_acsl_assert_data_7.pred_txt = "i < 3";
__gen_e_acsl_assert_data_7.file = "ptr.i";
__gen_e_acsl_assert_data_7.fct = "main";
__gen_e_acsl_assert_data_7.line = 18;
+ __gen_e_acsl_assert_data_7.name = "index_bound";
__e_acsl_assert(i < 3,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_8 =
@@ -132,10 +134,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_8,"i",0,i);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "index_bound: 0 <= i";
+ __gen_e_acsl_assert_data_8.pred_txt = "0 <= i";
__gen_e_acsl_assert_data_8.file = "ptr.i";
__gen_e_acsl_assert_data_8.fct = "main";
__gen_e_acsl_assert_data_8.line = 18;
+ __gen_e_acsl_assert_data_8.name = "index_bound";
__e_acsl_assert(0 <= i,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__gen_e_acsl_assert_data_6.blocking = 1;
@@ -159,10 +162,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_10,"i",0,i);
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "index_bound: (long)(2 - i) < 3";
+ __gen_e_acsl_assert_data_10.pred_txt = "(long)(2 - i) < 3";
__gen_e_acsl_assert_data_10.file = "ptr.i";
__gen_e_acsl_assert_data_10.fct = "main";
__gen_e_acsl_assert_data_10.line = 19;
+ __gen_e_acsl_assert_data_10.name = "index_bound";
__e_acsl_assert(2L - i < 3L,& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_11 =
@@ -170,10 +174,11 @@ int main(void)
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_11,"i",0,i);
__gen_e_acsl_assert_data_11.blocking = 1;
__gen_e_acsl_assert_data_11.kind = "RTE";
- __gen_e_acsl_assert_data_11.pred_txt = "index_bound: 0 <= (long)(2 - i)";
+ __gen_e_acsl_assert_data_11.pred_txt = "0 <= (long)(2 - i)";
__gen_e_acsl_assert_data_11.file = "ptr.i";
__gen_e_acsl_assert_data_11.fct = "main";
__gen_e_acsl_assert_data_11.line = 19;
+ __gen_e_acsl_assert_data_11.name = "index_bound";
__e_acsl_assert(0L <= 2L - i,& __gen_e_acsl_assert_data_11);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_11);
__gen_e_acsl_assert_data_9.blocking = 1;
@@ -207,10 +212,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_13.blocking = 1;
__gen_e_acsl_assert_data_13.kind = "RTE";
- __gen_e_acsl_assert_data_13.pred_txt = "mem_access: \\valid_read(&t[2] - i)";
+ __gen_e_acsl_assert_data_13.pred_txt = "\\valid_read(&t[2] - i)";
__gen_e_acsl_assert_data_13.file = "ptr.i";
__gen_e_acsl_assert_data_13.fct = "main";
__gen_e_acsl_assert_data_13.line = 20;
+ __gen_e_acsl_assert_data_13.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,
& __gen_e_acsl_assert_data_13);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_13);
@@ -260,10 +266,11 @@ int main(void)
else __gen_e_acsl_and_2 = 0;
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "RTE";
- __gen_e_acsl_assert_data_15.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_15.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_15.file = "ptr.i";
__gen_e_acsl_assert_data_15.fct = "main";
__gen_e_acsl_assert_data_15.line = 26;
+ __gen_e_acsl_assert_data_15.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_2,& __gen_e_acsl_assert_data_15);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_15);
__gen_e_acsl_assert_data_14.blocking = 1;
@@ -294,10 +301,11 @@ int main(void)
(void *)(& p));
__gen_e_acsl_assert_data_17.blocking = 1;
__gen_e_acsl_assert_data_17.kind = "RTE";
- __gen_e_acsl_assert_data_17.pred_txt = "mem_access: \\valid_read(p + k)";
+ __gen_e_acsl_assert_data_17.pred_txt = "\\valid_read(p + k)";
__gen_e_acsl_assert_data_17.file = "ptr.i";
__gen_e_acsl_assert_data_17.fct = "main";
__gen_e_acsl_assert_data_17.line = 28;
+ __gen_e_acsl_assert_data_17.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_4,& __gen_e_acsl_assert_data_17);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_17);
__gen_e_acsl_assert_data_16.blocking = 1;
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_ranges_in_builtins.c b/src/plugins/e-acsl/tests/memory/oracle/gen_ranges_in_builtins.c
index 24930091b451c17297a6433781c9e213d80d0f6c..e8c4b325fcc879c6d3eded17655065d74bee84e2 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_ranges_in_builtins.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_ranges_in_builtins.c
@@ -724,10 +724,11 @@ int main(void)
(void *)(& multi_dynamic));
__gen_e_acsl_assert_data_18.blocking = 1;
__gen_e_acsl_assert_data_18.kind = "RTE";
- __gen_e_acsl_assert_data_18.pred_txt = "mem_access: \\valid_read(multi_dynamic + 4)";
+ __gen_e_acsl_assert_data_18.pred_txt = "\\valid_read(multi_dynamic + 4)";
__gen_e_acsl_assert_data_18.file = "ranges_in_builtins.c";
__gen_e_acsl_assert_data_18.fct = "main";
__gen_e_acsl_assert_data_18.line = 72;
+ __gen_e_acsl_assert_data_18.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_3,& __gen_e_acsl_assert_data_18);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_18);
__e_acsl_assert_register_int(& __gen_e_acsl_assert_data_17,"sizeof(int)",
@@ -909,10 +910,11 @@ void __gen_e_acsl_g(long *ptr, size_t size)
(__e_acsl_mpz_struct const *)(__gen_e_acsl_if));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "offset_lesser_or_eq_than_SIZE_MAX:\n (\\let size = sizeof(long) * (((size - 1) - 0) + 1); size <= 0? 0: size) <=\n 18446744073709551615";
+ __gen_e_acsl_assert_data_2.pred_txt = "(\\let size = sizeof(long) * (((size - 1) - 0) + 1); size <= 0? 0: size) <=\n18446744073709551615";
__gen_e_acsl_assert_data_2.file = "ranges_in_builtins.c";
__gen_e_acsl_assert_data_2.fct = "g";
__gen_e_acsl_assert_data_2.line = 8;
+ __gen_e_acsl_assert_data_2.name = "offset_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_2 <= 0,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_size_3 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_if));
@@ -1028,10 +1030,11 @@ void __gen_e_acsl_g(long *ptr, size_t size)
(__e_acsl_mpz_struct const *)(__gen_e_acsl_if_2));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "offset_lesser_or_eq_than_SIZE_MAX:\n (\\let size = sizeof(long) * (((\\old(size) + 1) - 0) + 1);\n size <= 0? 0: size)\n <= 18446744073709551615";
+ __gen_e_acsl_assert_data_4.pred_txt = "(\\let size = sizeof(long) * (((\\old(size) + 1) - 0) + 1); size <= 0? 0: size)\n<= 18446744073709551615";
__gen_e_acsl_assert_data_4.file = "ranges_in_builtins.c";
__gen_e_acsl_assert_data_4.fct = "g";
__gen_e_acsl_assert_data_4.line = 9;
+ __gen_e_acsl_assert_data_4.name = "offset_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_4 <= 0,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_size_6 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_if_2));
@@ -1150,10 +1153,11 @@ void __gen_e_acsl_f(char *s, long n)
(__e_acsl_mpz_struct const *)(__gen_e_acsl_if));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "offset_lesser_or_eq_than_SIZE_MAX:\n (\\let size = sizeof(char) * (((n + 1000) - 3) + 1); size <= 0? 0: size) <=\n 18446744073709551615";
+ __gen_e_acsl_assert_data_2.pred_txt = "(\\let size = sizeof(char) * (((n + 1000) - 3) + 1); size <= 0? 0: size) <=\n18446744073709551615";
__gen_e_acsl_assert_data_2.file = "ranges_in_builtins.c";
__gen_e_acsl_assert_data_2.fct = "f";
__gen_e_acsl_assert_data_2.line = 6;
+ __gen_e_acsl_assert_data_2.name = "offset_lesser_or_eq_than_SIZE_MAX";
__e_acsl_assert(__gen_e_acsl_le_2 <= 0,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_size_2 = __gmpz_get_ui((__e_acsl_mpz_struct const *)(__gen_e_acsl_if));
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_separated.c b/src/plugins/e-acsl/tests/memory/oracle/gen_separated.c
index 27fd719fed1f34145dc7be731006e1a8b9458485..4cd79cd0a40bd19db35e1aff255195ecdcbc3fde 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_separated.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_separated.c
@@ -47,10 +47,11 @@ int main(void)
(void *)(& a),(void *)0);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "separated_guard: \\valid_read(&a)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(&a)";
__gen_e_acsl_assert_data_2.file = "separated.c";
__gen_e_acsl_assert_data_2.fct = "main";
__gen_e_acsl_assert_data_2.line = 14;
+ __gen_e_acsl_assert_data_2.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_3 =
@@ -65,10 +66,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "separated_guard: \\valid_read(&b)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(&b)";
__gen_e_acsl_assert_data_3.file = "separated.c";
__gen_e_acsl_assert_data_3.fct = "main";
__gen_e_acsl_assert_data_3.line = 14;
+ __gen_e_acsl_assert_data_3.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_4 =
@@ -83,10 +85,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "separated_guard: \\valid_read(&c)";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(&c)";
__gen_e_acsl_assert_data_4.file = "separated.c";
__gen_e_acsl_assert_data_4.fct = "main";
__gen_e_acsl_assert_data_4.line = 14;
+ __gen_e_acsl_assert_data_4.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_3,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_register_ptr(& __gen_e_acsl_assert_data,"&a",
@@ -138,10 +141,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "separated_guard: \\valid_read(&a)";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\valid_read(&a)";
__gen_e_acsl_assert_data_6.file = "separated.c";
__gen_e_acsl_assert_data_6.fct = "main";
__gen_e_acsl_assert_data_6.line = 15;
+ __gen_e_acsl_assert_data_6.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_4,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_7 =
@@ -156,10 +160,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "separated_guard: \\valid_read(&b)";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\valid_read(&b)";
__gen_e_acsl_assert_data_7.file = "separated.c";
__gen_e_acsl_assert_data_7.fct = "main";
__gen_e_acsl_assert_data_7.line = 15;
+ __gen_e_acsl_assert_data_7.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_5,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_8 =
@@ -174,10 +179,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "separated_guard: \\valid_read(&c)";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\valid_read(&c)";
__gen_e_acsl_assert_data_8.file = "separated.c";
__gen_e_acsl_assert_data_8.fct = "main";
__gen_e_acsl_assert_data_8.line = 15;
+ __gen_e_acsl_assert_data_8.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_6,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_9 =
@@ -203,10 +209,11 @@ int main(void)
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "separated_guard: \\valid_read(d)";
+ __gen_e_acsl_assert_data_9.pred_txt = "\\valid_read(d)";
__gen_e_acsl_assert_data_9.file = "separated.c";
__gen_e_acsl_assert_data_9.fct = "main";
__gen_e_acsl_assert_data_9.line = 15;
+ __gen_e_acsl_assert_data_9.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
__e_acsl_assert_register_ptr(& __gen_e_acsl_assert_data_5,"&a",
@@ -291,10 +298,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_11.blocking = 1;
__gen_e_acsl_assert_data_11.kind = "RTE";
- __gen_e_acsl_assert_data_11.pred_txt = "separated_guard: \\valid_read(&array[0 .. 9])";
+ __gen_e_acsl_assert_data_11.pred_txt = "\\valid_read(&array[0 .. 9])";
__gen_e_acsl_assert_data_11.file = "separated.c";
__gen_e_acsl_assert_data_11.fct = "main";
__gen_e_acsl_assert_data_11.line = 21;
+ __gen_e_acsl_assert_data_11.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_8,
& __gen_e_acsl_assert_data_11);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_11);
@@ -322,10 +330,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "separated_guard: \\valid_read(&array[10 .. 19])";
+ __gen_e_acsl_assert_data_12.pred_txt = "\\valid_read(&array[10 .. 19])";
__gen_e_acsl_assert_data_12.file = "separated.c";
__gen_e_acsl_assert_data_12.fct = "main";
__gen_e_acsl_assert_data_12.line = 21;
+ __gen_e_acsl_assert_data_12.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_9,
& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
@@ -415,10 +424,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_14.blocking = 1;
__gen_e_acsl_assert_data_14.kind = "RTE";
- __gen_e_acsl_assert_data_14.pred_txt = "separated_guard: \\valid_read(&array[0 .. 10])";
+ __gen_e_acsl_assert_data_14.pred_txt = "\\valid_read(&array[0 .. 10])";
__gen_e_acsl_assert_data_14.file = "separated.c";
__gen_e_acsl_assert_data_14.fct = "main";
__gen_e_acsl_assert_data_14.line = 22;
+ __gen_e_acsl_assert_data_14.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_10,
& __gen_e_acsl_assert_data_14);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_14);
@@ -446,10 +456,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_15.blocking = 1;
__gen_e_acsl_assert_data_15.kind = "RTE";
- __gen_e_acsl_assert_data_15.pred_txt = "separated_guard: \\valid_read(&array[5 .. 15])";
+ __gen_e_acsl_assert_data_15.pred_txt = "\\valid_read(&array[5 .. 15])";
__gen_e_acsl_assert_data_15.file = "separated.c";
__gen_e_acsl_assert_data_15.fct = "main";
__gen_e_acsl_assert_data_15.line = 22;
+ __gen_e_acsl_assert_data_15.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_11,
& __gen_e_acsl_assert_data_15);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_15);
@@ -540,10 +551,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_17.blocking = 1;
__gen_e_acsl_assert_data_17.kind = "RTE";
- __gen_e_acsl_assert_data_17.pred_txt = "separated_guard: \\valid_read(&array[0 .. 19])";
+ __gen_e_acsl_assert_data_17.pred_txt = "\\valid_read(&array[0 .. 19])";
__gen_e_acsl_assert_data_17.file = "separated.c";
__gen_e_acsl_assert_data_17.fct = "main";
__gen_e_acsl_assert_data_17.line = 23;
+ __gen_e_acsl_assert_data_17.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_12,
& __gen_e_acsl_assert_data_17);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_17);
@@ -571,10 +583,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_18.blocking = 1;
__gen_e_acsl_assert_data_18.kind = "RTE";
- __gen_e_acsl_assert_data_18.pred_txt = "separated_guard: \\valid_read(&array[5 .. 15])";
+ __gen_e_acsl_assert_data_18.pred_txt = "\\valid_read(&array[5 .. 15])";
__gen_e_acsl_assert_data_18.file = "separated.c";
__gen_e_acsl_assert_data_18.fct = "main";
__gen_e_acsl_assert_data_18.line = 23;
+ __gen_e_acsl_assert_data_18.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_13,
& __gen_e_acsl_assert_data_18);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_18);
@@ -645,10 +658,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_20.blocking = 1;
__gen_e_acsl_assert_data_20.kind = "RTE";
- __gen_e_acsl_assert_data_20.pred_txt = "separated_guard: \\valid_read((double *)array)";
+ __gen_e_acsl_assert_data_20.pred_txt = "\\valid_read((double *)array)";
__gen_e_acsl_assert_data_20.file = "separated.c";
__gen_e_acsl_assert_data_20.fct = "main";
__gen_e_acsl_assert_data_20.line = 24;
+ __gen_e_acsl_assert_data_20.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_14,
& __gen_e_acsl_assert_data_20);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_20);
@@ -664,10 +678,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_21.blocking = 1;
__gen_e_acsl_assert_data_21.kind = "RTE";
- __gen_e_acsl_assert_data_21.pred_txt = "separated_guard: \\valid_read(&array[1])";
+ __gen_e_acsl_assert_data_21.pred_txt = "\\valid_read(&array[1])";
__gen_e_acsl_assert_data_21.file = "separated.c";
__gen_e_acsl_assert_data_21.fct = "main";
__gen_e_acsl_assert_data_21.line = 24;
+ __gen_e_acsl_assert_data_21.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_15,
& __gen_e_acsl_assert_data_21);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_21);
@@ -734,10 +749,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_23.blocking = 1;
__gen_e_acsl_assert_data_23.kind = "RTE";
- __gen_e_acsl_assert_data_23.pred_txt = "separated_guard: \\valid_read(&array[0 .. 1])";
+ __gen_e_acsl_assert_data_23.pred_txt = "\\valid_read(&array[0 .. 1])";
__gen_e_acsl_assert_data_23.file = "separated.c";
__gen_e_acsl_assert_data_23.fct = "main";
__gen_e_acsl_assert_data_23.line = 25;
+ __gen_e_acsl_assert_data_23.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_16,
& __gen_e_acsl_assert_data_23);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_23);
@@ -765,10 +781,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_24.blocking = 1;
__gen_e_acsl_assert_data_24.kind = "RTE";
- __gen_e_acsl_assert_data_24.pred_txt = "separated_guard: \\valid_read(&array[1 .. 2])";
+ __gen_e_acsl_assert_data_24.pred_txt = "\\valid_read(&array[1 .. 2])";
__gen_e_acsl_assert_data_24.file = "separated.c";
__gen_e_acsl_assert_data_24.fct = "main";
__gen_e_acsl_assert_data_24.line = 25;
+ __gen_e_acsl_assert_data_24.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_17,
& __gen_e_acsl_assert_data_24);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_24);
@@ -859,10 +876,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_26.blocking = 1;
__gen_e_acsl_assert_data_26.kind = "RTE";
- __gen_e_acsl_assert_data_26.pred_txt = "separated_guard: \\valid_read(&array[15 .. 5])";
+ __gen_e_acsl_assert_data_26.pred_txt = "\\valid_read(&array[15 .. 5])";
__gen_e_acsl_assert_data_26.file = "separated.c";
__gen_e_acsl_assert_data_26.fct = "main";
__gen_e_acsl_assert_data_26.line = 26;
+ __gen_e_acsl_assert_data_26.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_18,
& __gen_e_acsl_assert_data_26);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_26);
@@ -890,10 +908,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_27.blocking = 1;
__gen_e_acsl_assert_data_27.kind = "RTE";
- __gen_e_acsl_assert_data_27.pred_txt = "separated_guard: \\valid_read(&array[0 .. 19])";
+ __gen_e_acsl_assert_data_27.pred_txt = "\\valid_read(&array[0 .. 19])";
__gen_e_acsl_assert_data_27.file = "separated.c";
__gen_e_acsl_assert_data_27.fct = "main";
__gen_e_acsl_assert_data_27.line = 26;
+ __gen_e_acsl_assert_data_27.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_19,
& __gen_e_acsl_assert_data_27);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_27);
@@ -983,10 +1002,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_29.blocking = 1;
__gen_e_acsl_assert_data_29.kind = "RTE";
- __gen_e_acsl_assert_data_29.pred_txt = "separated_guard: \\valid_read(&array[0 .. -3])";
+ __gen_e_acsl_assert_data_29.pred_txt = "\\valid_read(&array[0 .. -3])";
__gen_e_acsl_assert_data_29.file = "separated.c";
__gen_e_acsl_assert_data_29.fct = "main";
__gen_e_acsl_assert_data_29.line = 27;
+ __gen_e_acsl_assert_data_29.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_20,
& __gen_e_acsl_assert_data_29);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_29);
@@ -1014,10 +1034,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_30.blocking = 1;
__gen_e_acsl_assert_data_30.kind = "RTE";
- __gen_e_acsl_assert_data_30.pred_txt = "separated_guard: \\valid_read(&array[0 .. 19])";
+ __gen_e_acsl_assert_data_30.pred_txt = "\\valid_read(&array[0 .. 19])";
__gen_e_acsl_assert_data_30.file = "separated.c";
__gen_e_acsl_assert_data_30.fct = "main";
__gen_e_acsl_assert_data_30.line = 27;
+ __gen_e_acsl_assert_data_30.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_21,
& __gen_e_acsl_assert_data_30);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_30);
@@ -1112,10 +1133,11 @@ int main(void)
else __gen_e_acsl_and_2 = 0;
__gen_e_acsl_assert_data_32.blocking = 1;
__gen_e_acsl_assert_data_32.kind = "RTE";
- __gen_e_acsl_assert_data_32.pred_txt = "separated_guard: \\valid_read(a_0)";
+ __gen_e_acsl_assert_data_32.pred_txt = "\\valid_read(a_0)";
__gen_e_acsl_assert_data_32.file = "separated.c";
__gen_e_acsl_assert_data_32.fct = "main";
__gen_e_acsl_assert_data_32.line = 36;
+ __gen_e_acsl_assert_data_32.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_and_2,& __gen_e_acsl_assert_data_32);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_32);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_33 =
@@ -1141,10 +1163,11 @@ int main(void)
else __gen_e_acsl_and_3 = 0;
__gen_e_acsl_assert_data_33.blocking = 1;
__gen_e_acsl_assert_data_33.kind = "RTE";
- __gen_e_acsl_assert_data_33.pred_txt = "separated_guard: \\valid_read(b_0)";
+ __gen_e_acsl_assert_data_33.pred_txt = "\\valid_read(b_0)";
__gen_e_acsl_assert_data_33.file = "separated.c";
__gen_e_acsl_assert_data_33.fct = "main";
__gen_e_acsl_assert_data_33.line = 36;
+ __gen_e_acsl_assert_data_33.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_and_3,& __gen_e_acsl_assert_data_33);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_33);
__e_acsl_assert_register_ptr(& __gen_e_acsl_assert_data_31,"a_0",
@@ -1205,10 +1228,11 @@ int main(void)
else __gen_e_acsl_and_4 = 0;
__gen_e_acsl_assert_data_35.blocking = 1;
__gen_e_acsl_assert_data_35.kind = "RTE";
- __gen_e_acsl_assert_data_35.pred_txt = "separated_guard: \\valid_read(a_0)";
+ __gen_e_acsl_assert_data_35.pred_txt = "\\valid_read(a_0)";
__gen_e_acsl_assert_data_35.file = "separated.c";
__gen_e_acsl_assert_data_35.fct = "main";
__gen_e_acsl_assert_data_35.line = 37;
+ __gen_e_acsl_assert_data_35.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_and_4,& __gen_e_acsl_assert_data_35);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_35);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_36 =
@@ -1234,10 +1258,11 @@ int main(void)
else __gen_e_acsl_and_5 = 0;
__gen_e_acsl_assert_data_36.blocking = 1;
__gen_e_acsl_assert_data_36.kind = "RTE";
- __gen_e_acsl_assert_data_36.pred_txt = "separated_guard: \\valid_read(b_0)";
+ __gen_e_acsl_assert_data_36.pred_txt = "\\valid_read(b_0)";
__gen_e_acsl_assert_data_36.file = "separated.c";
__gen_e_acsl_assert_data_36.fct = "main";
__gen_e_acsl_assert_data_36.line = 37;
+ __gen_e_acsl_assert_data_36.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_and_5,& __gen_e_acsl_assert_data_36);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_36);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_37 =
@@ -1263,10 +1288,11 @@ int main(void)
else __gen_e_acsl_and_6 = 0;
__gen_e_acsl_assert_data_37.blocking = 1;
__gen_e_acsl_assert_data_37.kind = "RTE";
- __gen_e_acsl_assert_data_37.pred_txt = "separated_guard: \\valid_read(c_0)";
+ __gen_e_acsl_assert_data_37.pred_txt = "\\valid_read(c_0)";
__gen_e_acsl_assert_data_37.file = "separated.c";
__gen_e_acsl_assert_data_37.fct = "main";
__gen_e_acsl_assert_data_37.line = 37;
+ __gen_e_acsl_assert_data_37.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_and_6,& __gen_e_acsl_assert_data_37);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_37);
__e_acsl_assert_register_ptr(& __gen_e_acsl_assert_data_34,"a_0",
@@ -1347,10 +1373,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_39.blocking = 1;
__gen_e_acsl_assert_data_39.kind = "RTE";
- __gen_e_acsl_assert_data_39.pred_txt = "separated_guard: \\valid_read(array_0 + (0 .. 9))";
+ __gen_e_acsl_assert_data_39.pred_txt = "\\valid_read(array_0 + (0 .. 9))";
__gen_e_acsl_assert_data_39.file = "separated.c";
__gen_e_acsl_assert_data_39.fct = "main";
__gen_e_acsl_assert_data_39.line = 46;
+ __gen_e_acsl_assert_data_39.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_27,
& __gen_e_acsl_assert_data_39);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_39);
@@ -1378,10 +1405,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_40.blocking = 1;
__gen_e_acsl_assert_data_40.kind = "RTE";
- __gen_e_acsl_assert_data_40.pred_txt = "separated_guard: \\valid_read(array_0 + (10 .. 19))";
+ __gen_e_acsl_assert_data_40.pred_txt = "\\valid_read(array_0 + (10 .. 19))";
__gen_e_acsl_assert_data_40.file = "separated.c";
__gen_e_acsl_assert_data_40.fct = "main";
__gen_e_acsl_assert_data_40.line = 46;
+ __gen_e_acsl_assert_data_40.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_28,
& __gen_e_acsl_assert_data_40);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_40);
@@ -1472,10 +1500,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_42.blocking = 1;
__gen_e_acsl_assert_data_42.kind = "RTE";
- __gen_e_acsl_assert_data_42.pred_txt = "separated_guard: \\valid_read(array_0 + (0 .. 10))";
+ __gen_e_acsl_assert_data_42.pred_txt = "\\valid_read(array_0 + (0 .. 10))";
__gen_e_acsl_assert_data_42.file = "separated.c";
__gen_e_acsl_assert_data_42.fct = "main";
__gen_e_acsl_assert_data_42.line = 47;
+ __gen_e_acsl_assert_data_42.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_29,
& __gen_e_acsl_assert_data_42);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_42);
@@ -1503,10 +1532,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_43.blocking = 1;
__gen_e_acsl_assert_data_43.kind = "RTE";
- __gen_e_acsl_assert_data_43.pred_txt = "separated_guard: \\valid_read(array_0 + (5 .. 15))";
+ __gen_e_acsl_assert_data_43.pred_txt = "\\valid_read(array_0 + (5 .. 15))";
__gen_e_acsl_assert_data_43.file = "separated.c";
__gen_e_acsl_assert_data_43.fct = "main";
__gen_e_acsl_assert_data_43.line = 47;
+ __gen_e_acsl_assert_data_43.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_30,
& __gen_e_acsl_assert_data_43);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_43);
@@ -1597,10 +1627,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_45.blocking = 1;
__gen_e_acsl_assert_data_45.kind = "RTE";
- __gen_e_acsl_assert_data_45.pred_txt = "separated_guard: \\valid_read(array_0 + (0 .. 19))";
+ __gen_e_acsl_assert_data_45.pred_txt = "\\valid_read(array_0 + (0 .. 19))";
__gen_e_acsl_assert_data_45.file = "separated.c";
__gen_e_acsl_assert_data_45.fct = "main";
__gen_e_acsl_assert_data_45.line = 48;
+ __gen_e_acsl_assert_data_45.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_31,
& __gen_e_acsl_assert_data_45);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_45);
@@ -1628,10 +1659,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_46.blocking = 1;
__gen_e_acsl_assert_data_46.kind = "RTE";
- __gen_e_acsl_assert_data_46.pred_txt = "separated_guard: \\valid_read(array_0 + (5 .. 15))";
+ __gen_e_acsl_assert_data_46.pred_txt = "\\valid_read(array_0 + (5 .. 15))";
__gen_e_acsl_assert_data_46.file = "separated.c";
__gen_e_acsl_assert_data_46.fct = "main";
__gen_e_acsl_assert_data_46.line = 48;
+ __gen_e_acsl_assert_data_46.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_32,
& __gen_e_acsl_assert_data_46);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_46);
@@ -1702,10 +1734,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_48.blocking = 1;
__gen_e_acsl_assert_data_48.kind = "RTE";
- __gen_e_acsl_assert_data_48.pred_txt = "separated_guard: \\valid_read(array_0 + 0)";
+ __gen_e_acsl_assert_data_48.pred_txt = "\\valid_read(array_0 + 0)";
__gen_e_acsl_assert_data_48.file = "separated.c";
__gen_e_acsl_assert_data_48.fct = "main";
__gen_e_acsl_assert_data_48.line = 49;
+ __gen_e_acsl_assert_data_48.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_33,
& __gen_e_acsl_assert_data_48);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_48);
@@ -1721,10 +1754,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_49.blocking = 1;
__gen_e_acsl_assert_data_49.kind = "RTE";
- __gen_e_acsl_assert_data_49.pred_txt = "separated_guard: \\valid_read(array_0 + 1)";
+ __gen_e_acsl_assert_data_49.pred_txt = "\\valid_read(array_0 + 1)";
__gen_e_acsl_assert_data_49.file = "separated.c";
__gen_e_acsl_assert_data_49.fct = "main";
__gen_e_acsl_assert_data_49.line = 49;
+ __gen_e_acsl_assert_data_49.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_34,
& __gen_e_acsl_assert_data_49);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_49);
@@ -1792,10 +1826,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_51.blocking = 1;
__gen_e_acsl_assert_data_51.kind = "RTE";
- __gen_e_acsl_assert_data_51.pred_txt = "separated_guard: \\valid_read(array_0 + (0 .. 1))";
+ __gen_e_acsl_assert_data_51.pred_txt = "\\valid_read(array_0 + (0 .. 1))";
__gen_e_acsl_assert_data_51.file = "separated.c";
__gen_e_acsl_assert_data_51.fct = "main";
__gen_e_acsl_assert_data_51.line = 50;
+ __gen_e_acsl_assert_data_51.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_35,
& __gen_e_acsl_assert_data_51);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_51);
@@ -1823,10 +1858,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_52.blocking = 1;
__gen_e_acsl_assert_data_52.kind = "RTE";
- __gen_e_acsl_assert_data_52.pred_txt = "separated_guard: \\valid_read(array_0 + (1 .. 2))";
+ __gen_e_acsl_assert_data_52.pred_txt = "\\valid_read(array_0 + (1 .. 2))";
__gen_e_acsl_assert_data_52.file = "separated.c";
__gen_e_acsl_assert_data_52.fct = "main";
__gen_e_acsl_assert_data_52.line = 50;
+ __gen_e_acsl_assert_data_52.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_36,
& __gen_e_acsl_assert_data_52);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_52);
@@ -1917,10 +1953,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_54.blocking = 1;
__gen_e_acsl_assert_data_54.kind = "RTE";
- __gen_e_acsl_assert_data_54.pred_txt = "separated_guard: \\valid_read(array_0 + (15 .. 5))";
+ __gen_e_acsl_assert_data_54.pred_txt = "\\valid_read(array_0 + (15 .. 5))";
__gen_e_acsl_assert_data_54.file = "separated.c";
__gen_e_acsl_assert_data_54.fct = "main";
__gen_e_acsl_assert_data_54.line = 51;
+ __gen_e_acsl_assert_data_54.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_37,
& __gen_e_acsl_assert_data_54);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_54);
@@ -1948,10 +1985,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_55.blocking = 1;
__gen_e_acsl_assert_data_55.kind = "RTE";
- __gen_e_acsl_assert_data_55.pred_txt = "separated_guard: \\valid_read(array_0 + (0 .. 19))";
+ __gen_e_acsl_assert_data_55.pred_txt = "\\valid_read(array_0 + (0 .. 19))";
__gen_e_acsl_assert_data_55.file = "separated.c";
__gen_e_acsl_assert_data_55.fct = "main";
__gen_e_acsl_assert_data_55.line = 51;
+ __gen_e_acsl_assert_data_55.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_38,
& __gen_e_acsl_assert_data_55);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_55);
@@ -2042,10 +2080,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_57.blocking = 1;
__gen_e_acsl_assert_data_57.kind = "RTE";
- __gen_e_acsl_assert_data_57.pred_txt = "separated_guard: \\valid_read(array_0 + (0 .. -3))";
+ __gen_e_acsl_assert_data_57.pred_txt = "\\valid_read(array_0 + (0 .. -3))";
__gen_e_acsl_assert_data_57.file = "separated.c";
__gen_e_acsl_assert_data_57.fct = "main";
__gen_e_acsl_assert_data_57.line = 52;
+ __gen_e_acsl_assert_data_57.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_39,
& __gen_e_acsl_assert_data_57);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_57);
@@ -2073,10 +2112,11 @@ int main(void)
(void *)(& array_0));
__gen_e_acsl_assert_data_58.blocking = 1;
__gen_e_acsl_assert_data_58.kind = "RTE";
- __gen_e_acsl_assert_data_58.pred_txt = "separated_guard: \\valid_read(array_0 + (0 .. 19))";
+ __gen_e_acsl_assert_data_58.pred_txt = "\\valid_read(array_0 + (0 .. 19))";
__gen_e_acsl_assert_data_58.file = "separated.c";
__gen_e_acsl_assert_data_58.fct = "main";
__gen_e_acsl_assert_data_58.line = 52;
+ __gen_e_acsl_assert_data_58.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_40,
& __gen_e_acsl_assert_data_58);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_58);
@@ -2170,10 +2210,11 @@ int main(void)
e_acsl_end_loop1: ;
__gen_e_acsl_assert_data_60.blocking = 1;
__gen_e_acsl_assert_data_60.kind = "RTE";
- __gen_e_acsl_assert_data_60.pred_txt = "separated_guard: \\valid_read(&array_1[0][0 .. 2][0])";
+ __gen_e_acsl_assert_data_60.pred_txt = "\\valid_read(&array_1[0][0 .. 2][0])";
__gen_e_acsl_assert_data_60.file = "separated.c";
__gen_e_acsl_assert_data_60.fct = "main";
__gen_e_acsl_assert_data_60.line = 60;
+ __gen_e_acsl_assert_data_60.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall,& __gen_e_acsl_assert_data_60);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_61 =
{.values = (void *)0};
@@ -2198,10 +2239,11 @@ int main(void)
e_acsl_end_loop2: ;
__gen_e_acsl_assert_data_61.blocking = 1;
__gen_e_acsl_assert_data_61.kind = "RTE";
- __gen_e_acsl_assert_data_61.pred_txt = "separated_guard: \\valid_read(&array_1[0][3 .. 5][0])";
+ __gen_e_acsl_assert_data_61.pred_txt = "\\valid_read(&array_1[0][3 .. 5][0])";
__gen_e_acsl_assert_data_61.file = "separated.c";
__gen_e_acsl_assert_data_61.fct = "main";
__gen_e_acsl_assert_data_61.line = 60;
+ __gen_e_acsl_assert_data_61.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_2,& __gen_e_acsl_assert_data_61);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_62 =
{.values = (void *)0};
@@ -2226,10 +2268,11 @@ int main(void)
e_acsl_end_loop3: ;
__gen_e_acsl_assert_data_62.blocking = 1;
__gen_e_acsl_assert_data_62.kind = "RTE";
- __gen_e_acsl_assert_data_62.pred_txt = "separated_guard: \\valid_read(&array_1[0][6 .. 9][0])";
+ __gen_e_acsl_assert_data_62.pred_txt = "\\valid_read(&array_1[0][6 .. 9][0])";
__gen_e_acsl_assert_data_62.file = "separated.c";
__gen_e_acsl_assert_data_62.fct = "main";
__gen_e_acsl_assert_data_62.line = 60;
+ __gen_e_acsl_assert_data_62.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_3,& __gen_e_acsl_assert_data_62);
__gen_e_acsl_forall_4 = 1;
__gen_e_acsl_range_4 = 6;
@@ -2268,10 +2311,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_63.blocking = 1;
__gen_e_acsl_assert_data_63.kind = "RTE";
- __gen_e_acsl_assert_data_63.pred_txt = "separated_guard: \\valid_read(&array_1[0][range_6][0])";
+ __gen_e_acsl_assert_data_63.pred_txt = "\\valid_read(&array_1[0][range_6][0])";
__gen_e_acsl_assert_data_63.file = "separated.c";
__gen_e_acsl_assert_data_63.fct = "main";
__gen_e_acsl_assert_data_63.line = 60;
+ __gen_e_acsl_assert_data_63.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_44,
& __gen_e_acsl_assert_data_63);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_63);
@@ -2289,10 +2333,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_64.blocking = 1;
__gen_e_acsl_assert_data_64.kind = "RTE";
- __gen_e_acsl_assert_data_64.pred_txt = "separated_guard: \\valid_read(&array_1[0][range_5][0])";
+ __gen_e_acsl_assert_data_64.pred_txt = "\\valid_read(&array_1[0][range_5][0])";
__gen_e_acsl_assert_data_64.file = "separated.c";
__gen_e_acsl_assert_data_64.fct = "main";
__gen_e_acsl_assert_data_64.line = 60;
+ __gen_e_acsl_assert_data_64.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_45,
& __gen_e_acsl_assert_data_64);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_64);
@@ -2310,10 +2355,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_65.blocking = 1;
__gen_e_acsl_assert_data_65.kind = "RTE";
- __gen_e_acsl_assert_data_65.pred_txt = "separated_guard: \\valid_read(&array_1[0][range_4][0])";
+ __gen_e_acsl_assert_data_65.pred_txt = "\\valid_read(&array_1[0][range_4][0])";
__gen_e_acsl_assert_data_65.file = "separated.c";
__gen_e_acsl_assert_data_65.fct = "main";
__gen_e_acsl_assert_data_65.line = 60;
+ __gen_e_acsl_assert_data_65.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_46,
& __gen_e_acsl_assert_data_65);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_65);
@@ -2407,10 +2453,11 @@ int main(void)
e_acsl_end_loop7: ;
__gen_e_acsl_assert_data_67.blocking = 1;
__gen_e_acsl_assert_data_67.kind = "RTE";
- __gen_e_acsl_assert_data_67.pred_txt = "separated_guard: \\valid_read(&array_1[0][0 .. 2][0])";
+ __gen_e_acsl_assert_data_67.pred_txt = "\\valid_read(&array_1[0][0 .. 2][0])";
__gen_e_acsl_assert_data_67.file = "separated.c";
__gen_e_acsl_assert_data_67.fct = "main";
__gen_e_acsl_assert_data_67.line = 61;
+ __gen_e_acsl_assert_data_67.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_7,& __gen_e_acsl_assert_data_67);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_68 =
{.values = (void *)0};
@@ -2435,10 +2482,11 @@ int main(void)
e_acsl_end_loop8: ;
__gen_e_acsl_assert_data_68.blocking = 1;
__gen_e_acsl_assert_data_68.kind = "RTE";
- __gen_e_acsl_assert_data_68.pred_txt = "separated_guard: \\valid_read(&array_1[1][0 .. 2][0])";
+ __gen_e_acsl_assert_data_68.pred_txt = "\\valid_read(&array_1[1][0 .. 2][0])";
__gen_e_acsl_assert_data_68.file = "separated.c";
__gen_e_acsl_assert_data_68.fct = "main";
__gen_e_acsl_assert_data_68.line = 61;
+ __gen_e_acsl_assert_data_68.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_8,& __gen_e_acsl_assert_data_68);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_69 =
{.values = (void *)0};
@@ -2463,10 +2511,11 @@ int main(void)
e_acsl_end_loop9: ;
__gen_e_acsl_assert_data_69.blocking = 1;
__gen_e_acsl_assert_data_69.kind = "RTE";
- __gen_e_acsl_assert_data_69.pred_txt = "separated_guard: \\valid_read(&array_1[2][0 .. 2][0])";
+ __gen_e_acsl_assert_data_69.pred_txt = "\\valid_read(&array_1[2][0 .. 2][0])";
__gen_e_acsl_assert_data_69.file = "separated.c";
__gen_e_acsl_assert_data_69.fct = "main";
__gen_e_acsl_assert_data_69.line = 61;
+ __gen_e_acsl_assert_data_69.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_9,& __gen_e_acsl_assert_data_69);
__gen_e_acsl_forall_10 = 1;
__gen_e_acsl_range_10 = 0;
@@ -2505,10 +2554,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_70.blocking = 1;
__gen_e_acsl_assert_data_70.kind = "RTE";
- __gen_e_acsl_assert_data_70.pred_txt = "separated_guard: \\valid_read(&array_1[0][range_12][0])";
+ __gen_e_acsl_assert_data_70.pred_txt = "\\valid_read(&array_1[0][range_12][0])";
__gen_e_acsl_assert_data_70.file = "separated.c";
__gen_e_acsl_assert_data_70.fct = "main";
__gen_e_acsl_assert_data_70.line = 61;
+ __gen_e_acsl_assert_data_70.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_50,
& __gen_e_acsl_assert_data_70);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_70);
@@ -2526,10 +2576,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_71.blocking = 1;
__gen_e_acsl_assert_data_71.kind = "RTE";
- __gen_e_acsl_assert_data_71.pred_txt = "separated_guard: \\valid_read(&array_1[1][range_11][0])";
+ __gen_e_acsl_assert_data_71.pred_txt = "\\valid_read(&array_1[1][range_11][0])";
__gen_e_acsl_assert_data_71.file = "separated.c";
__gen_e_acsl_assert_data_71.fct = "main";
__gen_e_acsl_assert_data_71.line = 61;
+ __gen_e_acsl_assert_data_71.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_51,
& __gen_e_acsl_assert_data_71);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_71);
@@ -2547,10 +2598,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_72.blocking = 1;
__gen_e_acsl_assert_data_72.kind = "RTE";
- __gen_e_acsl_assert_data_72.pred_txt = "separated_guard: \\valid_read(&array_1[2][range_10][0])";
+ __gen_e_acsl_assert_data_72.pred_txt = "\\valid_read(&array_1[2][range_10][0])";
__gen_e_acsl_assert_data_72.file = "separated.c";
__gen_e_acsl_assert_data_72.fct = "main";
__gen_e_acsl_assert_data_72.line = 61;
+ __gen_e_acsl_assert_data_72.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_52,
& __gen_e_acsl_assert_data_72);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_72);
@@ -2658,10 +2710,11 @@ int main(void)
e_acsl_end_loop14: ;
__gen_e_acsl_assert_data_74.blocking = 1;
__gen_e_acsl_assert_data_74.kind = "RTE";
- __gen_e_acsl_assert_data_74.pred_txt = "separated_guard: \\valid_read(&array_1[0 .. 2][0 .. 2][0])";
+ __gen_e_acsl_assert_data_74.pred_txt = "\\valid_read(&array_1[0 .. 2][0 .. 2][0])";
__gen_e_acsl_assert_data_74.file = "separated.c";
__gen_e_acsl_assert_data_74.fct = "main";
__gen_e_acsl_assert_data_74.line = 62;
+ __gen_e_acsl_assert_data_74.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_13,& __gen_e_acsl_assert_data_74);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_75 =
{.values = (void *)0};
@@ -2702,10 +2755,11 @@ int main(void)
e_acsl_end_loop16: ;
__gen_e_acsl_assert_data_75.blocking = 1;
__gen_e_acsl_assert_data_75.kind = "RTE";
- __gen_e_acsl_assert_data_75.pred_txt = "separated_guard: \\valid_read(&array_1[0 .. 2][3 .. 5][0])";
+ __gen_e_acsl_assert_data_75.pred_txt = "\\valid_read(&array_1[0 .. 2][3 .. 5][0])";
__gen_e_acsl_assert_data_75.file = "separated.c";
__gen_e_acsl_assert_data_75.fct = "main";
__gen_e_acsl_assert_data_75.line = 62;
+ __gen_e_acsl_assert_data_75.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_15,& __gen_e_acsl_assert_data_75);
__gen_e_acsl_forall_17 = 1;
__gen_e_acsl_range_18 = 3;
@@ -2749,10 +2803,11 @@ int main(void)
sizeof(double),(void *)(& array_1[0][0][0]),(void *)0);
__gen_e_acsl_assert_data_76.blocking = 1;
__gen_e_acsl_assert_data_76.kind = "RTE";
- __gen_e_acsl_assert_data_76.pred_txt = "separated_guard: \\valid_read(&array_1[range_19][range_20][0])";
+ __gen_e_acsl_assert_data_76.pred_txt = "\\valid_read(&array_1[range_19][range_20][0])";
__gen_e_acsl_assert_data_76.file = "separated.c";
__gen_e_acsl_assert_data_76.fct = "main";
__gen_e_acsl_assert_data_76.line = 62;
+ __gen_e_acsl_assert_data_76.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_55,
& __gen_e_acsl_assert_data_76);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_76);
@@ -2769,10 +2824,11 @@ int main(void)
sizeof(double),(void *)(& array_1[0][0][0]),(void *)0);
__gen_e_acsl_assert_data_77.blocking = 1;
__gen_e_acsl_assert_data_77.kind = "RTE";
- __gen_e_acsl_assert_data_77.pred_txt = "separated_guard: \\valid_read(&array_1[range_17][range_18][0])";
+ __gen_e_acsl_assert_data_77.pred_txt = "\\valid_read(&array_1[range_17][range_18][0])";
__gen_e_acsl_assert_data_77.file = "separated.c";
__gen_e_acsl_assert_data_77.fct = "main";
__gen_e_acsl_assert_data_77.line = 62;
+ __gen_e_acsl_assert_data_77.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_56,
& __gen_e_acsl_assert_data_77);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_77);
@@ -2884,10 +2940,11 @@ int main(void)
e_acsl_end_loop22: ;
__gen_e_acsl_assert_data_79.blocking = 1;
__gen_e_acsl_assert_data_79.kind = "RTE";
- __gen_e_acsl_assert_data_79.pred_txt = "separated_guard: \\valid_read(&array_1[0 .. 3][0 .. 2][0])";
+ __gen_e_acsl_assert_data_79.pred_txt = "\\valid_read(&array_1[0 .. 3][0 .. 2][0])";
__gen_e_acsl_assert_data_79.file = "separated.c";
__gen_e_acsl_assert_data_79.fct = "main";
__gen_e_acsl_assert_data_79.line = 63;
+ __gen_e_acsl_assert_data_79.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_21,& __gen_e_acsl_assert_data_79);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_80 =
{.values = (void *)0};
@@ -2928,10 +2985,11 @@ int main(void)
e_acsl_end_loop24: ;
__gen_e_acsl_assert_data_80.blocking = 1;
__gen_e_acsl_assert_data_80.kind = "RTE";
- __gen_e_acsl_assert_data_80.pred_txt = "separated_guard: \\valid_read(&array_1[3 .. 5][0 .. 2][0])";
+ __gen_e_acsl_assert_data_80.pred_txt = "\\valid_read(&array_1[3 .. 5][0 .. 2][0])";
__gen_e_acsl_assert_data_80.file = "separated.c";
__gen_e_acsl_assert_data_80.fct = "main";
__gen_e_acsl_assert_data_80.line = 63;
+ __gen_e_acsl_assert_data_80.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_23,& __gen_e_acsl_assert_data_80);
__gen_e_acsl_forall_25 = 1;
__gen_e_acsl_range_26 = 0;
@@ -2975,10 +3033,11 @@ int main(void)
sizeof(double),(void *)(& array_1[0][0][0]),(void *)0);
__gen_e_acsl_assert_data_81.blocking = 1;
__gen_e_acsl_assert_data_81.kind = "RTE";
- __gen_e_acsl_assert_data_81.pred_txt = "separated_guard: \\valid_read(&array_1[range_27][range_28][0])";
+ __gen_e_acsl_assert_data_81.pred_txt = "\\valid_read(&array_1[range_27][range_28][0])";
__gen_e_acsl_assert_data_81.file = "separated.c";
__gen_e_acsl_assert_data_81.fct = "main";
__gen_e_acsl_assert_data_81.line = 63;
+ __gen_e_acsl_assert_data_81.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_59,
& __gen_e_acsl_assert_data_81);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_81);
@@ -2995,10 +3054,11 @@ int main(void)
sizeof(double),(void *)(& array_1[0][0][0]),(void *)0);
__gen_e_acsl_assert_data_82.blocking = 1;
__gen_e_acsl_assert_data_82.kind = "RTE";
- __gen_e_acsl_assert_data_82.pred_txt = "separated_guard: \\valid_read(&array_1[range_25][range_26][0])";
+ __gen_e_acsl_assert_data_82.pred_txt = "\\valid_read(&array_1[range_25][range_26][0])";
__gen_e_acsl_assert_data_82.file = "separated.c";
__gen_e_acsl_assert_data_82.fct = "main";
__gen_e_acsl_assert_data_82.line = 63;
+ __gen_e_acsl_assert_data_82.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_60,
& __gen_e_acsl_assert_data_82);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_82);
@@ -3073,10 +3133,11 @@ int main(void)
{.values = (void *)0};
__gen_e_acsl_assert_data_84.blocking = 1;
__gen_e_acsl_assert_data_84.kind = "RTE";
- __gen_e_acsl_assert_data_84.pred_txt = "separated_guard: \\valid_read(&array_1[0 .. 3][2 .. 0][0])";
+ __gen_e_acsl_assert_data_84.pred_txt = "\\valid_read(&array_1[0 .. 3][2 .. 0][0])";
__gen_e_acsl_assert_data_84.file = "separated.c";
__gen_e_acsl_assert_data_84.fct = "main";
__gen_e_acsl_assert_data_84.line = 64;
+ __gen_e_acsl_assert_data_84.name = "separated_guard";
__e_acsl_assert(1,& __gen_e_acsl_assert_data_84);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_85 =
{.values = (void *)0};
@@ -3117,10 +3178,11 @@ int main(void)
e_acsl_end_loop30: ;
__gen_e_acsl_assert_data_85.blocking = 1;
__gen_e_acsl_assert_data_85.kind = "RTE";
- __gen_e_acsl_assert_data_85.pred_txt = "separated_guard: \\valid_read(&array_1[3 .. 5][0 .. 2][0])";
+ __gen_e_acsl_assert_data_85.pred_txt = "\\valid_read(&array_1[3 .. 5][0 .. 2][0])";
__gen_e_acsl_assert_data_85.file = "separated.c";
__gen_e_acsl_assert_data_85.fct = "main";
__gen_e_acsl_assert_data_85.line = 64;
+ __gen_e_acsl_assert_data_85.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_forall_29,& __gen_e_acsl_assert_data_85);
__gen_e_acsl_forall_31 = 1;
__gen_e_acsl_range_34 = 0;
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_valid.c b/src/plugins/e-acsl/tests/memory/oracle/gen_valid.c
index bda841adb2e2f5ce53e30232358472d1a60c9559..e31b81cecdec52d7f0f6adcf31079b1fe00b58b1 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_valid.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_valid.c
@@ -137,10 +137,11 @@ void g(void)
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_2.file = "valid.c";
__gen_e_acsl_assert_data_2.fct = "g";
__gen_e_acsl_assert_data_2.line = 24;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data,
@@ -707,10 +708,11 @@ int main(void)
else __gen_e_acsl_and_21 = 0;
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "mem_access: \\valid_read(c)";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\valid_read(c)";
__gen_e_acsl_assert_data_7.file = "valid.c";
__gen_e_acsl_assert_data_7.fct = "main";
__gen_e_acsl_assert_data_7.line = 40;
+ __gen_e_acsl_assert_data_7.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_21,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_6,
@@ -764,10 +766,11 @@ int main(void)
else __gen_e_acsl_and_23 = 0;
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "mem_access: \\valid_read(d)";
+ __gen_e_acsl_assert_data_9.pred_txt = "\\valid_read(d)";
__gen_e_acsl_assert_data_9.file = "valid.c";
__gen_e_acsl_assert_data_9.fct = "main";
__gen_e_acsl_assert_data_9.line = 41;
+ __gen_e_acsl_assert_data_9.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_23,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_8,
@@ -822,10 +825,11 @@ int main(void)
else __gen_e_acsl_and_24 = 0;
__gen_e_acsl_assert_data_11.blocking = 1;
__gen_e_acsl_assert_data_11.kind = "RTE";
- __gen_e_acsl_assert_data_11.pred_txt = "mem_access: \\valid_read(d)";
+ __gen_e_acsl_assert_data_11.pred_txt = "\\valid_read(d)";
__gen_e_acsl_assert_data_11.file = "valid.c";
__gen_e_acsl_assert_data_11.fct = "main";
__gen_e_acsl_assert_data_11.line = 41;
+ __gen_e_acsl_assert_data_11.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_24,& __gen_e_acsl_assert_data_11);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_11);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_10,
@@ -838,10 +842,11 @@ int main(void)
else __gen_e_acsl_and_25 = 0;
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "mem_access: \\valid_read(*d)";
+ __gen_e_acsl_assert_data_10.pred_txt = "\\valid_read(*d)";
__gen_e_acsl_assert_data_10.file = "valid.c";
__gen_e_acsl_assert_data_10.fct = "main";
__gen_e_acsl_assert_data_10.line = 41;
+ __gen_e_acsl_assert_data_10.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_25,& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_12 =
@@ -867,10 +872,11 @@ int main(void)
else __gen_e_acsl_and_26 = 0;
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "mem_access: \\valid_read(d)";
+ __gen_e_acsl_assert_data_12.pred_txt = "\\valid_read(d)";
__gen_e_acsl_assert_data_12.file = "valid.c";
__gen_e_acsl_assert_data_12.fct = "main";
__gen_e_acsl_assert_data_12.line = 41;
+ __gen_e_acsl_assert_data_12.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_26,& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_8,
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_valid_alias.c b/src/plugins/e-acsl/tests/memory/oracle/gen_valid_alias.c
index a811107fd53e2e84aaa519acf560fdcda3b56711..b8ce6271bbc724546205a7448ba1b89d8d298cd6 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_valid_alias.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_valid_alias.c
@@ -182,10 +182,11 @@ int main(void)
else __gen_e_acsl_and_7 = 0;
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "mem_access: \\valid_read(b)";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(b)";
__gen_e_acsl_assert_data_4.file = "valid_alias.c";
__gen_e_acsl_assert_data_4.fct = "main";
__gen_e_acsl_assert_data_4.line = 14;
+ __gen_e_acsl_assert_data_4.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_7,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__gen_e_acsl_assert_data_3.blocking = 1;
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_valid_in_contract.c b/src/plugins/e-acsl/tests/memory/oracle/gen_valid_in_contract.c
index 3f991258a7a5a788b0ab392aa773b26737cfd379..087ef8783af5880fa77f4caf88562952160d686c 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_valid_in_contract.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_valid_in_contract.c
@@ -102,10 +102,11 @@ struct list *__gen_e_acsl_f(struct list *l)
(void *)0);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "RTE";
- __gen_e_acsl_assert_data.pred_txt = "mem_access: \\valid_read(&l->next)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid_read(&l->next)";
__gen_e_acsl_assert_data.file = "valid_in_contract.c";
__gen_e_acsl_assert_data.fct = "f";
__gen_e_acsl_assert_data.line = 17;
+ __gen_e_acsl_assert_data.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
__gen_e_acsl_valid_2 = __e_acsl_valid((void *)l->next,
@@ -136,10 +137,11 @@ struct list *__gen_e_acsl_f(struct list *l)
(void *)__gen_e_acsl_at);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "B1: \\result == \\old(l)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == \\old(l)";
__gen_e_acsl_assert_data_2.file = "valid_in_contract.c";
__gen_e_acsl_assert_data_2.fct = "f";
__gen_e_acsl_assert_data_2.line = 15;
+ __gen_e_acsl_assert_data_2.name = "B1";
__e_acsl_assert(__retres == __gen_e_acsl_at,
& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
@@ -155,10 +157,11 @@ struct list *__gen_e_acsl_f(struct list *l)
(void *)__gen_e_acsl_at_2);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "B2: \\result == \\old(l)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result == \\old(l)";
__gen_e_acsl_assert_data_3.file = "valid_in_contract.c";
__gen_e_acsl_assert_data_3.fct = "f";
__gen_e_acsl_assert_data_3.line = 18;
+ __gen_e_acsl_assert_data_3.name = "B2";
__e_acsl_assert(__retres == __gen_e_acsl_at_2,
& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_vdso.c b/src/plugins/e-acsl/tests/memory/oracle/gen_vdso.c
index d5cddaab78c0d75871ebb9b51ea91d44b38bb3df..54be1732403f281be5d49021696b420322544072 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_vdso.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_vdso.c
@@ -81,10 +81,11 @@ time_t __gen_e_acsl_time(time_t *timer)
"\\valid(timer)",0,__gen_e_acsl_valid);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Precondition";
- __gen_e_acsl_assert_data.pred_txt = "not_null: valid_timer: \\valid(timer)";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid(timer)";
__gen_e_acsl_assert_data.file = "FRAMAC_SHARE/libc/time.h";
__gen_e_acsl_assert_data.fct = "time";
__gen_e_acsl_assert_data.line = 102;
+ __gen_e_acsl_assert_data.name = "not_null/valid_timer";
__e_acsl_assert(__gen_e_acsl_valid,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -142,10 +143,11 @@ time_t __gen_e_acsl_time(time_t *timer)
0,__gen_e_acsl_initialized);
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "Postcondition";
- __gen_e_acsl_assert_data_4.pred_txt = "not_null: initialization: timer: \\initialized(\\old(timer))";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\initialized(\\old(timer))";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/time.h";
__gen_e_acsl_assert_data_4.fct = "time";
__gen_e_acsl_assert_data_4.line = 104;
+ __gen_e_acsl_assert_data_4.name = "not_null/initialization/timer";
__e_acsl_assert(__gen_e_acsl_initialized,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
}
diff --git a/src/plugins/e-acsl/tests/memory/oracle/gen_vla.c b/src/plugins/e-acsl/tests/memory/oracle/gen_vla.c
index 38a7638daba3787939cdf71d48a73b12670ad300..7475c0099eff80cccee76ee0137b847b97b8a2c1 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/gen_vla.c
+++ b/src/plugins/e-acsl/tests/memory/oracle/gen_vla.c
@@ -39,10 +39,11 @@ int main(int argc, char **argv)
else __gen_e_acsl_and = 0;
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Assertion";
- __gen_e_acsl_assert_data.pred_txt = "alloca_bounds: 0 < sizeof(int) * LEN <= 18446744073709551615";
+ __gen_e_acsl_assert_data.pred_txt = "0 < sizeof(int) * LEN <= 18446744073709551615";
__gen_e_acsl_assert_data.file = "vla.c";
__gen_e_acsl_assert_data.fct = "main";
__gen_e_acsl_assert_data.line = 9;
+ __gen_e_acsl_assert_data.name = "alloca_bounds";
__e_acsl_assert(__gen_e_acsl_and,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
diff --git a/src/plugins/e-acsl/tests/special/oracle/gen_e-acsl-functions.c b/src/plugins/e-acsl/tests/special/oracle/gen_e-acsl-functions.c
index b3c766498c673e1ff8f2900299ff777e5aebaded..1eda3264b1fe3bb63c5d9840eb9515541ac963b7 100644
--- a/src/plugins/e-acsl/tests/special/oracle/gen_e-acsl-functions.c
+++ b/src/plugins/e-acsl/tests/special/oracle/gen_e-acsl-functions.c
@@ -135,10 +135,11 @@ int __gen_e_acsl_f(int *p)
(void *)p,(void *)(& p));
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_3.file = "e-acsl-functions.c";
__gen_e_acsl_assert_data_3.fct = "f";
__gen_e_acsl_assert_data_3.line = 10;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__gen_e_acsl_assert_data_2.blocking = 1;
@@ -161,10 +162,11 @@ int __gen_e_acsl_f(int *p)
(void *)p,(void *)(& p));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_5.file = "e-acsl-functions.c";
__gen_e_acsl_assert_data_5.fct = "f";
__gen_e_acsl_assert_data_5.line = 11;
+ __gen_e_acsl_assert_data_5.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__gen_e_acsl_at = *p;
diff --git a/src/plugins/e-acsl/tests/special/oracle/gen_e-acsl-valid.c b/src/plugins/e-acsl/tests/special/oracle/gen_e-acsl-valid.c
index 9dc6068e7e4164ce9b54323ea632104cf5aca96b..55c6aca7000fd2ee546ca5aceeebd65fa4c4e3c4 100644
--- a/src/plugins/e-acsl/tests/special/oracle/gen_e-acsl-valid.c
+++ b/src/plugins/e-acsl/tests/special/oracle/gen_e-acsl-valid.c
@@ -50,10 +50,11 @@ void f(int *x, int *y)
(void *)x,(void *)(& x));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(x)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(x)";
__gen_e_acsl_assert_data_2.file = "e-acsl-valid.c";
__gen_e_acsl_assert_data_2.fct = "f";
__gen_e_acsl_assert_data_2.line = 27;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__gen_e_acsl_assert_data.blocking = 1;
@@ -201,10 +202,11 @@ void __gen_e_acsl_f(int *x, int *y)
(void *)x,(void *)(& x));
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "RTE";
- __gen_e_acsl_assert_data_2.pred_txt = "mem_access: \\valid_read(x)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read(x)";
__gen_e_acsl_assert_data_2.file = "e-acsl-valid.c";
__gen_e_acsl_assert_data_2.fct = "f";
__gen_e_acsl_assert_data_2.line = 17;
+ __gen_e_acsl_assert_data_2.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_contract_set_behavior_assumes(__gen_e_acsl_contract,(size_t)0,
@@ -218,10 +220,11 @@ void __gen_e_acsl_f(int *x, int *y)
(void *)x,(void *)(& x));
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(x)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(x)";
__gen_e_acsl_assert_data_3.file = "e-acsl-valid.c";
__gen_e_acsl_assert_data_3.fct = "f";
__gen_e_acsl_assert_data_3.line = 21;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_contract_set_behavior_assumes(__gen_e_acsl_contract,(size_t)1,
diff --git a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_args.c b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_args.c
index b11ba3e4f62390cc8337dc01caca723a0ad68501..22c52cd04b65be0d1030740c8c03bcfea2508a35 100644
--- a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_args.c
+++ b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_args.c
@@ -89,10 +89,11 @@ int main(int argc, char const **argv)
(void *)(& argv));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "mem_access: \\valid_read(argv)";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read(argv)";
__gen_e_acsl_assert_data_4.file = "t_args.c";
__gen_e_acsl_assert_data_4.fct = "main";
__gen_e_acsl_assert_data_4.line = 10;
+ __gen_e_acsl_assert_data_4.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_3,
diff --git a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_darray.c b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_darray.c
index 5fcb2978a3fec9d5507530b2344c680a2b0dfe7e..2e9704213ce3e0be2049df9b017886e7095d2881 100644
--- a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_darray.c
+++ b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_darray.c
@@ -29,10 +29,11 @@ void area_triangle(double (*vertices)[4])
0,__gen_e_acsl_valid_read);
__gen_e_acsl_assert_data.blocking = 1;
__gen_e_acsl_assert_data.kind = "Assertion";
- __gen_e_acsl_assert_data.pred_txt = "rte: mem_access: \\valid_read((double *)*(vertices + 0))";
+ __gen_e_acsl_assert_data.pred_txt = "\\valid_read((double *)*(vertices + 0))";
__gen_e_acsl_assert_data.file = "t_darray.c";
__gen_e_acsl_assert_data.fct = "area_triangle";
__gen_e_acsl_assert_data.line = 6;
+ __gen_e_acsl_assert_data.name = "rte/mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data);
}
@@ -55,10 +56,11 @@ void area_triangle(double (*vertices)[4])
0,__gen_e_acsl_valid_read_2);
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Assertion";
- __gen_e_acsl_assert_data_2.pred_txt = "rte: mem_access: \\valid_read((double *)*(vertices + 1))";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\valid_read((double *)*(vertices + 1))";
__gen_e_acsl_assert_data_2.file = "t_darray.c";
__gen_e_acsl_assert_data_2.fct = "area_triangle";
__gen_e_acsl_assert_data_2.line = 7;
+ __gen_e_acsl_assert_data_2.name = "rte/mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
}
diff --git a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_dpointer.c b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_dpointer.c
index fa7c748107ff5515dffe8389ca2bbc594fea1236..fef2d09de76094617e455b66f280ba926d51abb4 100644
--- a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_dpointer.c
+++ b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_dpointer.c
@@ -81,10 +81,11 @@ int main(void)
(void *)(& p));
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(p + i)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(p + i)";
__gen_e_acsl_assert_data_3.file = "t_dpointer.c";
__gen_e_acsl_assert_data_3.fct = "main";
__gen_e_acsl_assert_data_3.line = 15;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_2,
@@ -148,10 +149,11 @@ int main(void)
(void *)(& p));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "mem_access: \\valid_read(p + 2)";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read(p + 2)";
__gen_e_acsl_assert_data_5.file = "t_dpointer.c";
__gen_e_acsl_assert_data_5.fct = "main";
__gen_e_acsl_assert_data_5.line = 21;
+ __gen_e_acsl_assert_data_5.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_4,
diff --git a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_getenv.c b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_getenv.c
index 00fea65e2cf393b47a15c38c5085376cc86bba86..2af473bdba21391af4ece12152846c19ce0edf00 100644
--- a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_getenv.c
+++ b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_getenv.c
@@ -54,10 +54,11 @@ char *__gen_e_acsl_getenv(char const *name)
}
__gen_e_acsl_assert_data_2.blocking = 1;
__gen_e_acsl_assert_data_2.kind = "Postcondition";
- __gen_e_acsl_assert_data_2.pred_txt = "null_or_valid_result: \\result == \\null || \\valid(\\result)";
+ __gen_e_acsl_assert_data_2.pred_txt = "\\result == \\null || \\valid(\\result)";
__gen_e_acsl_assert_data_2.file = "FRAMAC_SHARE/libc/stdlib.h";
__gen_e_acsl_assert_data_2.fct = "getenv";
__gen_e_acsl_assert_data_2.line = 488;
+ __gen_e_acsl_assert_data_2.name = "null_or_valid_result";
__e_acsl_assert(__gen_e_acsl_or,& __gen_e_acsl_assert_data_2);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_2);
__e_acsl_delete_block((void *)(& __retres));
diff --git a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_global_init.c b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_global_init.c
index 9e71a59519afbea4e40820b1bb3cb83942460d03..0642483398e245127f2cf3a54382d5a38647cfbe 100644
--- a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_global_init.c
+++ b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_global_init.c
@@ -259,10 +259,11 @@ int main(int argc, char const **argv)
else __gen_e_acsl_and_2 = 0;
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_3.file = "t_global_init.c";
__gen_e_acsl_assert_data_3.fct = "main";
__gen_e_acsl_assert_data_3.line = 50;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_2,
diff --git a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_local_init.c b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_local_init.c
index 74d0ba3d7ff5b901ea616516a4d31fbafdc47e6f..59299163b135bb1a9ce8ab0f48bee898c4b6197c 100644
--- a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_local_init.c
+++ b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_local_init.c
@@ -242,10 +242,11 @@ int main(int argc, char const **argv)
else __gen_e_acsl_and_2 = 0;
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "RTE";
- __gen_e_acsl_assert_data_3.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_3.file = "t_local_init.c";
__gen_e_acsl_assert_data_3.fct = "main";
__gen_e_acsl_assert_data_3.line = 36;
+ __gen_e_acsl_assert_data_3.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_2,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_2,
@@ -368,10 +369,11 @@ int main(int argc, char const **argv)
else __gen_e_acsl_and_5 = 0;
__gen_e_acsl_assert_data_6.blocking = 1;
__gen_e_acsl_assert_data_6.kind = "RTE";
- __gen_e_acsl_assert_data_6.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_6.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_6.file = "t_local_init.c";
__gen_e_acsl_assert_data_6.fct = "main";
__gen_e_acsl_assert_data_6.line = 43;
+ __gen_e_acsl_assert_data_6.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_5,& __gen_e_acsl_assert_data_6);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_6);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_5,
@@ -481,10 +483,11 @@ int main(int argc, char const **argv)
else __gen_e_acsl_and_8 = 0;
__gen_e_acsl_assert_data_9.blocking = 1;
__gen_e_acsl_assert_data_9.kind = "RTE";
- __gen_e_acsl_assert_data_9.pred_txt = "mem_access: \\valid_read(P)";
+ __gen_e_acsl_assert_data_9.pred_txt = "\\valid_read(P)";
__gen_e_acsl_assert_data_9.file = "t_local_init.c";
__gen_e_acsl_assert_data_9.fct = "main";
__gen_e_acsl_assert_data_9.line = 48;
+ __gen_e_acsl_assert_data_9.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_8,& __gen_e_acsl_assert_data_9);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_9);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_8,
@@ -593,10 +596,11 @@ int main(int argc, char const **argv)
else __gen_e_acsl_and_11 = 0;
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "mem_access: \\valid_read(P)";
+ __gen_e_acsl_assert_data_12.pred_txt = "\\valid_read(P)";
__gen_e_acsl_assert_data_12.file = "t_local_init.c";
__gen_e_acsl_assert_data_12.fct = "main";
__gen_e_acsl_assert_data_12.line = 53;
+ __gen_e_acsl_assert_data_12.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_11,& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_11,
diff --git a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_memcpy.c b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_memcpy.c
index 305b7cb7986faa50698904aa10675661ee011fb1..9b0a94e0efa8152db7d793b74336d09789904632 100644
--- a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_memcpy.c
+++ b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_memcpy.c
@@ -360,10 +360,11 @@ int main(void)
else __gen_e_acsl_and_7 = 0;
__gen_e_acsl_assert_data_8.blocking = 1;
__gen_e_acsl_assert_data_8.kind = "RTE";
- __gen_e_acsl_assert_data_8.pred_txt = "mem_access: \\valid_read(p)";
+ __gen_e_acsl_assert_data_8.pred_txt = "\\valid_read(p)";
__gen_e_acsl_assert_data_8.file = "t_memcpy.c";
__gen_e_acsl_assert_data_8.fct = "main";
__gen_e_acsl_assert_data_8.line = 40;
+ __gen_e_acsl_assert_data_8.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_7,& __gen_e_acsl_assert_data_8);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_8);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_7,
@@ -415,10 +416,11 @@ int main(void)
(void *)(& p));
__gen_e_acsl_assert_data_10.blocking = 1;
__gen_e_acsl_assert_data_10.kind = "RTE";
- __gen_e_acsl_assert_data_10.pred_txt = "mem_access: \\valid_read(p + 1)";
+ __gen_e_acsl_assert_data_10.pred_txt = "\\valid_read(p + 1)";
__gen_e_acsl_assert_data_10.file = "t_memcpy.c";
__gen_e_acsl_assert_data_10.fct = "main";
__gen_e_acsl_assert_data_10.line = 41;
+ __gen_e_acsl_assert_data_10.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_2,
& __gen_e_acsl_assert_data_10);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_10);
@@ -485,10 +487,11 @@ int main(void)
else __gen_e_acsl_and_10 = 0;
__gen_e_acsl_assert_data_12.blocking = 1;
__gen_e_acsl_assert_data_12.kind = "RTE";
- __gen_e_acsl_assert_data_12.pred_txt = "mem_access: \\valid_read(q)";
+ __gen_e_acsl_assert_data_12.pred_txt = "\\valid_read(q)";
__gen_e_acsl_assert_data_12.file = "t_memcpy.c";
__gen_e_acsl_assert_data_12.fct = "main";
__gen_e_acsl_assert_data_12.line = 42;
+ __gen_e_acsl_assert_data_12.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_10,& __gen_e_acsl_assert_data_12);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_12);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_11,
@@ -540,10 +543,11 @@ int main(void)
(void *)(& q));
__gen_e_acsl_assert_data_14.blocking = 1;
__gen_e_acsl_assert_data_14.kind = "RTE";
- __gen_e_acsl_assert_data_14.pred_txt = "mem_access: \\valid_read(q + 1)";
+ __gen_e_acsl_assert_data_14.pred_txt = "\\valid_read(q + 1)";
__gen_e_acsl_assert_data_14.file = "t_memcpy.c";
__gen_e_acsl_assert_data_14.fct = "main";
__gen_e_acsl_assert_data_14.line = 43;
+ __gen_e_acsl_assert_data_14.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_4,
& __gen_e_acsl_assert_data_14);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_14);
@@ -624,10 +628,11 @@ int main(void)
else __gen_e_acsl_and_13 = 0;
__gen_e_acsl_assert_data_16.blocking = 1;
__gen_e_acsl_assert_data_16.kind = "RTE";
- __gen_e_acsl_assert_data_16.pred_txt = "mem_access: \\valid_read(q)";
+ __gen_e_acsl_assert_data_16.pred_txt = "\\valid_read(q)";
__gen_e_acsl_assert_data_16.file = "t_memcpy.c";
__gen_e_acsl_assert_data_16.fct = "main";
__gen_e_acsl_assert_data_16.line = 48;
+ __gen_e_acsl_assert_data_16.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_and_13,& __gen_e_acsl_assert_data_16);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_16);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_15,
@@ -679,10 +684,11 @@ int main(void)
(void *)(& q));
__gen_e_acsl_assert_data_18.blocking = 1;
__gen_e_acsl_assert_data_18.kind = "RTE";
- __gen_e_acsl_assert_data_18.pred_txt = "mem_access: \\valid_read(q + 1)";
+ __gen_e_acsl_assert_data_18.pred_txt = "\\valid_read(q + 1)";
__gen_e_acsl_assert_data_18.file = "t_memcpy.c";
__gen_e_acsl_assert_data_18.fct = "main";
__gen_e_acsl_assert_data_18.line = 49;
+ __gen_e_acsl_assert_data_18.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read_6,
& __gen_e_acsl_assert_data_18);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_18);
@@ -748,10 +754,11 @@ void *__gen_e_acsl_memset(void *s, int c, size_t n)
__gen_e_acsl_at);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Postcondition";
- __gen_e_acsl_assert_data_3.pred_txt = "result_ptr: \\result == \\old(s)";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\result == \\old(s)";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_3.fct = "memset";
__gen_e_acsl_assert_data_3.line = 135;
+ __gen_e_acsl_assert_data_3.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_delete_block((void *)(& s));
@@ -846,10 +853,11 @@ void *__gen_e_acsl_memcpy(void * restrict dest, void const * restrict src,
(void *)(& dest));
__gen_e_acsl_assert_data_4.blocking = 1;
__gen_e_acsl_assert_data_4.kind = "RTE";
- __gen_e_acsl_assert_data_4.pred_txt = "separated_guard: \\valid_read((char *)dest + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_4.pred_txt = "\\valid_read((char *)dest + (0 .. n - 1))";
__gen_e_acsl_assert_data_4.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_4.fct = "memcpy";
__gen_e_acsl_assert_data_4.line = 98;
+ __gen_e_acsl_assert_data_4.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_4);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_4);
__e_acsl_assert_data_t __gen_e_acsl_assert_data_5 =
@@ -878,10 +886,11 @@ void *__gen_e_acsl_memcpy(void * restrict dest, void const * restrict src,
(void *)(& src));
__gen_e_acsl_assert_data_5.blocking = 1;
__gen_e_acsl_assert_data_5.kind = "RTE";
- __gen_e_acsl_assert_data_5.pred_txt = "separated_guard: \\valid_read((char *)src + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_5.pred_txt = "\\valid_read((char *)src + (0 .. n - 1))";
__gen_e_acsl_assert_data_5.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_5.fct = "memcpy";
__gen_e_acsl_assert_data_5.line = 98;
+ __gen_e_acsl_assert_data_5.name = "separated_guard";
__e_acsl_assert(__gen_e_acsl_valid_read_2,& __gen_e_acsl_assert_data_5);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_5);
__e_acsl_assert_register_ptr(& __gen_e_acsl_assert_data_3,"dest",dest);
@@ -927,10 +936,11 @@ void *__gen_e_acsl_memcpy(void * restrict dest, void const * restrict src,
0,__gen_e_acsl_separated);
__gen_e_acsl_assert_data_3.blocking = 1;
__gen_e_acsl_assert_data_3.kind = "Precondition";
- __gen_e_acsl_assert_data_3.pred_txt = "separation:\n \\separated((char *)dest + (0 .. n - 1), (char *)src + (0 .. n - 1))";
+ __gen_e_acsl_assert_data_3.pred_txt = "\\separated((char *)dest + (0 .. n - 1), (char *)src + (0 .. n - 1))";
__gen_e_acsl_assert_data_3.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_3.fct = "memcpy";
__gen_e_acsl_assert_data_3.line = 98;
+ __gen_e_acsl_assert_data_3.name = "separation";
__e_acsl_assert(__gen_e_acsl_separated,& __gen_e_acsl_assert_data_3);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_3);
__e_acsl_temporal_reset_parameters();
@@ -957,10 +967,11 @@ void *__gen_e_acsl_memcpy(void * restrict dest, void const * restrict src,
__gen_e_acsl_at);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "Postcondition";
- __gen_e_acsl_assert_data_7.pred_txt = "result_ptr: \\result == \\old(dest)";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\result == \\old(dest)";
__gen_e_acsl_assert_data_7.file = "FRAMAC_SHARE/libc/string.h";
__gen_e_acsl_assert_data_7.fct = "memcpy";
__gen_e_acsl_assert_data_7.line = 102;
+ __gen_e_acsl_assert_data_7.name = "result_ptr";
__e_acsl_assert(__retres == __gen_e_acsl_at,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_delete_block((void *)(& src));
diff --git a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_struct.c b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_struct.c
index cedbfbcdb2ad988e042ef474099d07db5f33c155..471aeeec24288db92fd87004c6e6c9593442076a 100644
--- a/src/plugins/e-acsl/tests/temporal/oracle/gen_t_struct.c
+++ b/src/plugins/e-acsl/tests/temporal/oracle/gen_t_struct.c
@@ -426,10 +426,11 @@ int main(void)
(void *)0);
__gen_e_acsl_assert_data_7.blocking = 1;
__gen_e_acsl_assert_data_7.kind = "RTE";
- __gen_e_acsl_assert_data_7.pred_txt = "mem_access: \\valid_read(&lp->t.p)";
+ __gen_e_acsl_assert_data_7.pred_txt = "\\valid_read(&lp->t.p)";
__gen_e_acsl_assert_data_7.file = "t_struct.c";
__gen_e_acsl_assert_data_7.fct = "main";
__gen_e_acsl_assert_data_7.line = 44;
+ __gen_e_acsl_assert_data_7.name = "mem_access";
__e_acsl_assert(__gen_e_acsl_valid_read,& __gen_e_acsl_assert_data_7);
__e_acsl_assert_clean(& __gen_e_acsl_assert_data_7);
__e_acsl_assert_register_ulong(& __gen_e_acsl_assert_data_6,
diff --git a/src/plugins/from/callwise.ml b/src/plugins/from/callwise.ml
index 03a681ae3f05d4b92d306c351a5eb5f23765ae67..0ca2714df0c75090c5172b5ef8958c59d7ed9501 100644
--- a/src/plugins/from/callwise.ml
+++ b/src/plugins/from/callwise.ml
@@ -29,7 +29,7 @@ module Tbl =
(struct
let name = "Callwise dependencies"
let size = 17
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
end)
let () = From_parameters.ForceCallDeps.set_output_dependencies [Tbl.self]
@@ -197,11 +197,11 @@ let () = From_parameters.ForceCallDeps.add_update_hook
let force_compute_all_calldeps ()=
- if Db.Value.is_computed () then
+ if Eva.Analysis.is_computed () then
Project.clear
- ~selection:(State_selection.with_dependencies Db.Value.self)
+ ~selection:(State_selection.with_dependencies Eva.Analysis.self)
();
- !Db.Value.compute ()
+ Eva.Analysis.compute ()
(* Registration for call-wise from *)
let () =
diff --git a/src/plugins/from/from_compute.ml b/src/plugins/from/from_compute.ml
index fe9417bc98ee3b8fd09979bdbb19b51a40f219b9..63a8368418645faa345e05a89987d89d97787290 100644
--- a/src/plugins/from/from_compute.ml
+++ b/src/plugins/from/from_compute.ml
@@ -701,7 +701,7 @@ struct
result
let compute kf =
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
ignore (compute_and_return kf)
end
diff --git a/src/plugins/from/from_register_gui.ml b/src/plugins/from/from_register_gui.ml
index 3e87de5ea8ca807fcfc0a91d5c0de99c3ed7bef3..8d607afd9b778bae94dbf0f2ac3bd915f53c2435 100644
--- a/src/plugins/from/from_register_gui.ml
+++ b/src/plugins/from/from_register_gui.ml
@@ -25,7 +25,7 @@ open Cil_types
let main (main_ui:Design.main_window_extension_points) =
let filetree_selector ~was_activated ~activating node =
(* [JS 2009/30/03] GUI may become too slow if froms are displayed *)
- if false && Db.Value.is_computed () then begin
+ if false && Eva.Analysis.is_computed () then begin
if not was_activated && activating then begin
match node with
| Filetree.Global (Cil_types.GFun ({svar=v},_)) ->
diff --git a/src/plugins/from/functionwise.ml b/src/plugins/from/functionwise.ml
index 9f4eb54bf0a961c0029b390607e62531f66c9fe9..85d2c9132dc508edccf2970a8c61cc2970dda224 100644
--- a/src/plugins/from/functionwise.ml
+++ b/src/plugins/from/functionwise.ml
@@ -29,7 +29,7 @@ module Tbl =
(struct
let name = "Functionwise dependencies"
let size = 17
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
end)
let () = From_parameters.ForceDeps.set_output_dependencies [Tbl.self]
@@ -92,7 +92,7 @@ let () =
let force_compute_all () =
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
Callgraph.Uses.iter_in_rev_order
(fun kf ->
if Kernel_function.is_definition kf && !Db.Value.is_called kf
diff --git a/src/plugins/impact/compute_impact.ml b/src/plugins/impact/compute_impact.ml
index 4305f65b876bc2d4292644d27645c2ed8445ad9a..a4579f1fb6fab4ac5556f8da78e9cb40393268e4 100644
--- a/src/plugins/impact/compute_impact.ml
+++ b/src/plugins/impact/compute_impact.ml
@@ -332,8 +332,8 @@ let downward_one_call_node wl (pnode, _ as node) caller_kf pdg =
| Key.SigCallKey(id, key) ->
let stmt = Key.call_from_id id in
- let called_kfs = Db.Value.call_to_kernel_function stmt in
- KFS.iter
+ let called_kfs = Eva.Results.callee stmt in
+ List.iter
(fun called_kf ->
let called_pdg = !Db.Pdg.get called_kf in
let nodes_callee, pdg_ok =
@@ -452,7 +452,7 @@ let all_upward_callers wl kfs =
let pdg_caller = !Db.Pdg.get caller in
List.iter (aux_call (caller, pdg_caller) (kf, pdg_kf)) callsites;
KFS.add caller todo
- ) todo (!Db.Value.callers kf);
+ ) todo (Eva.Results.callsites kf);
)
else todo
in
@@ -536,7 +536,7 @@ let initial_worklist ?(skip=Locations.Zone.bottom) ?(reason=false) nodes kf =
let initial_nodes ~skip kf stmt =
Options.debug ~level:3 "computing initial nodes for %d" stmt.sid;
let pdg = !Db.Pdg.get kf in
- if Db.Value.is_reachable_stmt stmt then
+ if Eva.Results.is_reachable stmt then
try
let all = !Db.Pdg.find_simple_stmt_nodes pdg stmt in
let filter n = match PdgTypes.Node.elem_key n with
diff --git a/src/plugins/impact/register_gui.ml b/src/plugins/impact/register_gui.ml
index 38bba42a81961373ba276d255a81ef2986236755..75e1f7a1487d74eddfa93cee9851ded33f655ccd 100644
--- a/src/plugins/impact/register_gui.ml
+++ b/src/plugins/impact/register_gui.ml
@@ -208,7 +208,7 @@ let impact_statement =
let impact_statement_ui (main_ui:Design.main_window_extension_points) s =
- let val_computed = Db.Value.is_computed () in
+ let val_computed = Eva.Analysis.is_computed () in
ignore (impact_statement (*restriction*)Locations.Zone.top s);
if not val_computed then
main_ui#reset ()
diff --git a/src/plugins/inout/cumulative_analysis.ml b/src/plugins/inout/cumulative_analysis.ml
index 174693b09f5442f9a6e48ef503bb510ec597ee7a..be141e2732d84b14373dad7238e7d30595850d68 100644
--- a/src/plugins/inout/cumulative_analysis.ml
+++ b/src/plugins/inout/cumulative_analysis.ml
@@ -98,7 +98,7 @@ struct
Kernel_function.Make_Table(X.T)
(struct
let name = "Inout.Cumulative_analysis.Memo(" ^ X.analysis_name ^ ")"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
let size = 97
end)
diff --git a/src/plugins/inout/derefs.ml b/src/plugins/inout/derefs.ml
index 19bba4c86cccbfb4e72afb0a15313f0db8239d84..53bf4d9d7fa06d2c3c57adc9c83a48294bd6144e 100644
--- a/src/plugins/inout/derefs.ml
+++ b/src/plugins/inout/derefs.ml
@@ -86,7 +86,7 @@ module Externals =
let get_external =
Externals.memo
(fun kf ->
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
if Kernel_function.is_definition kf then
try
externalize
diff --git a/src/plugins/inout/operational_inputs.ml b/src/plugins/inout/operational_inputs.ml
index 43736a78c9436ab1209a6d1bd9af3bed5476bfe3..ebeeb9ed96de848f06c64fea8fc103c03c0a5178 100644
--- a/src/plugins/inout/operational_inputs.ml
+++ b/src/plugins/inout/operational_inputs.ml
@@ -208,7 +208,7 @@ module Internals =
Kernel_function.Make_Table(Inout_type)
(struct
let name = "Inout.Operational_inputs.Internals"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
let size = 17
end)
@@ -374,26 +374,18 @@ module Computer(Fenv:Dataflows.FUNCTION_ENV)(X:sig
| AAssert (_, p)
| AInvariant (_, true, p) ->
begin
- let env =
- Eva.Eval_terms.env_annot
- ~pre:X.kf_pre_state
- ~here:(X.stmt_state stmt)
- ()
+ let pre = X.kf_pre_state
+ and here = X.stmt_state stmt in
+ let deps =
+ Eva.Eval_terms.annot_predicate_deps ~pre ~here p.tp_statement
in
- match Eva.Eval_terms.predicate_deps env p.tp_statement with
+ match deps with
| None ->
(* To be sound, we should perform a join with the top zone here.
We do nothing instead because the latter behavior would
directly disable memexec. *)
()
- | Some logic_deps ->
- let p_zone =
- Cil_datatype.Logic_label.Map.fold
- (fun _ -> Zone.join)
- logic_deps
- Zone.bottom
- in
- store_non_terminating_logic_inputs p_zone
+ | Some p_zone -> store_non_terminating_logic_inputs p_zone
end
| _ -> ())
stmt
@@ -807,9 +799,9 @@ end
let get_internal =
Internals.memo
(fun kf ->
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
try Internals.find kf (* The results may have been computed by the call
- to Value.compute *)
+ to Eva.Analysis.compute *)
with
| Not_found ->
if!Db.Value.use_spec_instead_of_definition kf then
diff --git a/src/plugins/inout/outputs.ml b/src/plugins/inout/outputs.ml
index 1137bece59862b3720436f2da090395382a8cc9e..7fd1961cfbdb4df2c18cc0c37829eb19d9615b47 100644
--- a/src/plugins/inout/outputs.ml
+++ b/src/plugins/inout/outputs.ml
@@ -48,10 +48,9 @@ class virtual do_it_ = object(self)
(* For local initializations, counts the written variable as an output of the
function, even if it is const; thus, [for_writing] is false in this case. *)
method private do_assign ~for_writing lv =
- let state = Db.Value.get_state self#current_kinstr in
- let _deps, bits_loc, _exact =
- !Db.Value.lval_to_zone_with_deps_state state
- ~deps:None ~for_writing lv
+ let ki = self#current_kinstr in
+ let bits_loc =
+ Eva.Results.(before_kinstr ki |> eval_address ~for_writing lv |> as_zone)
in
self#join bits_loc
diff --git a/src/plugins/inout/register.ml b/src/plugins/inout/register.ml
index f8615a255af358297d2005df233cabb149b43e94..26a3fd05529fd4e26a2fb53358014bfb7d085b4a 100644
--- a/src/plugins/inout/register.ml
+++ b/src/plugins/inout/register.ml
@@ -26,8 +26,8 @@
module ShouldOutput =
State_builder.True_ref
(struct
- let dependencies = [Db.Value.self] (* To be completed if some computations
- use some other results than value *)
+ let dependencies = [Eva.Analysis.self] (* To be completed if some computations
+ use some other results than Eva *)
let name = "Inout.Register.ShouldOuput"
end)
let () = Inout_parameters.Output.add_set_hook
@@ -49,7 +49,7 @@ let main () =
Inout_parameters.Output.get () && ShouldOutput.get ()
then begin
ShouldOutput.set false;
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
Callgraph.Uses.iter_in_rev_order
(fun kf ->
if Kernel_function.is_definition kf && !Db.Value.is_called kf
diff --git a/src/plugins/loop_analysis/Makefile.in b/src/plugins/loop_analysis/Makefile.in
index 4cb7ceebdc781357e9221147bad002aae4d4c284..a4aee4ac5c07f8d1596462e154ed1f4a874feb59 100644
--- a/src/plugins/loop_analysis/Makefile.in
+++ b/src/plugins/loop_analysis/Makefile.in
@@ -33,6 +33,7 @@ PLUGIN_DISTRIBUTED:=$(PLUGIN_ENABLE)
PLUGIN_NAME:= LoopAnalysis
PLUGIN_CMO:= options region_analysis region_analysis_stmt loop_analysis register
PLUGIN_CMI:= region_analysis_sig
+PLUGIN_DEPENDENCIES:= Eva
PLUGIN_DISTRIB_EXTERNAL:= Makefile.in configure.ac configure test.c test.oracle README.org
PLUGIN_TESTS_DIRS:=loop_analysis
diff --git a/src/plugins/loop_analysis/loop_analysis.ml b/src/plugins/loop_analysis/loop_analysis.ml
index 39a8827dd6a6ccf49727ac1b7cdb7a18c4d32dde..a37f5ec6586e66fc2b74e11a11b627dc6b060d7a 100644
--- a/src/plugins/loop_analysis/loop_analysis.ml
+++ b/src/plugins/loop_analysis/loop_analysis.ml
@@ -340,37 +340,18 @@ module Store(* (B:sig *)
Printer.pp_stmt stmt
let value_min_max stmt vi =
- if (Db.Value.is_computed ()) then
+ if (Eva.Analysis.is_computed ()) then
begin
Options.feedback ~dkey ~once:true
"value analysis computed, trying results";
- if Db.Value.is_reachable_stmt stmt then
- let state = Db.Value.get_stmt_state stmt in
- try
- let loc = Locations.loc_of_varinfo vi in
- let v = Db.Value.find state loc in
- let ival = Cvalue.V.project_ival v in
- let omin, omax = Ival.min_and_max ival in
- omin, omax
- with
- | Not_found ->
- Options.feedback ~dkey "value_min_max: not found: %a@.\
- function: %a, stmt: %a"
- Printer.pp_varinfo vi Kernel_function.pretty
- (Kernel_function.find_englobing_kf stmt) Printer.pp_stmt stmt;
- None, None
- | Cvalue.V.Not_based_on_null ->
- Options.feedback ~dkey "value_min_max: not based on null: %a@.\
- function: %a, stmt: %a"
- Printer.pp_varinfo vi Kernel_function.pretty
- (Kernel_function.find_englobing_kf stmt) Printer.pp_stmt stmt;
- None, None
- else
- begin
+ let value = Eva.Results.(before stmt |> eval_var vi |> as_ival) in
+ match value with
+ | Result.Ok ival -> Ival.min_and_max ival
+ | Error e ->
+ if e = Eva.Results.Bottom then
Options.feedback ~dkey "skipping unreachable stmt (function: %a)"
Kernel_function.pretty (Kernel_function.find_englobing_kf stmt);
- None, None
- end
+ None, None
end
else
begin
@@ -490,7 +471,7 @@ module Store(* (B:sig *)
with Not_found -> ()
end
| c ->
- if (Db.Value.is_computed ()) then
+ if (Eva.Analysis.is_computed ()) then
begin
let min_max_int = value_min_max stmt in
match c with
diff --git a/src/plugins/loop_analysis/tests/loop_analysis/oracle/with_value.res.oracle b/src/plugins/loop_analysis/tests/loop_analysis/oracle/with_value.res.oracle
index f2851d8cb74760ca575b38650701d31b54dcc5f9..b7db69d0c82a6d489540170eed6b3c41a2e97997 100644
--- a/src/plugins/loop_analysis/tests/loop_analysis/oracle/with_value.res.oracle
+++ b/src/plugins/loop_analysis/tests/loop_analysis/oracle/with_value.res.oracle
@@ -433,6 +433,10 @@
with_value.i:26: 5
with_value.i:30: 5
with_value.i:34: 4
+ with_value.i:38: 2147483648
+ with_value.i:42: 2147483649
+ with_value.i:46: 2147483649
+ with_value.i:50: 2147483648
with_value.i:54: 2147483646
with_value.i:58: 2147483647
with_value.i:62: 2147483647
diff --git a/src/plugins/markdown-report/eva_info.ml b/src/plugins/markdown-report/eva_info.ml
index 7c00cc4ae15e0e88f9a093f261341904dcb1994d..6fccda29a384d8ec9a3cd25a7bab46eb610ae5c7 100644
--- a/src/plugins/markdown-report/eva_info.ml
+++ b/src/plugins/markdown-report/eva_info.ml
@@ -96,7 +96,7 @@ class eva_coverage_vis ~from_entry_point = object(self)
| Block _ | UnspecifiedSequence _ -> Cil.DoChildren
| _ ->
self#incr_total_stmts;
- if Db.Value.is_reachable_stmt s then self#incr_covered_stmts;
+ if Eva.Results.is_reachable s then self#incr_covered_stmts;
Cil.DoChildren
method! vinst i =
@@ -114,7 +114,7 @@ class eva_coverage_vis ~from_entry_point = object(self)
Cil.SkipChildren
| Call(_,{ enode = Lval (Mem _,NoOffset)},_,_) ->
let s = Option.get self#current_stmt in
- let kfs = Db.Value.call_to_kernel_function s in
+ let kfs = Eva.Results.callee s in
let handle_one kf =
let vi = Kernel_function.get_vi kf in
if not (Cil_datatype.Varinfo.Hashtbl.mem calls vi)
@@ -129,7 +129,7 @@ class eva_coverage_vis ~from_entry_point = object(self)
end
end
in
- Kernel_function.Hptset.iter handle_one kfs;
+ List.iter handle_one kfs;
Cil.SkipChildren
| _ -> Cil.SkipChildren (* No need to go further. *)
@@ -187,7 +187,7 @@ open Markdown
let coverage_md_gen () =
let main = Kernel.MainFunction.get () in
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
let vis = new eva_coverage_vis ~from_entry_point:false in
let stats = vis#compute () in
let summary_whole =
@@ -231,7 +231,7 @@ let coverage_md_gen () =
[ Block [Text summary_whole]; Block [Text summary ]]
let domains_md_gen () =
- let eva_domains = Eva.Value_parameters.enabled_domains () in
+ let eva_domains = Eva.Parameters.enabled_domains () in
let domains = List.filter (fun (name, _) -> name <> "cvalue") eva_domains in
let aux (name, descr) = (plain "domain" @ bold name), plain descr in
List.map aux domains
diff --git a/src/plugins/metrics/metrics_coverage.ml b/src/plugins/metrics/metrics_coverage.ml
index ead657ccfe1122c0ac7ec88c2823ce2b5f0e9682..e5a40743a728466f0c392da7bc498294b468d2e8 100644
--- a/src/plugins/metrics/metrics_coverage.ml
+++ b/src/plugins/metrics/metrics_coverage.ml
@@ -215,7 +215,7 @@ class coverageByFun = object
method! vstmt s =
total <- total + 1;
- if Db.Value.is_reachable_stmt s then value <- value + 1;
+ if Eva.Results.is_reachable s then value <- value + 1;
Cil.DoChildren
method result = (total, value)
@@ -226,7 +226,7 @@ module Kf_Coverage = Kernel_function.Make_Table
(struct
let name = "Metrics_coverage.Kf_coverage"
let size = 7
- let dependencies = [ Db.Value.self; Metrics_parameters.Libc.self ]
+ let dependencies = [ Eva.Analysis.self; Metrics_parameters.Libc.self ]
end)
let is_computed_by_fun () = Kf_Coverage.length () > 0
@@ -244,12 +244,12 @@ let compute_coverage_for kf =
with Kernel_function.No_Definition -> ()
let compute_coverage_by_fun () =
- if Db.Value.is_computed () && not (is_computed_by_fun ())
+ if Eva.Analysis.is_computed () && not (is_computed_by_fun ())
then
let libc = Metrics_parameters.Libc.get () in
Globals.Functions.iter
(fun kf ->
- if !Db.Value.is_called kf &&
+ if Eva.Results.is_called kf &&
Metrics_base.consider_function ~libc (Kernel_function.get_vi kf)
then compute_coverage_for kf)
@@ -264,12 +264,12 @@ let compute_syntactic ~libc kf =
let dkey_sem = Metrics_parameters.register_category "semantic-visitor"
let compute_semantic ~libc =
- assert (Db.Value.is_computed ());
+ assert (Eva.Analysis.is_computed ());
let res = ref Varinfo.Set.empty in
(* Just iter on all the functions and consult the appropriate table *)
Globals.Functions.iter
(fun kf ->
- if !Db.Value.is_called kf &&
+ if Eva.Results.is_called kf &&
Metrics_base.consider_function ~libc
(Kernel_function.get_vi kf)
then begin
@@ -360,7 +360,7 @@ class semantic_printer ~libc (cov_metrics : coverage_metrics) = object(self)
(* uses semantic *)
method pp_value_coverage fmt =
- assert (Db.Value.is_computed ());
+ assert (Eva.Analysis.is_computed ());
let all = self#all_funs in
let syntactic = cov_metrics.syntactic
and semantic = cov_metrics.semantic in
@@ -425,7 +425,7 @@ let percent_coverage ~libc cov_metrics =
;;
let compute ~libc =
- assert (Db.Value.is_computed ());
+ assert (Eva.Analysis.is_computed ());
let semantic = compute_semantic ~libc in
let main = fst (Globals.entry_point ()) in
let syntactic, initializers = compute_syntactic ~libc main in
diff --git a/src/plugins/metrics/metrics_pivot.ml b/src/plugins/metrics/metrics_pivot.ml
new file mode 100644
index 0000000000000000000000000000000000000000..78cc4db8fb9090341dae3e3b3f7ec0a13f1661ed
--- /dev/null
+++ b/src/plugins/metrics/metrics_pivot.ml
@@ -0,0 +1,544 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2021 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+(* Data for a GUI-based pivot table *)
+
+open Cil_types
+
+module PivotSourceState =
+ State_builder.List_ref
+ (Datatype.List(Datatype.String))
+ (struct
+ let name = "PivotSourceState"
+ let dependencies = [ Ast.self; Db.Value.self; Property_status.self;
+ Messages.self ]
+ end)
+
+type syntax_domain =
+ | Code
+ | Declaration
+ | Annotation
+
+type message_domain = Log.kind
+
+type domain =
+ | Syntax of syntax_domain
+ | Property
+ | Message of message_domain
+
+let string_of_string_list sep =
+ Format.asprintf "%a"
+ (Pretty_utils.pp_list ~pre:"" ~suf:"" ~sep Format.pp_print_string)
+
+let split_loc (loc : Cil_types.location) =
+ let fp = (fst loc).pos_path in
+ let line = string_of_int (fst loc).pos_lnum in
+ let fp_pretty = Filepath.Normalized.to_pretty_string fp in
+ let dir = Filename.dirname fp_pretty in
+ let name = Filename.basename fp_pretty in
+ let ext = Filename.extension name in
+ dir, name, ext, line
+
+let node_of_instr = function
+ | Set _ -> "assignment"
+ | Call _ -> "call"
+ | Local_init _ -> "local_init"
+ | Asm _ -> "asm"
+ | Skip _ -> "nop"
+ | Code_annot _ ->
+ (* should be done by the annotations visitor *)
+ assert false
+
+let opt_node_of_stmtkind = function
+ | Instr _ -> None
+ | Return (_, _) -> Some "return"
+ | Goto (_, _) -> Some "goto"
+ | Break _ -> Some "break"
+ | Continue _ -> Some "continue"
+ | If (_, _, _, _) -> Some "if"
+ | Switch (_, _, _, _) -> Some "switch"
+ | Loop (_, _, _, _, _) -> Some "loop"
+ | Block _ -> None
+ | UnspecifiedSequence _ -> Some "unspecified_sequence"
+ | Throw (_, _) -> Some "throw"
+ | TryCatch (_, _, _) -> Some "try_catch"
+ | TryFinally (_, _, _) -> Some "try_finally"
+ | TryExcept (_, _, _, _) -> Some "try_except"
+
+let node_of_code_annotation_node = function
+ | AAssert _ -> "assert"
+ | AStmtSpec _ -> "stmt_spec"
+ | AInvariant _ -> "invariant"
+ | AVariant _ -> "variant"
+ | AAssigns _ -> "assigns"
+ | AAllocation _ -> "allocation"
+ | APragma _ -> "ca_pragma"
+ | AExtended _ -> "extended"
+
+let node_of_global_annotation = function
+ | Dfun_or_pred _ -> "logic_fun_or_pred"
+ | Dvolatile _ -> "logic_volatile"
+ | Daxiomatic _ -> "axiomatic"
+ | Dtype _ -> "logic_type"
+ | Dlemma _ -> "logic_lemma"
+ | Dinvariant _ -> "invariant"
+ | Dtype_annot _ -> "type_annot"
+ | Dmodel_annot _ -> "model_annot"
+ | Dextended _ -> "ga_extended"
+
+let domain_and_node_of_global = function
+ | GType _ -> Declaration, "gtype"
+ | GCompTag _ -> Declaration, "gcomptag"
+ | GCompTagDecl _ -> Declaration, "gcomptagdecl"
+ | GEnumTag _ -> Declaration, "genumtag"
+ | GEnumTagDecl _ -> Declaration, "genumtagdecl"
+ | GVarDecl _ -> Declaration, "global_var"
+ | GFunDecl _ -> Declaration, "gfundecl"
+ | GVar _ -> Declaration, "gvar"
+ | GFun _ -> Declaration, "gfun"
+ | GAsm _ -> Code, "gasm"
+ | GPragma _ -> Code, "gpragma"
+ | GText _ -> Code, "gtext"
+ | GAnnot _ -> Code, "gannot"
+
+let names_of_global = function
+ | GType (_, _) -> []
+ | GCompTag (_, _) -> []
+ | GCompTagDecl (_, _) -> []
+ | GEnumTag (_, _) -> []
+ | GEnumTagDecl (_, _) -> []
+ | GVarDecl (vi, _) -> [vi.vname]
+ | GFunDecl (_, vi, _) -> [vi.vname]
+ | GVar (vi, _, _) -> [vi.vname]
+ | GFun ({svar}, _) -> [svar.vname]
+ | GAsm (_, _) -> []
+ | GPragma (_, _) -> []
+ | GText _ -> []
+ | GAnnot (_, _) -> []
+
+let name_of_logic_info li = li.l_var_info.lv_name
+
+let name_of_global_annotation = function
+ | Dvolatile (_, _, _, _, _) -> None
+ | Dfun_or_pred (li, _)
+ | Dinvariant (li, _)
+ | Dtype_annot (li, _) -> Some (name_of_logic_info li)
+ | Daxiomatic (name, _, _, _)
+ | Dtype ({lt_name = name}, _)
+ | Dlemma (name, _, _, _, _, _)
+ | Dmodel_annot ({mi_name = name}, _)
+ | Dextended ({ext_name = name}, _, _) -> Some name
+
+let node_of_predicate_kind = function
+ | Assert -> "assert"
+ | Check -> "check"
+ | Admit -> "admit"
+
+let node_of_property = function
+ | Property.IPPredicate idp ->
+ Format.asprintf "%a" Property.pretty_predicate_kind idp.ip_kind
+ | IPCodeAnnot ica -> node_of_code_annotation_node ica.ica_ca.annot_content
+ | IPAxiomatic _ -> "axiomatic"
+ | IPLemma _ -> "lemma"
+ | IPBehavior _ -> "behavior"
+ | IPComplete _ -> "complete"
+ | IPDisjoint _ -> "disjoint"
+ | IPAllocation _ -> "allocates"
+ | IPAssigns _ -> "assigns"
+ | IPFrom _ -> "from"
+ | IPDecrease _ -> "loop variant"
+ | IPExtended _ -> "extended"
+ | IPReachable _ -> "reachable"
+ | IPPropertyInstance _ -> "instance"
+ | IPTypeInvariant _ -> "type_invariant"
+ | IPGlobalInvariant _ -> "global_invariant"
+ | IPOther _ -> "other"
+
+let names_of_property = function
+ | Property.IPPredicate idp -> idp.ip_pred.ip_content.tp_statement.pred_name
+ | IPCodeAnnot _ -> []
+ | IPAxiomatic _ -> []
+ | IPLemma _ -> []
+ | IPBehavior _ -> []
+ | IPComplete _ -> []
+ | IPDisjoint _ -> []
+ | IPAllocation _ -> []
+ | IPAssigns _ -> []
+ | IPFrom _ -> []
+ | IPDecrease _ -> []
+ | IPExtended _ -> []
+ | IPReachable _ -> []
+ | IPPropertyInstance _ -> []
+ | IPTypeInvariant _ -> []
+ | IPGlobalInvariant _ -> []
+ | IPOther _ -> []
+
+let plugin_of_emitters el =
+ match el with
+ | []
+ | ["Call Preconditions"]
+ | ["Frama-C kernel"] -> "kernel"
+ | ["Eva"] -> "eva"
+ | _ -> "<unknown emitters (" ^ string_of_string_list "," el ^ ")>"
+
+let string_of_syntax_domain = function
+ | Code -> "code"
+ | Declaration -> "decl"
+ | Annotation -> "annot"
+
+let string_of_message_domain = function
+ | Log.Result -> "result"
+ | Feedback -> "feedback"
+ | Debug -> "debug"
+ | Warning -> "warning"
+ | Error -> "error"
+ | Failure -> "failure"
+
+let split_domain = function
+ | Syntax d -> "syntax", string_of_syntax_domain d
+ | Property -> "property", ""
+ | Message d -> "message", string_of_message_domain d
+
+module FunctionAtPos = struct
+ let tbl :
+ (Filepath.Normalized.t,
+ (Filepath.position * Filepath.position * string) Array.t)
+ Hashtbl.t =
+ Hashtbl.create 16
+
+ let binary_search a pos : string option =
+ let cmp = Cil_datatype.Position.compare in
+ let rec aux lo hi =
+ if lo > hi then None
+ else
+ let mid = (hi + lo) / 2 in
+ let (mstart, mend, mfunc) = a.(mid) in
+ if cmp pos mstart >= 0 then
+ if cmp pos mend <= 0 then Some mfunc
+ else aux (mid + 1) hi
+ else aux lo (mid - 1)
+ in
+ aux 0 (Array.length a - 1)
+
+ let compute () =
+ let tmp = Hashtbl.create 16 in
+ let files =
+ List.fold_left (fun acc ((pos1, _, _) as triple) ->
+ let fp = pos1.Filepath.pos_path in
+ Hashtbl.add tmp fp triple;
+ Datatype.Filepath.Set.add fp acc
+ ) Datatype.Filepath.Set.empty (Cabs2cil.func_locs ())
+ in
+ Hashtbl.clear tbl;
+ Datatype.Filepath.Set.iter (fun fp ->
+ let l =
+ List.sort (fun (start1, _, _) (start2, _, _) ->
+ Cil_datatype.Position.compare start1 start2
+ ) (Hashtbl.find_all tmp fp)
+ in
+ Hashtbl.replace tbl fp (Array.of_list l)
+ ) files
+
+ let find pos =
+ let fp = pos.Filepath.pos_path in
+ Option.bind (Hashtbl.find_opt tbl fp)
+ (fun a -> binary_search a pos)
+
+end
+
+type entry = {
+ loc: Cil_datatype.Location.t;
+ func: string option;
+ domain: domain;
+ plugin: string;
+ status: string;
+ node: string;
+ names: string list;
+ text: string;
+}
+
+let headers = ["Directory"; "Filename"; "Extension"; "Line Number";
+ "Function"; "Domain"; "Kind"; "Plugin"; "Status"; "Node";
+ "Names"; "Text"]
+
+let add_entry_str entry =
+ let dir, fname, ext, line = split_loc entry.loc in
+ let funcname = Option.fold ~none:"" ~some:Stdlib.Fun.id entry.func in
+ let domain, kind = split_domain entry.domain in
+ let names = string_of_string_list ":" entry.names in
+ let entry = [dir; fname; ext; line; funcname;
+ domain; kind; entry.plugin; entry.status; entry.node;
+ names; entry.text]
+ in
+ if PivotSourceState.get () = [] then
+ PivotSourceState.add headers;
+ PivotSourceState.add entry
+
+let new_entry ?func ?(plugin="") ?(status="") ?(node="") ?(names=[]) ?(text="") loc domain =
+ { loc; func; domain; plugin; status; node; names; text }
+
+let add_entry ?func ?plugin ?status ?node ?names ?text loc domain =
+ let entry = new_entry ?func ?plugin ?status ?node ?names ?text loc domain in
+ add_entry_str entry
+
+class full_visitor = object(self)
+ inherit Cil.nopCilVisitor
+ val mutable cur_func = None
+ method add ?func ?node ?names domain =
+ let loc = Cil.CurrentLoc.get () in
+ let func = if func <> None && func <> Some "" then func else cur_func in
+ add_entry ?func ?node ?names loc domain
+ method add_code ?func ?names node =
+ self#add ?func ~node ?names (Syntax Code)
+ method add_decl ?func ?names node =
+ self#add ?func ~node ?names (Syntax Declaration)
+ method add_annot ?names node =
+ self#add ~node ?names (Syntax Annotation)
+
+ method! vvrbl (_v:varinfo) = DoChildren
+ method! vvdec (_v:varinfo) = DoChildren
+ method! vexpr (_e:exp) = DoChildren
+ method! vlval (_l:lval) = DoChildren
+ method! voffs (_o:offset) = DoChildren
+ method! vinitoffs (_o:offset) = DoChildren
+
+ method! vinst (i:instr) =
+ let node = node_of_instr i in
+ self#add_code node;
+ DoChildren
+
+ method! vstmt (s:stmt) =
+ begin
+ match opt_node_of_stmtkind s.skind with
+ | None -> ()
+ | Some node -> self#add_code node
+ end;
+ DoChildren
+
+ method! vfunc (f:fundec) =
+ cur_func <- Some f.svar.vname;
+ Cil.DoChildrenPost (fun fd ->
+ cur_func <- None;
+ fd
+ )
+
+ method! vglob (g:global) =
+ let domain, node = domain_and_node_of_global g in
+ let names = names_of_global g in
+ let func = "<global>" in
+ if domain = Declaration then
+ self#add_decl ~func ~names node
+ else
+ self#add_code ~func ~names node;
+ DoChildren
+
+ method! vblock _ = DoChildren
+ method! vinit _ _ _ = DoChildren
+ method! vlocal_init _ _ = DoChildren
+ method! vtype _ = DoChildren
+ method! vcompinfo _ = DoChildren
+ method! venuminfo _ = DoChildren
+ method! vfieldinfo _ = DoChildren
+ method! venumitem _ = DoChildren
+ method! vattr _ = DoChildren
+ method! vattrparam _ = DoChildren
+ method! vmodel_info _ = DoChildren
+ method! vlogic_type _ = DoChildren
+ method! videntified_term _ = DoChildren
+ method! vterm _ = DoChildren
+ method! vterm_node _ = DoChildren
+ method! vterm_lval _ = DoChildren
+ method! vterm_lhost _ = DoChildren
+ method! vterm_offset _ = DoChildren
+ method! vlogic_label _ = DoChildren
+ method! vlogic_info_decl _ = DoChildren
+ method! vlogic_info_use _ = DoChildren
+ method! vlogic_type_info_decl _ = DoChildren
+ method! vlogic_type_info_use _ = DoChildren
+ method! vlogic_type_def _ = DoChildren
+ method! vlogic_ctor_info_decl _ = DoChildren
+ method! vlogic_ctor_info_use _ = DoChildren
+ method! vlogic_var_use _ = DoChildren
+ method! vlogic_var_decl _ = DoChildren
+ method! vquantifiers _ = DoChildren
+ method! videntified_predicate _ =
+ (* should be done by the annotations visitor *)
+ assert false
+ method! vpredicate_node _ = DoChildren
+ method! vpredicate _ = DoChildren
+ method! vbehavior _ = DoChildren
+ method! vassigns _ = DoChildren
+ method! vfrees _ = DoChildren
+ method! vallocates _ = DoChildren
+ method! vallocation _ = DoChildren
+ method! vloop_pragma _ = DoChildren
+ method! vslice_pragma _ = DoChildren
+ method! vimpact_pragma _ = DoChildren
+ method! vdeps _ = DoChildren
+ method! vfrom _ = DoChildren
+ method! vcode_annot _ =
+ (* should be done by the annotations visitor *)
+ assert false
+ method! vannotation ga =
+ let node = node_of_global_annotation ga in
+ let names = Option.to_list (name_of_global_annotation ga) in
+ self#add_annot ~names node;
+ DoChildren
+end
+
+let ca_visitor_cur_func : string option ref = ref None
+let ca_visitor_cur_emitter = ref "<unknown>"
+class code_annot_visitor = object(self)
+ inherit Cil.nopCilVisitor
+
+ method add_annot ?(names=[]) node =
+ let loc = Cil.CurrentLoc.get () in
+ let func = !ca_visitor_cur_func in
+ let plugin = !ca_visitor_cur_emitter in
+ let domain = Syntax Annotation in
+ add_entry ?func ~plugin ~node ~names loc domain
+
+ method! videntified_predicate {ip_content = {tp_kind}} =
+ let node = node_of_predicate_kind tp_kind in
+ self#add_annot node;
+ DoChildren
+
+ method! vcode_annot ca =
+ let content = ca.annot_content in
+ self#add_annot (node_of_code_annotation_node content);
+ DoChildren
+
+ method! vannotation ga =
+ let node = node_of_global_annotation ga in
+ let names = Option.to_list (name_of_global_annotation ga) in
+ self#add_annot ~names node;
+ DoChildren
+end
+
+let visit_annots () =
+ let vis = new code_annot_visitor in
+ Annotations.iter_all_code_annot (
+ fun stmt emitter ca ->
+ let kf = Kernel_function.find_englobing_kf stmt in
+ ca_visitor_cur_func := Some (Kernel_function.get_name kf);
+ ca_visitor_cur_emitter := Emitter.get_name emitter;
+ ignore (Cil.visitCilCodeAnnotation (vis :> Cil.cilVisitor) ca)
+ )
+
+let visit_properties () =
+ Property_status.iter
+ (fun ip ->
+ let loc = Property.location ip in
+ let func = Option.map Kernel_function.get_name (Property.get_kf ip) in
+ let emitters =
+ Property_status.fold_on_statuses (fun emitter _status acc ->
+ Emitter.Usable_emitter.get_name emitter.emitter :: acc
+ ) ip []
+ in
+ let plugin = plugin_of_emitters emitters in
+ let domain = Property in
+ let status =
+ Format.asprintf "%a"
+ Property_status.Feedback.pretty (Property_status.Feedback.get ip)
+ in
+ let node = node_of_property ip in
+ let names = names_of_property ip in
+ add_entry ?func ~node ~status ~plugin ~names loc domain
+ )
+
+let visit_messages () =
+ FunctionAtPos.compute ();
+ Messages.iter (fun ev ->
+ let plugin = ev.evt_plugin in
+ let loc_of_pos p = (p, p) in
+ let loc, func =
+ match ev.evt_source with
+ | None -> Cil_datatype.Location.unknown, "<global>"
+ | Some pos ->
+ let funcname =
+ match FunctionAtPos.find pos with
+ | None -> Metrics_parameters.warning
+ "FUNCTION NOT FOUND FOR NON-GLOBAL MESSAGE POS: %a"
+ Cil_datatype.Position.pretty_debug pos;
+ "<unknown>"
+ | Some name -> name
+ in
+ loc_of_pos pos, funcname
+ in
+ let domain = Message (ev.evt_kind) in
+ let text = ev.evt_message in
+ add_entry ~func ~plugin ~text loc domain
+ )
+
+(* Useful mainly for debugging *)
+let _pp_as_csv (data : string list list) =
+ let pp_list = string_of_string_list "," in
+ List.iter (fun ls -> Format.printf "%s@\n" (pp_list ls)) (List.rev data)
+
+(* Server / Ivette stuff *)
+
+open Server
+
+let package =
+ Package.package
+ ~plugin:"pivot"
+ ~name:"general"
+ ~title:"Pivot Table Services"
+ ~readme:"pivot.md"
+ ()
+
+module TableState = struct
+ type t = string list list
+ let jtype =
+ Data.declare ~package
+ ~name:"tableStateType"
+ ~descr:(Markdown.plain "State of the pivot table source data.")
+ Package.(Jarray (Jarray Jstring))
+ let to_json ll =
+ `List (List.rev_map (fun l -> `List (List.map (fun s -> `String s) l)) ll)
+end
+
+let pivot_signal =
+ States.register_value ~package
+ ~name:"pivotState"
+ ~descr:(Markdown.plain "State of the pivot table source data.")
+ ~output:(module TableState)
+ ~get:PivotSourceState.get
+ ~add_hook:PivotSourceState.add_hook_on_update
+ ()
+
+let compute () =
+ let ast = Ast.get () in
+ let vis = new full_visitor in
+ ignore (Cil.visitCilFile (vis :> Cil.cilVisitor) ast);
+ visit_annots ();
+ visit_properties ();
+ visit_messages ();
+ (*_pp_as_csv (PivotSourceState.get ());*)
+ (* Signals that the pivot table has been updated. *)
+ Server.Request.emit pivot_signal
+
+let _compute =
+ Server.Request.register ~package
+ ~kind:`EXEC ~name:"compute"
+ ~descr:(Markdown.plain "Computes the pivot table.")
+ ~input:(module Data.Junit) ~output:(module Data.Junit) compute
diff --git a/src/plugins/metrics/metrics_pivot.mli b/src/plugins/metrics/metrics_pivot.mli
new file mode 100644
index 0000000000000000000000000000000000000000..98ffe7ef308729877bd4ce7bf50dd0584b275cde
--- /dev/null
+++ b/src/plugins/metrics/metrics_pivot.mli
@@ -0,0 +1,23 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2021 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+(** Nothing is exported. *)
diff --git a/src/plugins/metrics/register.ml b/src/plugins/metrics/register.ml
index 1ab4336a288ce79a1cc5a57321819fddc016c314..bcf8263ca05d3bb2e4d9c319f8615e53bd7cf7d9 100644
--- a/src/plugins/metrics/register.ml
+++ b/src/plugins/metrics/register.ml
@@ -44,11 +44,11 @@ let syntactic ?(libc=Metrics_parameters.Libc.get ()) () =
Metrics_parameters.result "%a"
cov_printer#pp_reached_from_function kf)
-let () = ValueCoverage.set_output_dependencies [Db.Value.self; Libc.self]
+let () = ValueCoverage.set_output_dependencies [Eva.Analysis.self; Libc.self]
let value ~libc () =
- !Db.Value.compute ();
- if Db.Value.is_computed () then begin
+ Eva.Analysis.compute ();
+ if Eva.Analysis.is_computed () then begin
let cov_metrics = Metrics_coverage.compute ~libc in
let cov_printer = new Metrics_coverage.semantic_printer ~libc cov_metrics in
Metrics_parameters.result "%t" cov_printer#pp_value_coverage;
diff --git a/src/plugins/metrics/register_gui.ml b/src/plugins/metrics/register_gui.ml
index ace660eb586bb41b196a5e55fe44b4344204e7a9..a75dd2ed93332dc3d996871daf9eacf801d58b61 100644
--- a/src/plugins/metrics/register_gui.ml
+++ b/src/plugins/metrics/register_gui.ml
@@ -146,7 +146,7 @@ module CyclomaticMetricsGUI = struct
end
method cyclo_selector (popup_factory:GMenu.menu GMenu.factory) main_ui ~button localizable =
- if button = 3 && Db.Value.is_computed () then
+ if button = 3 && Eva.Analysis.is_computed () then
match localizable with
| PVDecl (Some kf, _,_) ->
let callback1 () =
@@ -214,7 +214,7 @@ module ValueCoverageGUI = struct
begin
match !result with
| None ->
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
result := Some (Metrics_coverage.compute ~libc)
| Some _ -> ()
end;
diff --git a/src/plugins/nonterm/nonterm_run.ml b/src/plugins/nonterm/nonterm_run.ml
index 23d5aa7635938046ba7d24391cc8e6bbdfb613d9..0cbfe74ffb31bddf7cf6a014fc1a8621187b7162 100644
--- a/src/plugins/nonterm/nonterm_run.ml
+++ b/src/plugins/nonterm/nonterm_run.ml
@@ -181,7 +181,7 @@ class unreachable_stmt_visitor kf to_ignore = object
method! vstmt stmt =
if Stmt.Hptset.mem stmt syntactically_reachable &&
- Db.Value.is_reachable_stmt stmt = false &&
+ not (Eva.Results.is_reachable stmt) &&
not (Stmt.Hptset.mem stmt !semantically_considered)
then begin
(* add node and its reachable successors to the considered statements *)
@@ -197,11 +197,10 @@ end
1. SyntacticallyUnreachable is disabled (otherwise it already checks them);
2. No warnings were emitted for the function (otherwise it may be redundant). *)
let check_unreachable_returns kf =
- let st = Db.Value.get_initial_state kf in
- if Db.Value.is_reachable st then begin
+ if Eva.Results.is_called kf then begin
try
let ret_stmt = Kernel_function.find_return kf in
- if not (Db.Value.is_reachable_stmt ret_stmt) then
+ if not (Eva.Results.is_reachable ret_stmt) then
warn_unreachable_statement ret_stmt
with
| Kernel_function.No_Statement -> (* should never happen *)
@@ -221,25 +220,24 @@ let check_unreachable_statements kf ~to_ignore ~dead_code ~warned_kfs =
considered as always terminating"
Kernel_function.pretty kf
else
- let st = Db.Value.get_initial_state kf in
- if Db.Value.is_reachable st then begin
- try
- let vis = new unreachable_stmt_visitor kf to_ignore in
+ if Eva.Results.is_called kf then begin
+ try
+ let vis = new unreachable_stmt_visitor kf to_ignore in
+ ignore (Visitor.visitFramacKf (vis :> Visitor.frama_c_visitor) kf);
+ if dead_code then begin
+ (* compute syntactically unreachable statements *)
+ let vis = new dead_cc_collector kf in
ignore (Visitor.visitFramacKf (vis :> Visitor.frama_c_visitor) kf);
- if dead_code then begin
- (* compute syntactically unreachable statements *)
- let vis = new dead_cc_collector kf in
- ignore (Visitor.visitFramacKf (vis :> Visitor.frama_c_visitor) kf);
- let cc_heads = List.map List.hd vis#get in
- Stmt.Hptset.iter (fun h -> warn_dead_code h) (Stmt.Hptset.of_list cc_heads)
- end
- else if not (Kernel_function.Set.mem kf warned_kfs) then
- check_unreachable_returns kf
- with
- | Kernel_function.No_Statement -> (* should never happen *)
- Self.error "function %a has no return statement, skipping"
- Kernel_function.pretty kf;
- end
+ let cc_heads = List.map List.hd vis#get in
+ Stmt.Hptset.iter (fun h -> warn_dead_code h) (Stmt.Hptset.of_list cc_heads)
+ end
+ else if not (Kernel_function.Set.mem kf warned_kfs) then
+ check_unreachable_returns kf
+ with
+ | Kernel_function.No_Statement -> (* should never happen *)
+ Self.error "function %a has no return statement, skipping"
+ Kernel_function.pretty kf;
+ end
(* To avoid redundant warnings, calls to possibly non-terminating functions
are ignored if:
@@ -281,14 +279,6 @@ class stmt_collector = object
method get_instr_stmts = List.rev !instr_stmts
end
-let get_callstack_state ~after stmt cs =
- match Db.Value.get_stmt_state_callstack ~after stmt with
- | None -> None (* unreachable stmt *)
- | Some table ->
- try
- Some (Value_types.Callstack.Hashtbl.find table cs)
- with Not_found -> None
-
(* collects the list of non-terminating instructions *)
let collect_nonterminating_statements fd nonterm_stacks =
let vis = new stmt_collector in
@@ -309,40 +299,23 @@ let collect_nonterminating_statements fd nonterm_stacks =
| _ ->
let source = fst (Stmt.loc stmt) in
Self.debug ~source "processing stmt:@ %a" Printer.pp_stmt stmt;
- match Db.Value.get_stmt_state_callstack ~after:false stmt with
- | None -> () (* unreachable stmt *)
- | Some before_table ->
- Value_types.Callstack.Hashtbl.iter
- (fun cs before_state ->
- try
- match Db.Value.get_stmt_state_callstack ~after:true stmt with
- | None -> (* no after table => non-terminating statement *)
- add_stack stmt cs
- | Some after_table ->
- let after_state =
- Value_types.Callstack.Hashtbl.find after_table cs
- in
- if Cvalue.Model.is_reachable before_state then
- if not (Cvalue.Model.is_reachable after_state) then add_stack stmt cs
- else if match stmt.skind with Loop _ -> true | _ -> false then begin
- (* special treatment for loops: even if their after state
- is reachable, we must check that at least one outgoing
- edge is reachable *)
- let out_edges = Stmts_graph.get_all_stmt_out_edges stmt in
- let all_out_edges_unreachable =
- List.for_all (fun (_, out_stmt) ->
- match get_callstack_state ~after:false out_stmt cs with
- | None -> true
- | Some state -> not (Cvalue.Model.is_reachable state)
- ) out_edges
- in
- if all_out_edges_unreachable then add_stack stmt cs
- end
- with
- | Not_found ->
- (* in this callstack, the statement is non-terminating *)
- add_stack stmt cs
- ) before_table
+ let process_callstack cs =
+ if Eva.Results.(after stmt |> in_callstack cs |> is_empty) then
+ add_stack stmt cs
+ else if match stmt.skind with Loop _ -> true | _ -> false then begin
+ (* special treatment for loops: even if their after state
+ is reachable, we must check that at least one outgoing
+ edge is reachable *)
+ let out_edges = Stmts_graph.get_all_stmt_out_edges stmt in
+ let all_out_edges_unreachable =
+ List.for_all (fun (_, out_stmt) ->
+ Eva.Results.(before out_stmt |> in_callstack cs |> is_empty)
+ ) out_edges
+ in
+ if all_out_edges_unreachable then add_stack stmt cs
+ end
+ in
+ List.iter process_callstack Eva.Results.(before stmt |> callstacks)
) vis#get_instr_stmts;
!new_nonterm_stmts
@@ -364,7 +337,7 @@ let cmp_callstacks cs1 cs2 =
let run () =
if not (Ast.is_computed ()) then
Self.abort "nonterm requires a computed AST";
- if not (Db.Value.is_computed ()) then
+ if not (Eva.Analysis.is_computed ()) then
Self.abort "nonterm requires a computed value analysis";
Self.debug "Starting analysis...";
let file = Ast.get () in
@@ -398,7 +371,7 @@ let run () =
Self.feedback ~level:2 "Analysis done."
;;
-let run_once, _ = State_builder.apply_once "Nonterm.run" [Db.Value.self] run
+let run_once, _ = State_builder.apply_once "Nonterm.run" [Eva.Analysis.self] run
let main () =
if Enabled.get () then run_once ()
diff --git a/src/plugins/occurrence/register.ml b/src/plugins/occurrence/register.ml
index 8d9d94741ec37ce7bf37449cc19674c8fc73cc66..e7253b938ccfd6c32b6733ecb805cad87b958659 100644
--- a/src/plugins/occurrence/register.ml
+++ b/src/plugins/occurrence/register.ml
@@ -48,7 +48,7 @@ end = struct
(struct
let size = 17
let name = "Occurrences.State"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
end)
module LastResult =
@@ -106,8 +106,8 @@ class occurrence = object (self)
method! vlval lv =
let ki = self#current_kinstr in
- if Db.Value.is_accessible ki then begin
- let z = !Db.Value.lval_to_zone ki lv in
+ begin
+ let z = Eva.Results.(before_kinstr ki |> eval_address lv |> as_zone) in
try
Locations.Zone.fold_topset_ok
(fun b _ () ->
@@ -135,7 +135,7 @@ class occurrence = object (self)
Db.yield ();
super#vstmt_aux s
- initializer !Db.Value.compute ()
+ initializer Eva.Analysis.compute ()
end
diff --git a/src/plugins/pdg/build.ml b/src/plugins/pdg/build.ml
index e90ada08bba331ce0f7190093d8c7d5c56d9630f..6606cbf535d5975bc4349e6bcb4776f34b94dbba 100644
--- a/src/plugins/pdg/build.ml
+++ b/src/plugins/pdg/build.ml
@@ -1000,7 +1000,7 @@ let degenerated top kf =
if top then PdgTypes.Pdg.top kf else PdgTypes.Pdg.bottom kf
let compute_pdg kf =
- if not (Db.Value.is_computed ()) then !Db.Value.compute ();
+ if not (Eva.Analysis.is_computed ()) then Eva.Analysis.compute ();
Pdg_parameters.feedback "computing for function %a" Kernel_function.pretty kf;
try
if is_variadic kf then
diff --git a/src/plugins/pdg/register.ml b/src/plugins/pdg/register.ml
index 5add8915f1cf8f77a1573dab0f468e71c1755c6f..0c1ae27625fcf632d968f3e545e48dc454891480 100644
--- a/src/plugins/pdg/register.ml
+++ b/src/plugins/pdg/register.ml
@@ -127,7 +127,7 @@ let compute_for_kf kf =
Kernel_function.Set.mem kf (Pdg_parameters.BuildFct.get ())
let compute () =
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
let do_kf_pdg kf =
if compute_for_kf kf then
let pdg = !Db.Pdg.get kf in
diff --git a/src/plugins/postdominators/compute.ml b/src/plugins/postdominators/compute.ml
index d0b257ac9a65ef5759a2b9b9e935fca9701bde32..1fbd79e06d6817cb9a1e7006618c9769e6842bb4 100644
--- a/src/plugins/postdominators/compute.ml
+++ b/src/plugins/postdominators/compute.ml
@@ -255,8 +255,8 @@ let () = Db.Main.extend output
include
PostDomDb
(struct
- let is_accessible = Db.Value.is_reachable_stmt
- let dependencies = [ Db.Value.self ]
+ let is_accessible = Eva.Results.is_reachable
+ let dependencies = [ Eva.Analysis.self ]
let name = "value"
let eval_cond stmt _e =
Db.Value.condition_truth_value stmt
diff --git a/src/plugins/qed/.ocp-indent b/src/plugins/qed/.ocp-indent
deleted file mode 100644
index ef83851c8dc4f772b62ee7bca7afe13faf0c110d..0000000000000000000000000000000000000000
--- a/src/plugins/qed/.ocp-indent
+++ /dev/null
@@ -1 +0,0 @@
-match_clause = 4
diff --git a/src/plugins/qed/export.ml b/src/plugins/qed/export.ml
index 452b8b472cf64977202d7572ddd5fb92bec34420..1e8115d0eb9b8277fe72ae3261376c0313ebe3d4 100644
--- a/src/plugins/qed/export.ml
+++ b/src/plugins/qed/export.ml
@@ -88,10 +88,10 @@ let sanitize ~to_lowercase base =
let c = base.[i] in
match c with
| '0' .. '9' | 'a' .. 'z' | '_' ->
- Buffer.add_char p c
+ Buffer.add_char p c
| 'A' .. 'Z' ->
- Buffer.add_char p
- (if to_lowercase then Char.lowercase_ascii c else c)
+ Buffer.add_char p
+ (if to_lowercase then Char.lowercase_ascii c else c)
| _ -> ()
done ;
Buffer.contents p
@@ -238,7 +238,7 @@ struct
let rec binders q k vars e =
match T.repr e with
| Bind(q',t,e) when q'=q ->
- binders q (succ k) (add_var k t vars) (lc_repr e)
+ binders q (succ k) (add_var k t vars) (lc_repr e)
| _ -> k,vars,e
let rec lambda k kts e =
@@ -251,11 +251,11 @@ struct
| Bind((Forall|Exists),_,_) | True | False -> true
| Not a -> has_prop_form link a
| Fun(f,_) ->
- begin
- match link f with
- | F_bool_prop _ -> true
- | _ -> T.Fun.sort f = Sprop
- end
+ begin
+ match link f with
+ | F_bool_prop _ -> true
+ | _ -> T.Fun.sort f = Sprop
+ end
| _ -> false
(* -------------------------------------------------------------------------- *)
@@ -386,16 +386,16 @@ struct
method private pp_unop ~op fmt x =
match op with
| Assoc op | Op op ->
- if self#op_spaced op (*&& self#is_atomic x*) then
- fprintf fmt "%s %a" op self#pp_flow x
- else
- fprintf fmt "%s%a" op self#pp_atom x
+ if self#op_spaced op (*&& self#is_atomic x*) then
+ fprintf fmt "%s %a" op self#pp_flow x
+ else
+ fprintf fmt "%s%a" op self#pp_atom x
| Call f -> self#pp_call ~f fmt [x]
method private pp_binop ~op fmt x y =
match op with
| Assoc op | Op op ->
- fprintf fmt "%a %s@ %a" self#pp_atom x op self#pp_atom y
+ fprintf fmt "%a %s@ %a" self#pp_atom x op self#pp_atom y
| Call f -> self#pp_call ~f fmt [x;y]
method private pp_binop_term ~op fmt x y =
@@ -406,56 +406,56 @@ struct
| Assoc op -> Plib.pp_assoc ~op self#pp_atom fmt xs
| Op op -> Plib.pp_fold_binop ~op self#pp_atom fmt xs
| Call f ->
- match self#callstyle with
- | CallVar | CallVoid ->
- Plib.pp_fold_call ~f self#pp_flow fmt xs
- | CallApply ->
- Plib.pp_fold_apply ~f self#pp_atom fmt xs
+ match self#callstyle with
+ | CallVar | CallVoid ->
+ Plib.pp_fold_call ~f self#pp_flow fmt xs
+ | CallApply ->
+ Plib.pp_fold_apply ~f self#pp_atom fmt xs
method pp_fun cmode fct fmt xs =
match self#link fct, cmode with
| F_call f, _
| F_bool_prop (f,_), Cterm
| F_bool_prop (_,f), Cprop ->
- self#pp_callsorts ~f fmt (Fun.params fct) xs
+ self#pp_callsorts ~f fmt (Fun.params fct) xs
| F_assoc op, _ -> Plib.pp_assoc ~e:"?" ~op self#pp_atom fmt xs
| F_left f, _ ->
- begin
- match self#callstyle with
- | CallVar | CallVoid ->
- Plib.pp_fold_call ~f self#pp_flow fmt xs
- | CallApply ->
- Plib.pp_fold_apply ~f self#pp_atom fmt xs
- end
+ begin
+ match self#callstyle with
+ | CallVar | CallVoid ->
+ Plib.pp_fold_call ~f self#pp_flow fmt xs
+ | CallApply ->
+ Plib.pp_fold_apply ~f self#pp_atom fmt xs
+ end
| F_right f, _ ->
- begin
- let xs = List.rev xs in
- match self#callstyle with
- | CallVar | CallVoid ->
- Plib.pp_fold_call_rev ~f self#pp_flow fmt xs
- | CallApply ->
- Plib.pp_fold_apply_rev ~f self#pp_atom fmt xs
- end
+ begin
+ let xs = List.rev xs in
+ match self#callstyle with
+ | CallVar | CallVoid ->
+ Plib.pp_fold_call_rev ~f self#pp_flow fmt xs
+ | CallApply ->
+ Plib.pp_fold_apply_rev ~f self#pp_atom fmt xs
+ end
| F_list(fc,fn), _ ->
- begin
- let rec plist w fmt xs =
- let style,fc,fn = w in
- match style , xs with
- | (CallVar|CallApply) , [] -> pp_print_string fmt fn
- | CallVoid , [] -> fprintf fmt "%s()" fn
- | (CallVar|CallVoid) , x::xs ->
- fprintf fmt "@[<hov 2>%s(@,%a,@,%a)@]"
- fc self#pp_flow x (plist w) xs
- | CallApply , x::xs ->
- fprintf fmt "@[<hov 2>(%s@ %a @ %a)@]"
- fc self#pp_atom x (plist w) xs
- in plist (self#callstyle,fc,fn) fmt xs
- end
+ begin
+ let rec plist w fmt xs =
+ let style,fc,fn = w in
+ match style , xs with
+ | (CallVar|CallApply) , [] -> pp_print_string fmt fn
+ | CallVoid , [] -> fprintf fmt "%s()" fn
+ | (CallVar|CallVoid) , x::xs ->
+ fprintf fmt "@[<hov 2>%s(@,%a,@,%a)@]"
+ fc self#pp_flow x (plist w) xs
+ | CallApply , x::xs ->
+ fprintf fmt "@[<hov 2>(%s@ %a @ %a)@]"
+ fc self#pp_atom x (plist w) xs
+ in plist (self#callstyle,fc,fn) fmt xs
+ end
| F_subst (_, s), _ ->
- let print = match self#callstyle with
- | CallVar | CallVoid -> self#pp_flow
- | CallApply -> self#pp_atom in
- Plib.substitute_list print s fmt xs
+ let print = match self#callstyle with
+ | CallVar | CallVoid -> self#pp_flow
+ | CallApply -> self#pp_atom in
+ Plib.substitute_list print s fmt xs
method virtual pp_apply : cmode -> term -> term list printer
@@ -498,21 +498,21 @@ struct
(fun _ ->
match self#op_real_of_int with
| Op op | Assoc op ->
- begin
- match flow with
- | Atom -> fprintf fmt "(%s %a)" op self#pp_atom e
- | Flow -> fprintf fmt "%s %a" op self#pp_atom e
- end
+ begin
+ match flow with
+ | Atom -> fprintf fmt "(%s %a)" op self#pp_atom e
+ | Flow -> fprintf fmt "%s %a" op self#pp_atom e
+ end
| Call f ->
- begin
- match self#callstyle with
- | CallVar | CallVoid ->
- fprintf fmt "%s(%a)" f self#pp_flow e
- | CallApply ->
- match flow with
- | Atom -> fprintf fmt "(%s %a)" f self#pp_atom e
- | Flow -> fprintf fmt "%s %a" f self#pp_atom e
- end)
+ begin
+ match self#callstyle with
+ | CallVar | CallVoid ->
+ fprintf fmt "%s(%a)" f self#pp_flow e
+ | CallApply ->
+ match flow with
+ | Atom -> fprintf fmt "(%s %a)" f self#pp_atom e
+ | Flow -> fprintf fmt "%s %a" f self#pp_atom e
+ end)
else match flow with
| Flow -> self#pp_flow fmt e
| Atom -> self#pp_atom fmt e
@@ -529,10 +529,10 @@ struct
begin fun _ ->
match phi (amode mode) with
| Assoc op | Op op ->
- if self#op_spaced op then
- fprintf fmt "%s %a" op (self#pp_arith_arg Atom) a
- else
- fprintf fmt "%s%a" op (self#pp_arith_arg Atom) a
+ if self#op_spaced op then
+ fprintf fmt "%s %a" op (self#pp_arith_arg Atom) a
+ else
+ fprintf fmt "%s%a" op (self#pp_arith_arg Atom) a
| Call f -> self#pp_arith_call ~f fmt [a]
end
@@ -542,7 +542,7 @@ struct
begin fun _ ->
match phi (amode mode) with
| Assoc op | Op op ->
- Plib.pp_binop ~op (self#pp_arith_arg Atom) fmt a b
+ Plib.pp_binop ~op (self#pp_arith_arg Atom) fmt a b
| Call f -> self#pp_arith_call ~f fmt [a;b]
end
@@ -554,11 +554,11 @@ struct
| Assoc op -> Plib.pp_assoc ~e:"?" ~op (self#pp_arith_arg Atom) fmt xs
| Op op -> Plib.pp_fold_binop ~e:"?" ~op (self#pp_arith_arg Atom) fmt xs
| Call f ->
- match self#callstyle with
- | CallVar | CallVoid ->
- Plib.pp_fold_call ~e:"?" ~f (self#pp_arith_arg Flow) fmt xs
- | CallApply ->
- Plib.pp_fold_apply ~e:"?" ~f (self#pp_arith_arg Atom) fmt xs
+ match self#callstyle with
+ | CallVar | CallVoid ->
+ Plib.pp_fold_call ~e:"?" ~f (self#pp_arith_arg Flow) fmt xs
+ | CallApply ->
+ Plib.pp_fold_apply ~e:"?" ~f (self#pp_arith_arg Atom) fmt xs
end
method private pp_arith_cmp ~phi fmt a b =
@@ -567,33 +567,33 @@ struct
let gmode = if is_real then Mreal else Mint in
match phi (cmode mode) amode with
| Assoc op | Op op ->
- self#with_mode gmode
- (fun emode ->
- let scope =
- match emode with
- | Mpositive | Mnegative
- | Mterm | Mterm_int | Mterm_real -> self#op_scope amode
- | Mint | Mreal -> None
- in match scope with
- | None ->
- begin
- fprintf fmt "@[<hov 2>" ;
- Plib.pp_binop ~op (self#pp_arith_arg Atom) fmt a b ;
- fprintf fmt "@]" ;
- end
- | Some s ->
- begin
- fprintf fmt "@[<hov 1>(" ;
- Plib.pp_binop ~op (self#pp_arith_arg Atom) fmt a b ;
- fprintf fmt ")%s@]" s ;
- end)
+ self#with_mode gmode
+ (fun emode ->
+ let scope =
+ match emode with
+ | Mpositive | Mnegative
+ | Mterm | Mterm_int | Mterm_real -> self#op_scope amode
+ | Mint | Mreal -> None
+ in match scope with
+ | None ->
+ begin
+ fprintf fmt "@[<hov 2>" ;
+ Plib.pp_binop ~op (self#pp_arith_arg Atom) fmt a b ;
+ fprintf fmt "@]" ;
+ end
+ | Some s ->
+ begin
+ fprintf fmt "@[<hov 1>(" ;
+ Plib.pp_binop ~op (self#pp_arith_arg Atom) fmt a b ;
+ fprintf fmt ")%s@]" s ;
+ end)
| Call f ->
- begin
- fprintf fmt "@[<hov 2>" ;
- self#with_mode gmode
- (fun _ -> self#pp_arith_call ~f fmt [a;b]) ;
- fprintf fmt "@]" ;
- end
+ begin
+ fprintf fmt "@[<hov 2>" ;
+ self#with_mode gmode
+ (fun _ -> self#pp_arith_call ~f fmt [a;b]) ;
+ fprintf fmt "@]" ;
+ end
method pp_times fmt k e =
if Z.equal k Z.minus_one
@@ -651,11 +651,11 @@ struct
| Assoc op -> Plib.pp_assoc ~e:"?" ~op pp_atom fmt xs
| Op op -> Plib.pp_fold_binop ~e:"?" ~op pp_atom fmt xs
| Call f ->
- match self#callstyle with
- | CallVar | CallVoid ->
- Plib.pp_fold_call ~e:"?" ~f pp_flow fmt xs
- | CallApply ->
- Plib.pp_fold_apply ~e:"?" ~f pp_atom fmt xs
+ match self#callstyle with
+ | CallVar | CallVoid ->
+ Plib.pp_fold_call ~e:"?" ~f pp_flow fmt xs
+ | CallApply ->
+ Plib.pp_fold_apply ~e:"?" ~f pp_atom fmt xs
(* -------------------------------------------------------------------------- *)
(* --- Equality --- *)
@@ -693,31 +693,31 @@ struct
match T.repr e with
| Bind(Lambda,t,e) ->
- let e = lc_repr e in
- let n,kts,e = lambda 1 [0,t] e in
- let last = Bvars.order (lc_vars e) + n - 1 in
- let binder (k,t) = bind_bvar (last-k) t index self#sanitize , t in
- let xts = List.map binder kts in
- self#pp_lambda fmt xts ;
- self#pp_binders fmt e
+ let e = lc_repr e in
+ let n,kts,e = lambda 1 [0,t] e in
+ let last = Bvars.order (lc_vars e) + n - 1 in
+ let binder (k,t) = bind_bvar (last-k) t index self#sanitize , t in
+ let xts = List.map binder kts in
+ self#pp_lambda fmt xts ;
+ self#pp_binders fmt e
| Bind((Forall|Exists) as q,t,e) ->
- let e = lc_repr e in
- let n,vars,e = binders q 1 (add_var 0 t TauMap.empty) e in
- let last = Bvars.order (lc_vars e) + n - 1 in
- TauMap.iter
- (fun t ks ->
- let binder k = bind_bvar (last-k) t index self#sanitize in
- let xs = List.fold_left (fun xs k -> binder k :: xs) [] ks in
- match q with
- | Forall -> fprintf fmt "%a@ " (self#pp_forall t) xs
- | Exists -> fprintf fmt "%a@ " (self#pp_exists t) xs
- | Lambda -> assert false
- ) vars ;
- self#pp_binders fmt e
+ let e = lc_repr e in
+ let n,vars,e = binders q 1 (add_var 0 t TauMap.empty) e in
+ let last = Bvars.order (lc_vars e) + n - 1 in
+ TauMap.iter
+ (fun t ks ->
+ let binder k = bind_bvar (last-k) t index self#sanitize in
+ let xs = List.fold_left (fun xs k -> binder k :: xs) [] ks in
+ match q with
+ | Forall -> fprintf fmt "%a@ " (self#pp_forall t) xs
+ | Exists -> fprintf fmt "%a@ " (self#pp_exists t) xs
+ | Lambda -> assert false
+ ) vars ;
+ self#pp_binders fmt e
| _ ->
- self#pp_shared fmt e
+ self#pp_shared fmt e
(* -------------------------------------------------------------------------- *)
(* --- Sharing --- *)
@@ -739,11 +739,11 @@ struct
method subterms f e =
match T.repr e with
| Rdef fts ->
- begin
- match T.record_with fts with
- | None -> T.lc_iter f e
- | Some(a,fts) -> f a ; List.iter (fun (_,e) -> f e) fts
- end
+ begin
+ match T.record_with fts with
+ | None -> T.lc_iter f e
+ | Some(a,fts) -> f a ; List.iter (fun (_,e) -> f e) fts
+ end
| _ -> T.lc_iter f e
method virtual pp_let : Format.formatter -> pmode -> string -> term -> unit
@@ -818,34 +818,34 @@ struct
self#op_minus amode
with
| Assoc add , Assoc sub , Op minus ->
- let factor x = match T.repr x with
- | Kint z when Z.lt z Z.zero-> (false,T.e_zint (Z.neg z))
- | Kreal r when Q.lt r Q.zero -> (false,T.e_real (Q.neg r))
- | Times(k,y) when Z.lt k Z.zero -> (false,T.e_times (Z.neg k) y)
- | _ -> (true,x) in
- let sxs = List.map factor xs in
- let sxs = List.stable_sort
- (fun (s1,e1) (s2,e2) ->
- match s1,s2 with
- | true,true | false,false ->
- Stdlib.compare (T.weigth e1) (T.weigth e2)
- | true,false -> (-1)
- | false,true -> 1
- ) sxs in
- Plib.iteri
- (fun i (s,x) ->
- begin
- match i , s with
- | (Ifirst | Isingle) , false ->
- if self#op_spaced minus && self#is_atomic x
- then fprintf fmt "%s " minus
- else pp_print_string fmt minus
- | (Ifirst | Isingle) , true -> ()
- | (Imiddle | Ilast) , true -> fprintf fmt "@ %s " add
- | (Imiddle | Ilast) , false -> fprintf fmt "@ %s " sub
- end ;
- self#pp_arith_arg Atom fmt x
- ) sxs
+ let factor x = match T.repr x with
+ | Kint z when Z.lt z Z.zero-> (false,T.e_zint (Z.neg z))
+ | Kreal r when Q.lt r Q.zero -> (false,T.e_real (Q.neg r))
+ | Times(k,y) when Z.lt k Z.zero -> (false,T.e_times (Z.neg k) y)
+ | _ -> (true,x) in
+ let sxs = List.map factor xs in
+ let sxs = List.stable_sort
+ (fun (s1,e1) (s2,e2) ->
+ match s1,s2 with
+ | true,true | false,false ->
+ Stdlib.compare (T.weigth e1) (T.weigth e2)
+ | true,false -> (-1)
+ | false,true -> 1
+ ) sxs in
+ Plib.iteri
+ (fun i (s,x) ->
+ begin
+ match i , s with
+ | (Ifirst | Isingle) , false ->
+ if self#op_spaced minus && self#is_atomic x
+ then fprintf fmt "%s " minus
+ else pp_print_string fmt minus
+ | (Ifirst | Isingle) , true -> ()
+ | (Imiddle | Ilast) , true -> fprintf fmt "@ %s " add
+ | (Imiddle | Ilast) , false -> fprintf fmt "@ %s " sub
+ end ;
+ self#pp_arith_arg Atom fmt x
+ ) sxs
| _ -> self#pp_arith_nary ~phi:(self#op_add) fmt xs
method pp_repr fmt e =
diff --git a/src/plugins/qed/export_why3.ml b/src/plugins/qed/export_why3.ml
index 2d7b39ce7c3d5412c4ee2cd93ffe2cf283f1e155..5f691a58fd0fb7b965438d598d7b1f4c627e2133 100644
--- a/src/plugins/qed/export_why3.ml
+++ b/src/plugins/qed/export_why3.ml
@@ -96,11 +96,11 @@ struct
method pp_int amode fmt k = match amode with
| Aint -> pp_print_string fmt (Z.to_string k)
| Areal ->
- if Z.lt k Z.zero then
- (* unary minus is -. instead of - in Why3... *)
- fprintf fmt "-.%s.0" (Z.to_string (Z.neg k))
- else
- fprintf fmt "%s.0" (Z.to_string k)
+ if Z.lt k Z.zero then
+ (* unary minus is -. instead of - in Why3... *)
+ fprintf fmt "-.%s.0" (Z.to_string (Z.neg k))
+ else
+ fprintf fmt "%s.0" (Z.to_string k)
method pp_real fmt r =
if Z.equal r.Q.den Z.one then
@@ -196,23 +196,23 @@ struct
method pp_forall tau fmt = function
| [] -> ()
| x::xs ->
- fprintf fmt "@[<hov 2>forall %a" self#pp_var x ;
- List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ;
- fprintf fmt "@ : %a.@]" self#pp_tau tau ;
+ fprintf fmt "@[<hov 2>forall %a" self#pp_var x ;
+ List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ;
+ fprintf fmt "@ : %a.@]" self#pp_tau tau ;
method pp_intros tau fmt = function
| [] -> ()
| x::xs ->
- fprintf fmt "@[<hov 2>forall %a" self#pp_var x ;
- List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ;
- fprintf fmt "@ : %a@]" self#pp_tau tau ;
+ fprintf fmt "@[<hov 2>forall %a" self#pp_var x ;
+ List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ;
+ fprintf fmt "@ : %a@]" self#pp_tau tau ;
method pp_exists tau fmt = function
| [] -> ()
| x::xs ->
- fprintf fmt "@[<hov 2>exists %a" self#pp_var x ;
- List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ;
- fprintf fmt "@ : %a.@]" self#pp_tau tau ;
+ fprintf fmt "@[<hov 2>exists %a" self#pp_var x ;
+ List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ;
+ fprintf fmt "@ : %a.@]" self#pp_tau tau ;
method pp_trigger fmt t =
let rec pretty fmt = function
@@ -227,18 +227,18 @@ struct
| F_call f, _
| F_bool_prop (f,_), Cterm
| F_bool_prop (_,f), Cprop ->
- Plib.pp_call_apply ~f pretty fmt ts
+ Plib.pp_call_apply ~f pretty fmt ts
| F_left f, _ -> Plib.pp_fold_apply ~f pretty fmt ts
| F_right f, _ -> Plib.pp_fold_apply_rev ~f pretty fmt (List.rev ts)
| F_assoc op, _ -> Plib.pp_assoc ~op pretty fmt ts
| F_subst (_, s), _ -> Plib.substitute_list pretty s fmt ts
| F_list(fc,fn) , _ ->
- let rec plist fc fn fmt = function
- | [] -> pp_print_string fmt fn
- | x::xs ->
- fprintf fmt "[<hov 2>(%s@ %a@ %a)@]" fc
- pretty x (plist fc fn) xs
- in plist fc fn fmt ts
+ let rec plist fc fn fmt = function
+ | [] -> pp_print_string fmt fn
+ | x::xs ->
+ fprintf fmt "[<hov 2>(%s@ %a@ %a)@]" fc
+ pretty x (plist fc fn) xs
+ in plist fc fn fmt ts
in fprintf fmt "@[<hov 2>%a@]" pretty t
(* -------------------------------------------------------------------------- *)
@@ -293,11 +293,11 @@ struct
) xs ;
match cmode with
| Cprop ->
- fprintf fmt " =@ @[<hov 0>%a@]@]@\n"
- self#pp_prop e
+ fprintf fmt " =@ @[<hov 0>%a@]@]@\n"
+ self#pp_prop e
| Cterm ->
- fprintf fmt " : %a =@ @[<hov 0>%a@]@]@\n"
- self#pp_tau t (self#pp_expr t) e
+ fprintf fmt " : %a =@ @[<hov 0>%a@]@]@\n"
+ self#pp_tau t (self#pp_expr t) e
end
method declare_fixpoint ~prefix fmt f xs t e =
diff --git a/src/plugins/qed/export_whycore.ml b/src/plugins/qed/export_whycore.ml
index 251bb091a8e7e248b49430bc980c1de6ce3532aa..5ee8ef25f54f58c1762694de5823202adb6b6f36 100644
--- a/src/plugins/qed/export_whycore.ml
+++ b/src/plugins/qed/export_whycore.ml
@@ -51,9 +51,9 @@ struct
let rec full_triggers = function
| [] -> []
| ts :: tgs ->
- match List.filter full_trigger ts with
- | [] -> full_triggers tgs
- | ts -> ts :: full_triggers tgs
+ match List.filter full_trigger ts with
+ | [] -> full_triggers tgs
+ | ts -> ts :: full_triggers tgs
class virtual engine =
object(self)
@@ -110,15 +110,15 @@ struct
(fun i (f,v) ->
( match i , base with
| (Isingle | Ifirst) , Some r ->
- fprintf fmt "@ %a with" self#pp_flow r
+ fprintf fmt "@ %a with" self#pp_flow r
| _ -> () ) ;
( match i with
| Ifirst | Imiddle ->
- fprintf fmt "@ @[<hov 2>%s = %a ;@]"
- (self#field f) self#pp_flow v
+ fprintf fmt "@ @[<hov 2>%s = %a ;@]"
+ (self#field f) self#pp_flow v
| Isingle | Ilast ->
- fprintf fmt "@ @[<hov 2>%s = %a@]"
- (self#field f) self#pp_flow v )
+ fprintf fmt "@ @[<hov 2>%s = %a@]"
+ (self#field f) self#pp_flow v )
) fvs ;
fprintf fmt "@ %s@]" right ;
end
@@ -150,30 +150,30 @@ struct
method declare_type fmt adt n = function
| Tabs ->
- self#pp_declare_adt fmt adt n ;
- pp_print_newline fmt ()
+ self#pp_declare_adt fmt adt n ;
+ pp_print_newline fmt ()
| Tdef def ->
- self#pp_declare_def fmt adt n def ;
- pp_print_newline fmt ()
+ self#pp_declare_def fmt adt n def ;
+ pp_print_newline fmt ()
| Tsum cases ->
- self#pp_declare_sum fmt adt n cases ;
- pp_print_newline fmt ()
+ self#pp_declare_sum fmt adt n cases ;
+ pp_print_newline fmt ()
| Trec fts ->
- begin
- Format.fprintf fmt "@[<hv 0>@[<hv 2>" ;
- self#pp_declare_adt fmt adt n ;
- let left,right = self#op_record in
- fprintf fmt " = %s" left ;
- Plib.iteri
- (fun index (f,t) ->
- match index with
- | Isingle | Ilast ->
- fprintf fmt "@ @[<hov 2>%s : %a@]" (self#field f) self#pp_tau t
- | Imiddle | Ifirst ->
- fprintf fmt "@ @[<hov 2>%s : %a@] ;" (self#field f) self#pp_tau t
- ) fts ;
- fprintf fmt "@] %s@]@\n" right ;
- end
+ begin
+ Format.fprintf fmt "@[<hv 0>@[<hv 2>" ;
+ self#pp_declare_adt fmt adt n ;
+ let left,right = self#op_record in
+ fprintf fmt " = %s" left ;
+ Plib.iteri
+ (fun index (f,t) ->
+ match index with
+ | Isingle | Ilast ->
+ fprintf fmt "@ @[<hov 2>%s : %a@]" (self#field f) self#pp_tau t
+ | Imiddle | Ifirst ->
+ fprintf fmt "@ @[<hov 2>%s : %a@] ;" (self#field f) self#pp_tau t
+ ) fts ;
+ fprintf fmt "@] %s@]@\n" right ;
+ end
method pp_declare_symbol t fmt f =
let name = link_name (self#link f) in
diff --git a/src/plugins/qed/hcons.ml b/src/plugins/qed/hcons.ml
index a95b21fe013c1952ddc2983d970e661997869a76..4d4928f3bc442668ebd575ce02753059abe14552 100644
--- a/src/plugins/qed/hcons.ml
+++ b/src/plugins/qed/hcons.ml
@@ -58,8 +58,8 @@ let rec compare_list cmp xs ys =
| [] , _ :: _ -> -1
| _ :: _ , [] -> 1
| x::xs , y::ys ->
- let c = cmp x y in
- if c = 0 then compare_list cmp xs ys else c
+ let c = cmp x y in
+ if c = 0 then compare_list cmp xs ys else c
let rec equal_list eq xs ys =
xs == ys ||
diff --git a/src/plugins/qed/intmap.ml b/src/plugins/qed/intmap.ml
index 58a2618a66b845ef29877e755deee3869423110f..e69c0336ffaa5ab21487d39a3889e5aa05f4c339 100644
--- a/src/plugins/qed/intmap.ml
+++ b/src/plugins/qed/intmap.ml
@@ -87,12 +87,12 @@ let pp_bits fmt k =
let rec pp_tree tab fmt = function
| Empty -> ()
| Lf(k,_) ->
- Format.fprintf fmt "%sL%a=%d@\n" tab pp_bits k k
+ Format.fprintf fmt "%sL%a=%d@\n" tab pp_bits k k
| Br(p,l,r) ->
- let next = tab ^ " " in
- pp_tree next fmt l ;
- Format.fprintf fmt "%s@@%a@\n" tab (pp_mask (decode_mask p)) p ;
- pp_tree next fmt r
+ let next = tab ^ " " in
+ pp_tree next fmt l ;
+ Format.fprintf fmt "%s@@%a@\n" tab (pp_mask (decode_mask p)) p ;
+ pp_tree next fmt r
(* -------------------------------------------------------------------------- *)
(* --- Bit utilities --- *)
@@ -187,16 +187,16 @@ let rec mem k = function
| Empty -> false
| Lf(i,_) -> i=k
| Br(p,t0,t1) ->
- match_prefix k p && mem k (if zero_bit k p then t0 else t1)
+ match_prefix k p && mem k (if zero_bit k p then t0 else t1)
let rec findq k = function
| Empty -> raise Not_found
| Lf(i,x) as t -> if k = i then (x,t) else raise Not_found
| Br(p,t0,t1) ->
- if match_prefix k p then
- findq k (if zero_bit k p then t0 else t1)
- else
- raise Not_found
+ if match_prefix k p then
+ findq k (if zero_bit k p then t0 else t1)
+ else
+ raise Not_found
let find k m = fst (findq k m)
@@ -211,16 +211,16 @@ let rec compare cmp s t =
| Empty , _ -> (-1)
| _ , Empty -> 1
| Lf(i,x) , Lf(j,y) ->
- let ck = Stdlib.compare i j in
- if ck = 0 then cmp x y else ck
+ let ck = Stdlib.compare i j in
+ if ck = 0 then cmp x y else ck
| Lf _ , _ -> (-1)
| _ , Lf _ -> 1
| Br(p,s0,s1) , Br(q,t0,t1) ->
- let cp = Stdlib.compare p q in
- if cp <> 0 then cp else
- let c0 = compare cmp s0 t0 in
- if c0 <> 0 then c0 else
- compare cmp s1 t1
+ let cp = Stdlib.compare p q in
+ if cp <> 0 then cp else
+ let c0 = compare cmp s0 t0 in
+ if c0 <> 0 then c0 else
+ compare cmp s1 t1
let rec equal eq s t =
if s == t then true else
@@ -232,7 +232,7 @@ let rec equal eq s t =
| Lf _ , _ -> false
| _ , Lf _ -> false
| Br(p,s0,s1) , Br(q,t0,t1) ->
- p==q && equal eq s0 t0 && equal eq s1 t1
+ p==q && equal eq s0 t0 && equal eq s1 t1
(* -------------------------------------------------------------------------- *)
(* --- Addition, Insert, Change, Remove --- *)
@@ -244,25 +244,25 @@ let rec change phi k x = function
| None -> t
| Some w -> Lf(k,w))
| Lf(i,y) as t ->
- if i = k then
- lf0 k y t (phi k x (Some y))
- else
- (match phi k x None with
- | None -> t
- | Some w -> let s = Lf(k,w) in
- join k s i t)
+ if i = k then
+ lf0 k y t (phi k x (Some y))
+ else
+ (match phi k x None with
+ | None -> t
+ | Some w -> let s = Lf(k,w) in
+ join k s i t)
| Br(p,t0,t1) as t ->
- if match_prefix k p then
- (* k belongs to tree *)
- if zero_bit k p
- then br0 p t0 t1 t (change phi k x t0) (* k is in t0 *)
- else br1 p t0 t1 t (change phi k x t1) (* k is in t1 *)
- else
- (* k is disjoint from tree *)
- (match phi k x None with
- | None -> t
- | Some w -> let s = Lf(k,w) in
- join k s p t)
+ if match_prefix k p then
+ (* k belongs to tree *)
+ if zero_bit k p
+ then br0 p t0 t1 t (change phi k x t0) (* k is in t0 *)
+ else br1 p t0 t1 t (change phi k x t1) (* k is in t1 *)
+ else
+ (* k is disjoint from tree *)
+ (match phi k x None with
+ | None -> t
+ | Some w -> let s = Lf(k,w) in
+ join k s p t)
(* good sharing *)
let insert f k x = change (fun _k x -> function
@@ -284,16 +284,16 @@ let mapi phi =
| Empty -> Empty
| Lf(k,x) -> Lf(k,phi k x)
| Br(p,t0,t1) ->
- let t0 = mapi phi t0 in
- let t1 = mapi phi t1 in
- Br(p,t0,t1)
+ let t0 = mapi phi t0 in
+ let t1 = mapi phi t1 in
+ Br(p,t0,t1)
in function (* to be sorted *)
| Empty -> Empty
| Lf(k,x) -> Lf(k,phi k x)
| Br(p,t0,t1) when p = max_int -> let t1 = mapi phi t1 in
- let t0 = mapi phi t0 in Br(p,t0,t1)
+ let t0 = mapi phi t0 in Br(p,t0,t1)
| Br(p,t0,t1) -> let t0 = mapi phi t0 in
- let t1 = mapi phi t1 in Br(p,t0,t1)
+ let t1 = mapi phi t1 in Br(p,t0,t1)
let map phi = mapi (fun _ x -> phi x)
let mapf phi =
@@ -305,9 +305,9 @@ let mapf phi =
| Empty -> Empty
| Lf(k,x) -> lf k (phi k x)
| Br(p,t0,t1) when p = max_int -> let t1 = mapf phi t1 in
- let t0 = mapf phi t0 in glue t0 t1
+ let t0 = mapf phi t0 in glue t0 t1
| Br(_,t0,t1) -> let t0 = mapf phi t0 in
- let t1 = mapf phi t1 in glue t0 t1
+ let t1 = mapf phi t1 in glue t0 t1
(* good sharing *)
let mapq phi =
@@ -315,20 +315,20 @@ let mapq phi =
| Empty as t -> t
| Lf(k,x) as t -> lf0 k x t (phi k x)
| Br(_,t0,t1) as t->
- let t0' = mapq phi t0 in
- let t1' = mapq phi t1 in
- glue01 t0' t1' t0 t1 t
+ let t0' = mapq phi t0 in
+ let t1' = mapq phi t1 in
+ glue01 t0' t1' t0 t1 t
in function (* to be sorted *)
| Empty as t -> t
| Lf(k,x) as t -> lf0 k x t (phi k x)
| Br(p,t0,t1) as t when p = max_int ->
- let t1' = mapq phi t1 in
- let t0' = mapq phi t0 in
- glue01 t0' t1' t0 t1 t
+ let t1' = mapq phi t1 in
+ let t0' = mapq phi t0 in
+ glue01 t0' t1' t0 t1 t
| Br(_,t0,t1) as t->
- let t0' = mapq phi t0 in
- let t1' = mapq phi t1 in
- glue01 t0' t1' t0 t1 t
+ let t0' = mapq phi t0 in
+ let t1' = mapq phi t1 in
+ glue01 t0' t1' t0 t1 t
(* good sharing *)
let filter f m = mapq (fun k v -> if f k v then Some v else None) m
@@ -338,22 +338,22 @@ let rec partition p = function
| Empty as t -> (t,t)
| Lf(k,x) as t -> if p k x then t,Empty else Empty,t
| Br(_,t0,t1) as t->
- let (t0',u0') = partition p t0 in
- let (t1',u1') = partition p t1 in
- if t0'==t0 && t1'==t1 then (t, u0') (* u0' and u1' are empty *)
- else if u0'==t0 && u1'==t1 then (t0', t) (* t0' and t1' are empty *)
- else (glue t0' t1'),(glue u0' u1')
+ let (t0',u0') = partition p t0 in
+ let (t1',u1') = partition p t1 in
+ if t0'==t0 && t1'==t1 then (t, u0') (* u0' and u1' are empty *)
+ else if u0'==t0 && u1'==t1 then (t0', t) (* t0' and t1' are empty *)
+ else (glue t0' t1'),(glue u0' u1')
(* good sharing *)
let rec partition_split p = function
| Empty as t -> (t,t)
| Lf(k,x) as t -> let u,v = p k x in (lf0 k x t u), (lf0 k x t v)
| Br(_,t0,t1) as t->
- let t0',u0' = partition_split p t0 in
- let t1',u1' = partition_split p t1 in
- if t0'==t0 && t1'==t1 then (t, u0') (* u0' and u1' are empty *)
- else if u0'==t0 && u1'==t1 then (t0', t) (* t0' and t1' are empty *)
- else (glue t0' t1'),(glue u0' u1')
+ let t0',u0' = partition_split p t0 in
+ let t1',u1' = partition_split p t1 in
+ if t0'==t0 && t1'==t1 then (t, u0') (* u0' and u1' are empty *)
+ else if u0'==t0 && u1'==t1 then (t0', t) (* t0' and t1' are empty *)
+ else (glue t0' t1'),(glue u0' u1')
(* -------------------------------------------------------------------------- *)
(* --- Iter --- *)
@@ -432,30 +432,30 @@ let rec interi lf_phi s t =
| Empty , _ -> Empty
| _ , Empty -> Empty
| Lf(i,x) , Lf(j,y) ->
- if i = j
- then lf_phi i x y
- else Empty
+ if i = j
+ then lf_phi i x y
+ else Empty
| Lf(i,x) , Br _ ->
- (match occur i t with None -> Empty | Some y -> lf_phi i x y)
+ (match occur i t with None -> Empty | Some y -> lf_phi i x y)
| Br _ , Lf(j,y) ->
- (match occur j s with None -> Empty | Some x -> lf_phi j x y)
+ (match occur j s with None -> Empty | Some x -> lf_phi j x y)
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue (interi lf_phi s0 t0) (interi lf_phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then interi lf_phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else interi lf_phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then interi lf_phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else interi lf_phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- Empty
+ if p == q then
+ (* prefixes agree *)
+ glue (interi lf_phi s0 t0) (interi lf_phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then interi lf_phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else interi lf_phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then interi lf_phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else interi lf_phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ Empty
let inter phi = interi (fun i x y -> Lf(i,phi i x y))
let interf phi = interi (fun i x y -> lf i (phi i x y))
@@ -471,28 +471,28 @@ let rec interq phi s t =
| Empty , _ -> s
| _ , Empty -> t
| Lf(i,x) , Lf(j,y) ->
- if i = j
- then lfq phi i x y s t
- else Empty
+ if i = j
+ then lfq phi i x y s t
+ else Empty
| Lf(i,x) , Br _ -> occur0 phi i x s t
| Br _ , Lf(j,y) -> occur1 phi j y s t
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue2 (interq phi s0 t0) (interq phi s1 t1) s0 s1 s t0 t1 t
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then interq phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else interq phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then interq phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else interq phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- Empty
+ if p == q then
+ (* prefixes agree *)
+ glue2 (interq phi s0 t0) (interq phi s1 t1) s0 s1 s t0 t1 t
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then interq phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else interq phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then interq phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else interq phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ Empty
(* -------------------------------------------------------------------------- *)
(* --- Union --- *)
@@ -514,29 +514,29 @@ let rec union phi s t =
| Empty , _ -> t
| _ , Empty -> s
| Lf(i,x) , Lf(j,y) ->
- if i = j
- then let w = phi i x y in
- if w == x then s else if w == y then t else Lf(i,w)
- else join i s j t
+ if i = j
+ then let w = phi i x y in
+ if w == x then s else if w == y then t else Lf(i,w)
+ else join i s j t
| Lf(i,x) , Br _ -> insert phi i x t
| Br _ , Lf(j,y) -> insert (fun j y x -> phi j x y) j y s
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- br2u p s0 s1 s t0 t1 t (union phi s0 t0) (union phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then br0u p s0 s1 s (union phi s0 t) (* t has bit m = 0 => t is inside s0 *)
- else br1u p s0 s1 s (union phi s1 t) (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then br0u q t0 t1 t (union phi s t0) (* s has bit n = 0 => s is inside t0 *)
- else br1u q t0 t1 t (union phi s t1) (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- join p s q t
+ if p == q then
+ (* prefixes agree *)
+ br2u p s0 s1 s t0 t1 t (union phi s0 t0) (union phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then br0u p s0 s1 s (union phi s0 t) (* t has bit m = 0 => t is inside s0 *)
+ else br1u p s0 s1 s (union phi s1 t) (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then br0u q t0 t1 t (union phi s t0) (* s has bit n = 0 => s is inside t0 *)
+ else br1u q t0 t1 t (union phi s t1) (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ join p s q t
(* -------------------------------------------------------------------------- *)
(* --- Merge --- *)
@@ -550,52 +550,52 @@ let rec merge phi s t =
| Empty , _ -> map2 phi t
| _ , Empty -> map1 phi s
| Lf(i,x) , Lf(j,y) ->
- if i = j then lf i (phi i (Some x) (Some y))
- else
- let a = lf i (phi i (Some x) None) in
- let b = lf j (phi j None (Some y)) in
- glue a b
+ if i = j then lf i (phi i (Some x) (Some y))
+ else
+ let a = lf i (phi i (Some x) None) in
+ let b = lf j (phi j None (Some y)) in
+ glue a b
| Lf(i,x) , Br(q,t0,t1) ->
- if match_prefix i q then
- (* leaf i is in tree t *)
- if zero_bit i q
- then glue (merge phi s t0) (map2 phi t1) (* s=i is in t0 *)
- else glue (map2 phi t0) (merge phi s t1) (* s=i is in t1 *)
- else
- (* leaf i does not appear in t *)
- glue (lf i (phi i (Some x) None)) (map2 phi t)
+ if match_prefix i q then
+ (* leaf i is in tree t *)
+ if zero_bit i q
+ then glue (merge phi s t0) (map2 phi t1) (* s=i is in t0 *)
+ else glue (map2 phi t0) (merge phi s t1) (* s=i is in t1 *)
+ else
+ (* leaf i does not appear in t *)
+ glue (lf i (phi i (Some x) None)) (map2 phi t)
| Br(p,s0,s1) , Lf(j,y) ->
- if match_prefix j p then
- (* leaf j is in tree s *)
- if zero_bit j p
- then glue (merge phi s0 t) (map1 phi s1) (* t=j is in s0 *)
- else glue (map1 phi s0) (merge phi s1 t) (* t=j is in s1 *)
- else
- (* leaf j does not appear in s *)
- glue (map1 phi s) (lf j (phi j None (Some y)))
+ if match_prefix j p then
+ (* leaf j is in tree s *)
+ if zero_bit j p
+ then glue (merge phi s0 t) (map1 phi s1) (* t=j is in s0 *)
+ else glue (map1 phi s0) (merge phi s1 t) (* t=j is in s1 *)
+ else
+ (* leaf j does not appear in s *)
+ glue (map1 phi s) (lf j (phi j None (Some y)))
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue (merge phi s0 t0) (merge phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then (* t has bit m = 0 => t is inside s0 *)
- glue (merge phi s0 t) (map1 phi s1)
- else (* t has bit m = 1 => t is inside s1 *)
- glue (map1 phi s0) (merge phi s1 t)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then (* s has bit n = 0 => s is inside t0 *)
- glue (merge phi s t0) (map2 phi t1)
- else (* s has bit n = 1 => s is inside t1 *)
- glue (map2 phi t0) (merge phi s t1)
- else
- glue (map1 phi s) (map2 phi t)
+ if p == q then
+ (* prefixes agree *)
+ glue (merge phi s0 t0) (merge phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then (* t has bit m = 0 => t is inside s0 *)
+ glue (merge phi s0 t) (map1 phi s1)
+ else (* t has bit m = 1 => t is inside s1 *)
+ glue (map1 phi s0) (merge phi s1 t)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then (* s has bit n = 0 => s is inside t0 *)
+ glue (merge phi s t0) (map2 phi t1)
+ else (* s has bit n = 1 => s is inside t1 *)
+ glue (map2 phi t0) (merge phi s t1)
+ else
+ glue (map1 phi s) (map2 phi t)
(* good sharing with s *)
let rec diffq phi s t =
@@ -603,35 +603,35 @@ let rec diffq phi s t =
| Empty , _ -> s
| _ , Empty -> s
| Lf(i,x) , Lf(j,y) ->
- if i = j
- then lfq phi i x y s t
- else s
+ if i = j
+ then lfq phi i x y s t
+ else s
| Lf(i,x) , Br _ ->
- (match occur i t with None -> s | Some y -> lfq phi i x y s t)
+ (match occur i t with None -> s | Some y -> lfq phi i x y s t)
| Br _ , Lf(j,y) -> change (fun j y x -> match x with None -> None | Some x -> phi j x y) j y s
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- let t0' = (diffq phi s0 t0) in
- let t1' = (diffq phi s1 t1) in
- glue01 t0' t1' s0 s1 s
- else if included_prefix p q then
- (* q contains p. *)
- if zero_bit q p
- then (* t has bit m = 0 => t is inside s0 *)
- let s0' = (diffq phi s0 t) in
- glue0 s0' s0 s1 s
- else (* t has bit m = 1 => t is inside s1 *)
- let s1' = (diffq phi s1 t) in
- glue1 s1' s0 s1 s
- else if included_prefix q p then
- (* p contains q. *)
- if zero_bit p q
- then diffq phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else diffq phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- s
+ if p == q then
+ (* prefixes agree *)
+ let t0' = (diffq phi s0 t0) in
+ let t1' = (diffq phi s1 t1) in
+ glue01 t0' t1' s0 s1 s
+ else if included_prefix p q then
+ (* q contains p. *)
+ if zero_bit q p
+ then (* t has bit m = 0 => t is inside s0 *)
+ let s0' = (diffq phi s0 t) in
+ glue0 s0' s0 s1 s
+ else (* t has bit m = 1 => t is inside s1 *)
+ let s1' = (diffq phi s1 t) in
+ glue1 s1' s0 s1 s
+ else if included_prefix q p then
+ (* p contains q. *)
+ if zero_bit p q
+ then diffq phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else diffq phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ s
(* -------------------------------------------------------------------------- *)
(* --- Iter Kernel --- *)
@@ -642,26 +642,26 @@ let rec iterk phi s t =
| Empty , _ | _ , Empty -> ()
| Lf(i,x) , Lf(j,y) -> if i = j then phi i x y
| Lf(i,x) , Br _ ->
- (match occur i t with None -> () | Some y -> phi i x y)
+ (match occur i t with None -> () | Some y -> phi i x y)
| Br _ , Lf(j,y) ->
- (match occur j s with None -> () | Some x -> phi j x y)
+ (match occur j s with None -> () | Some x -> phi j x y)
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (iterk phi s0 t0 ; iterk phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then iterk phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else iterk phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then iterk phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else iterk phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- ()
+ if p == q then
+ (* prefixes agree *)
+ (iterk phi s0 t0 ; iterk phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then iterk phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else iterk phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then iterk phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else iterk phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ ()
(* -------------------------------------------------------------------------- *)
(* --- Iter2 --- *)
@@ -675,49 +675,49 @@ let rec iter2 phi s t =
| Empty , _ -> iter22 phi t
| _ , Empty -> iter21 phi s
| Lf(i,x) , Lf(j,y) ->
- if i = j then phi i (Some x) (Some y)
- else ( phi i (Some x) None ; phi j None (Some y) )
+ if i = j then phi i (Some x) (Some y)
+ else ( phi i (Some x) None ; phi j None (Some y) )
| Lf(i,x) , Br(q,t0,t1) ->
- if match_prefix i q then
- (* leaf i is in tree t *)
- if zero_bit i q
- then (iter2 phi s t0 ; iter22 phi t1) (* s=i is in t0 *)
- else (iter22 phi t0 ; iter2 phi s t1) (* s=i is in t1 *)
- else
- (* leaf i does not appear in t *)
- (phi i (Some x) None ; iter22 phi t)
+ if match_prefix i q then
+ (* leaf i is in tree t *)
+ if zero_bit i q
+ then (iter2 phi s t0 ; iter22 phi t1) (* s=i is in t0 *)
+ else (iter22 phi t0 ; iter2 phi s t1) (* s=i is in t1 *)
+ else
+ (* leaf i does not appear in t *)
+ (phi i (Some x) None ; iter22 phi t)
| Br(p,s0,s1) , Lf(j,y) ->
- if match_prefix j p then
- (* leaf j is in tree s *)
- if zero_bit j p
- then (iter2 phi s0 t ; iter21 phi s1) (* t=j is in s0 *)
- else (iter21 phi s0 ; iter2 phi s1 t) (* t=j is in s1 *)
- else
- (* leaf j does not appear in s *)
- (iter21 phi s ; phi j None (Some y))
+ if match_prefix j p then
+ (* leaf j is in tree s *)
+ if zero_bit j p
+ then (iter2 phi s0 t ; iter21 phi s1) (* t=j is in s0 *)
+ else (iter21 phi s0 ; iter2 phi s1 t) (* t=j is in s1 *)
+ else
+ (* leaf j does not appear in s *)
+ (iter21 phi s ; phi j None (Some y))
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (iter2 phi s0 t0 ; iter2 phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then (* t has bit m = 0 => t is inside s0 *)
- (iter2 phi s0 t ; iter21 phi s1)
- else (* t has bit m = 1 => t is inside s1 *)
- (iter21 phi s0 ; iter2 phi s1 t)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then (* s has bit n = 0 => s is inside t0 *)
- (iter2 phi s t0 ; iter22 phi t1)
- else (* s has bit n = 1 => s is inside t1 *)
- (iter22 phi t0 ; iter2 phi s t1)
- else
- (iter21 phi s ; iter22 phi t)
+ if p == q then
+ (* prefixes agree *)
+ (iter2 phi s0 t0 ; iter2 phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then (* t has bit m = 0 => t is inside s0 *)
+ (iter2 phi s0 t ; iter21 phi s1)
+ else (* t has bit m = 1 => t is inside s1 *)
+ (iter21 phi s0 ; iter2 phi s1 t)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then (* s has bit n = 0 => s is inside t0 *)
+ (iter2 phi s t0 ; iter22 phi t1)
+ else (* s has bit n = 1 => s is inside t1 *)
+ (iter22 phi t0 ; iter2 phi s t1)
+ else
+ (iter21 phi s ; iter22 phi t)
(* -------------------------------------------------------------------------- *)
(* --- Intersects --- *)
@@ -731,22 +731,22 @@ let rec intersectf phi s t =
| Lf(i,x) , Br _ -> (match occur i t with None -> false | Some y -> phi i x y)
| Br _ , Lf(j,y) -> (match occur j s with None -> false | Some x -> phi j x y)
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (intersectf phi s0 t0) || (intersectf phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then intersectf phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else intersectf phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then intersectf phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else intersectf phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- false
+ if p == q then
+ (* prefixes agree *)
+ (intersectf phi s0 t0) || (intersectf phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then intersectf phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else intersectf phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then intersectf phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else intersectf phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ false
let intersect s t = intersectf (fun _i _x _y -> true) s t
(* -------------------------------------------------------------------------- *)
@@ -759,23 +759,23 @@ let rec subsetf phi s t =
| _ , Empty -> false
| Lf(i,x) , Lf(j,y) -> if i = j then phi i x y else false
| Lf(i,x) , Br _ ->
- (match occur i t with None -> false | Some y -> phi i x y)
+ (match occur i t with None -> false | Some y -> phi i x y)
| Br _ , Lf _ -> false
| Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (subsetf phi s0 t0 && subsetf phi s1 t1)
- else if included_prefix p q then
- (* q contains p: t is included in a (strict) subtree of s *)
- false
- else if included_prefix q p then
- (* p contains q: s is included in a subtree of t *)
- if zero_bit p q
- then subsetf phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else subsetf phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- false
+ if p == q then
+ (* prefixes agree *)
+ (subsetf phi s0 t0 && subsetf phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p: t is included in a (strict) subtree of s *)
+ false
+ else if included_prefix q p then
+ (* p contains q: s is included in a subtree of t *)
+ if zero_bit p q
+ then subsetf phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else subsetf phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ false
let subset = subsetf
let subsetk s t = subsetf (fun _i _x _y -> true) s t
diff --git a/src/plugins/qed/kind.ml b/src/plugins/qed/kind.ml
index aeff97808721c82ff7940b8e8c6cc205a5490f66..54795d235ed9057f86541783560ebbfc0fa2c231 100644
--- a/src/plugins/qed/kind.ml
+++ b/src/plugins/qed/kind.ml
@@ -54,8 +54,8 @@ let image = function Sarray s -> s | _ -> Sdata
let rec merge_list f s = function
| [] -> s
| x::xs ->
- if s = Sprop then Sprop
- else merge_list f (merge s (f x)) xs
+ if s = Sprop then Sprop
+ else merge_list f (merge s (f x)) xs
let pretty fmt = function
| Sprop -> Format.pp_print_string fmt "Prop"
@@ -78,8 +78,8 @@ let rec degree_of_tau = function
| Data(_,ts) -> degree_of_list ts
| Array(a,b) -> max (degree_of_tau a) (degree_of_tau b)
| Record fts ->
- List.fold_left
- (fun r (_,t) -> max r (degree_of_tau t)) 0 fts
+ List.fold_left
+ (fun r (_,t) -> max r (degree_of_tau t)) 0 fts
and degree_of_list = function
| [] -> 0
@@ -105,10 +105,10 @@ let pp_data pdata ptau fmt a = function
| [] -> pdata fmt a
| [t] -> Format.fprintf fmt "%a %a" ptau t pdata a
| t::ts ->
- Format.fprintf fmt "@[(@[<hov 2>%a" ptau t ;
- List.iter
- (fun t -> Format.fprintf fmt ",@,%a" ptau t) ts ;
- Format.fprintf fmt ")@]@ %a@]" pdata a
+ Format.fprintf fmt "@[(@[<hov 2>%a" ptau t ;
+ List.iter
+ (fun t -> Format.fprintf fmt ",@,%a" ptau t) ts ;
+ Format.fprintf fmt ")@]@ %a@]" pdata a
let pp_record pfield ptau fmt ?(opened=false) fts =
Format.fprintf fmt "@[<hv 0>{@[<hv 2>" ;
@@ -125,10 +125,10 @@ let rec pp_tau pvar pfield pdata fmt = function
| Prop -> Format.pp_print_string fmt "prop"
| Tvar x -> pvar fmt x
| Array(Int,te) ->
- Format.fprintf fmt "%a[]" (pp_tau pvar pfield pdata) te
+ Format.fprintf fmt "%a[]" (pp_tau pvar pfield pdata) te
| Array(tk,te) ->
- Format.fprintf fmt "%a[%a]"
- (pp_tau pvar pfield pdata) te (pp_tau pvar pfield pdata) tk
+ Format.fprintf fmt "%a[%a]"
+ (pp_tau pvar pfield pdata) te (pp_tau pvar pfield pdata) tk
| Data(a,ts) -> pp_data pdata (pp_tau pvar pfield pdata) fmt a ts
| Record fts -> pp_record pfield (pp_tau pvar pfield pdata) fmt fts
@@ -139,11 +139,11 @@ let rec hash_tau hfield hadt = function
| Prop -> 3
| Tvar k -> 4+k
| Array(tk,te) ->
- 7 * Hcons.hash_pair (hash_tau hfield hadt tk) (hash_tau hfield hadt te)
+ 7 * Hcons.hash_pair (hash_tau hfield hadt tk) (hash_tau hfield hadt te)
| Data(a,te) ->
- 11 * Hcons.hash_list (hash_tau hfield hadt) (hadt a) te
+ 11 * Hcons.hash_list (hash_tau hfield hadt) (hadt a) te
| Record fts ->
- Hcons.hash_list (hash_field hfield hadt) 13 fts
+ Hcons.hash_list (hash_field hfield hadt) 13 fts
and hash_field hfield hadt (f,t) =
Hcons.hash_pair (hfield f) (hash_tau hfield hadt t)
@@ -152,15 +152,15 @@ let rec eq_tau cfield cadt t1 t2 =
match t1 , t2 with
| (Bool|Int|Real|Prop|Tvar _) , (Bool|Int|Real|Prop|Tvar _) -> t1 = t2
| Array(ta,tb) , Array(ta',tb') ->
- eq_tau cfield cadt ta ta' && eq_tau cfield cadt tb tb'
+ eq_tau cfield cadt ta ta' && eq_tau cfield cadt tb tb'
| Array _ , _ | _ , Array _ -> false
| Data(a,ts) , Data(b,ts') ->
- cadt a b && Hcons.equal_list (eq_tau cfield cadt) ts ts'
+ cadt a b && Hcons.equal_list (eq_tau cfield cadt) ts ts'
| Data _ , _ | _ , Data _ -> false
| Record fts , Record gts ->
- Hcons.equal_list
- (fun (f,t) (g,t') -> cfield f g && eq_tau cfield cadt t t')
- fts gts
+ Hcons.equal_list
+ (fun (f,t) (g,t') -> cfield f g && eq_tau cfield cadt t t')
+ fts gts
| Record _ , _ | _ , Record _ -> false
let rec compare_tau cfield cadt t1 t2 =
@@ -181,21 +181,21 @@ let rec compare_tau cfield cadt t1 t2 =
| Tvar _ , _ -> (-1)
| _ , Tvar _ -> 1
| Array(ta,tb) , Array(ta',tb') ->
- let c = compare_tau cfield cadt ta ta' in
- if c = 0 then compare_tau cfield cadt tb tb' else c
+ let c = compare_tau cfield cadt ta ta' in
+ if c = 0 then compare_tau cfield cadt tb tb' else c
| Array _ , _ -> (-1)
| _ , Array _ -> 1
| Data(a,ts) , Data(b,ts') ->
- let c = cadt a b in
- if c = 0 then Hcons.compare_list (compare_tau cfield cadt) ts ts' else c
+ let c = cadt a b in
+ if c = 0 then Hcons.compare_list (compare_tau cfield cadt) ts ts' else c
| Data _ , _ -> (-1)
| _ , Data _ -> 1
| Record fts , Record gts ->
- Hcons.compare_list
- (fun (f,t) (g,t') ->
- let c = cfield f g in
- if c = 0 then compare_tau cfield cadt t t' else c
- ) fts gts
+ Hcons.compare_list
+ (fun (f,t) (g,t') ->
+ let c = cfield f g in
+ if c = 0 then compare_tau cfield cadt t t' else c
+ ) fts gts
module MakeTau(F : Field)(A : Data) =
struct
diff --git a/src/plugins/qed/listmap.ml b/src/plugins/qed/listmap.ml
index e118becc75c1a6616d91413cb17a4a2d90425730..b7cf3e4bec0dee18690ce6f830fc7c41dbe074fa 100644
--- a/src/plugins/qed/listmap.ml
+++ b/src/plugins/qed/listmap.ml
@@ -62,11 +62,11 @@ struct
let rec aux ((res,rest) as acc) = function
| [] -> List.rev_append res rest
| ((k,v) as i) :: resti ->
- (match f k v with
- | None -> (* remove *) aux ((rev_append_until i rest res),resti) resti
- | Some v' ->
- if v'==v then (* add idem *) aux acc resti
- else (* add new *) aux (((k,v')::(rev_append_until i rest res)),resti) resti)
+ (match f k v with
+ | None -> (* remove *) aux ((rev_append_until i rest res),resti) resti
+ | Some v' ->
+ if v'==v then (* add idem *) aux acc resti
+ else (* add new *) aux (((k,v')::(rev_append_until i rest res)),resti) resti)
in aux ([],l) l
(* good sharing *)
@@ -75,8 +75,8 @@ struct
let rec aux ((res,rest) as acc) = function
| [] -> List.rev_append res rest
| i :: resti ->
- if f i then (* add idem *) aux acc resti
- else (* remove *) aux ((rev_append_until i rest res),resti) resti
+ if f i then (* add idem *) aux acc resti
+ else (* remove *) aux ((rev_append_until i rest res),resti) resti
in aux ([],l) l
(* good sharing *)
@@ -85,8 +85,8 @@ struct
let rec aux ((res,rest) as acc) ((res',rest') as acc') = function
| [] -> (List.rev_append res rest), (List.rev_append res' rest')
| ((k,v) as i) :: resti ->
- if f k v then aux acc ((rev_append_until i rest' res'),resti) resti
- else aux ((rev_append_until i rest res),resti) acc' resti
+ if f k v then aux acc ((rev_append_until i rest' res'),resti) resti
+ else aux ((rev_append_until i rest res),resti) acc' resti
in aux ([],l) ([],l) l
(* good sharing *)
@@ -94,14 +94,14 @@ struct
let rec aux = function
| [] -> (match f k v None with None -> l | Some w -> l @ [k,w])
| ((k',v') as a)::next->
- let c = K.compare k k' in
- if c < 0 then l
- else if c = 0 then
- match f k v (Some v') with
- | None -> append_until a l next
- | Some w -> if w==v' then l
- else append_until a l ((k, w) :: next)
- else (* c > 0 *) aux next
+ let c = K.compare k k' in
+ if c < 0 then l
+ else if c = 0 then
+ match f k v (Some v') with
+ | None -> append_until a l next
+ | Some w -> if w==v' then l
+ else append_until a l ((k, w) :: next)
+ else (* c > 0 *) aux next
in aux l
(* good sharing *)
@@ -109,13 +109,13 @@ struct
let rec aux = function
| [] -> l @ [k,v]
| (((k',v') as a)::next) as w ->
- let c = K.compare k k' in
- if c < 0 then append_until a l ((k,v) :: w)
- else if c = 0 then
- let w = f k v v'
- in if w==v' then l
- else append_until a l ((k, w) :: next)
- else (* c > 0 *) aux next
+ let c = K.compare k k' in
+ if c < 0 then append_until a l ((k,v) :: w)
+ else if c = 0 then
+ let w = f k v v'
+ in if w==v' then l
+ else append_until a l ((k, w) :: next)
+ else (* c > 0 *) aux next
in aux l
(* good sharing *)
@@ -124,10 +124,10 @@ struct
let rec findk k = function
| [] -> raise Not_found
| ((k0,_) as e) :: next ->
- let c = K.compare k k0 in
- if c < 0 then raise Not_found else
- if c > 0 then findk k next else
- e
+ let c = K.compare k k0 in
+ if c < 0 then raise Not_found else
+ if c > 0 then findk k next else
+ e
let find k m = snd (findk k m)
@@ -147,9 +147,9 @@ struct
let rec mapf f = function
| [] -> []
| (k,x)::m ->
- match f k x with
- | Some y -> (k,y)::mapf f m
- | None -> mapf f m
+ match f k x with
+ | Some y -> (k,y)::mapf f m
+ | None -> mapf f m
let fold f m a = List.fold_left (fun a (k,v) -> f k v a) a m
@@ -157,21 +157,21 @@ struct
match w1 , w2 with
| [] , _ | _ , [] -> []
| (k1,v1)::r1 , (k2,v2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then inter f r1 w2 else
- if c > 0 then inter f w1 r2 else
- (k1,f k1 v1 v2) :: inter f r1 r2
+ let c = K.compare k1 k2 in
+ if c < 0 then inter f r1 w2 else
+ if c > 0 then inter f w1 r2 else
+ (k1,f k1 v1 v2) :: inter f r1 r2
let rec interf f w1 w2 =
match w1 , w2 with
| [] , _ | _ , [] -> []
| (k1,v1)::r1 , (k2,v2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then interf f r1 w2 else
- if c > 0 then interf f w1 r2 else
- match f k1 v1 v2 with
- | None -> interf f r1 r2
- | Some v12 -> (k1,v12) :: interf f r1 r2
+ let c = K.compare k1 k2 in
+ if c < 0 then interf f r1 w2 else
+ if c > 0 then interf f w1 r2 else
+ match f k1 v1 v2 with
+ | None -> interf f r1 r2
+ | Some v12 -> (k1,v12) :: interf f r1 r2
(* good sharing with w1 *)
let interq f w1 w2 =
@@ -180,13 +180,13 @@ struct
| [] , _ -> (* no addition *) List.rev_append res o1
| a1::_, [] -> (* no addition *) List.rev_append res (List.rev (rev_append_until a1 o1 []))
| ((k1,v1) as a1)::r1 , (k2,v2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 w2
- else if c > 0 then (* remove a2 *) aux acc w1 r2
- else match f k1 v1 v2 with
- | None -> (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 r2
- | Some w -> if w==v1 then (* adding a1 *) aux acc r1 r2
- else (* adding w *) aux (((k1,w)::(rev_append_until a1 o1 res)), r1) r1 r2
+ let c = K.compare k1 k2 in
+ if c < 0 then (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 w2
+ else if c > 0 then (* remove a2 *) aux acc w1 r2
+ else match f k1 v1 v2 with
+ | None -> (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 r2
+ | Some w -> if w==v1 then (* adding a1 *) aux acc r1 r2
+ else (* adding w *) aux (((k1,w)::(rev_append_until a1 o1 res)), r1) r1 r2
in aux ([],w1) w1 w2
(* good sharing with w1 *)
@@ -196,13 +196,13 @@ struct
| [] , _ -> (* no addition *) List.rev_append res o1
| _ , [] -> (* adding w1 *) List.rev_append res o1
| ((k1,v1) as a1)::r1 , (k2,v2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then (* adding a1 *) aux acc r1 w2
- else if c > 0 then (* skip *) aux acc w1 r2
- else match f k1 v1 v2 with
- | None -> (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 r2
- | Some w -> if w==v1 then (* adding a1 *) aux acc r1 r2
- else (* adding w *) aux (((k1,w)::(rev_append_until a1 o1 res)), r1) r1 r2
+ let c = K.compare k1 k2 in
+ if c < 0 then (* adding a1 *) aux acc r1 w2
+ else if c > 0 then (* skip *) aux acc w1 r2
+ else match f k1 v1 v2 with
+ | None -> (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 r2
+ | Some w -> if w==v1 then (* adding a1 *) aux acc r1 r2
+ else (* adding w *) aux (((k1,w)::(rev_append_until a1 o1 res)), r1) r1 r2
in aux ([],w1) w1 w2
(* good sharing with w1 *)
@@ -212,12 +212,12 @@ struct
| [] , _ -> (* adding w2 *) List.rev_append res (List.append o1 w2)
| _ , [] -> (* adding w1 *) List.rev_append res o1
| ((k1,v1) as a1)::r1 , ((k2,v2) as a2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then (* adding a1 *) aux acc r1 w2
- else if c = 0 then let w = f k1 v1 v2 in
- if w==v1 then (* adding a1 *) aux acc r1 r2
- else (* adding w *) aux (((k1,w)::(rev_append_until a1 o1 res)), r1) r1 r2
- else (* c > 0 *) (* adding a2 *) aux ((a2::(rev_append_until a1 o1 res)),w1) w1 r2
+ let c = K.compare k1 k2 in
+ if c < 0 then (* adding a1 *) aux acc r1 w2
+ else if c = 0 then let w = f k1 v1 v2 in
+ if w==v1 then (* adding a1 *) aux acc r1 r2
+ else (* adding w *) aux (((k1,w)::(rev_append_until a1 o1 res)), r1) r1 r2
+ else (* c > 0 *) (* adding a2 *) aux ((a2::(rev_append_until a1 o1 res)),w1) w1 r2
in aux ([],w1) w1 w2
let rec subset f w1 w2 =
@@ -225,10 +225,10 @@ struct
| [] , _ -> true
| _::_ , [] -> false
| (k1,v1)::r1 , (k2,v2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then false else
- if c > 0 then subset f w1 r2 else
- f k1 v1 v2 && subset f r1 r2
+ let c = K.compare k1 k2 in
+ if c < 0 then false else
+ if c > 0 then subset f w1 r2 else
+ f k1 v1 v2 && subset f r1 r2
let rec iterk
(f : K.t -> 'a -> 'b -> unit)
@@ -238,10 +238,10 @@ struct
match w1 , w2 with
| [] , _ | _ , [] -> ()
| (k1,v1)::r1 , (k2,v2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then iterk f r1 w2 else
- if c > 0 then iterk f w1 r2 else
- (f k1 v1 v2 ; iterk f r1 r2)
+ let c = K.compare k1 k2 in
+ if c < 0 then iterk f r1 w2 else
+ if c > 0 then iterk f w1 r2 else
+ (f k1 v1 v2 ; iterk f r1 r2)
let rec iter2
(f : K.t -> 'a option -> 'b option -> unit)
@@ -253,10 +253,10 @@ struct
| _ , [] -> List.iter (fun (k1,v1) -> f k1 (Some v1) None) w1
| [] , _ -> List.iter (fun (k2,v2) -> f k2 None (Some v2)) w2
| (k1,v1)::r1 , (k2,v2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then (f k1 (Some v1) None ; iter2 f r1 w2) else
- if c > 0 then (f k2 None (Some v2) ; iter2 f w1 r2) else
- (f k1 (Some v1) (Some v2) ; iter2 f r1 r2)
+ let c = K.compare k1 k2 in
+ if c < 0 then (f k1 (Some v1) None ; iter2 f r1 w2) else
+ if c > 0 then (f k2 None (Some v2) ; iter2 f w1 r2) else
+ (f k1 (Some v1) (Some v2) ; iter2 f r1 r2)
let cons k v w =
match v with
@@ -271,9 +271,9 @@ struct
| _ , [] -> mapf (fun k1 v1 -> f k1 (Some v1) None) w1
| [] , _ -> mapf (fun k2 v2 -> f k2 None (Some v2)) w2
| (k1,v1)::r1 , (k2,v2)::r2 ->
- let c = K.compare k1 k2 in
- if c < 0 then cons k1 (f k1 (Some v1) None) (merge f r1 w2) else
- if c > 0 then cons k2 (f k2 None (Some v2)) (merge f w1 r2) else
- cons k1 (f k1 (Some v1) (Some v2)) (merge f r1 r2)
+ let c = K.compare k1 k2 in
+ if c < 0 then cons k1 (f k1 (Some v1) None) (merge f r1 w2) else
+ if c > 0 then cons k2 (f k2 None (Some v2)) (merge f w1 r2) else
+ cons k1 (f k1 (Some v1) (Some v2)) (merge f r1 r2)
end
diff --git a/src/plugins/qed/listset.ml b/src/plugins/qed/listset.ml
index 2143a31039be34ada361f407784093ad69ec850e..9d0b5766f622dd8bafbb48bf88fe89aa3fb887e1 100644
--- a/src/plugins/qed/listset.ml
+++ b/src/plugins/qed/listset.ml
@@ -62,8 +62,8 @@ struct
let rec aux ((res,rest) as acc) = function
| [] -> List.rev_append res rest
| i :: resti ->
- if f i then aux acc resti
- else aux ((rev_append_until i rest res),resti) resti
+ if f i then aux acc resti
+ else aux ((rev_append_until i rest res),resti) resti
in aux ([],l) l
(* good sharing *)
@@ -71,8 +71,8 @@ struct
let rec aux ((res,rest) as acc) ((res',rest') as acc') = function
| [] -> (List.rev_append res rest), (List.rev_append res' rest')
| i :: resti ->
- if f i then aux acc ((rev_append_until i rest' res'),resti) resti
- else aux ((rev_append_until i rest res),resti) acc' resti
+ if f i then aux acc ((rev_append_until i rest' res'),resti) resti
+ else aux ((rev_append_until i rest res),resti) acc' resti
in aux ([],l) ([],l) l
(* good sharing *)
@@ -80,10 +80,10 @@ struct
let rec aux = function
| [] -> l @ [k]
| (k'::next) as w ->
- let c = E.compare k k' in
- if c < 0 then append_until k' l (k::w)
- else if c = 0 then l
- else (* c > 0 *) aux next
+ let c = E.compare k k' in
+ if c < 0 then append_until k' l (k::w)
+ else if c = 0 then l
+ else (* c > 0 *) aux next
in aux l
(* good sharing *)
@@ -91,18 +91,18 @@ struct
let rec aux = function
| [] -> l
| (k'::next) as w ->
- let c = E.compare k k' in
- if c > 0 then append_until k' l w
- else if c = 0 then append_until k' l next
- else (* c > 0 *) aux next
+ let c = E.compare k k' in
+ if c > 0 then append_until k' l w
+ else if c = 0 then append_until k' l next
+ else (* c > 0 *) aux next
in aux l
let rec mem x = function
| [] -> false
| e::es ->
- let c = E.compare x e in
- if c < 0 then false else
- if c > 0 then mem x es else true
+ let c = E.compare x e in
+ if c < 0 then false else
+ if c > 0 then mem x es else true
let iter = List.iter
let fold = List.fold_right
@@ -114,10 +114,10 @@ struct
| [] , _ -> (* adding w2 *) List.rev_append res (List.append o1 w2)
| _ , [] -> (* adding w1 *) List.rev_append res o1
| a1::r1 , a2::r2 ->
- let c = E.compare a1 a2 in
- if c < 0 then (* adding a1 *) aux acc r1 w2
- else if c = 0 then (* adding a1 *) aux acc r1 r2
- else (* c > 0 *) (* adding a2 *) aux ((a2::(rev_append_until a1 o1 res)),w1) w1 r2
+ let c = E.compare a1 a2 in
+ if c < 0 then (* adding a1 *) aux acc r1 w2
+ else if c = 0 then (* adding a1 *) aux acc r1 r2
+ else (* c > 0 *) (* adding a2 *) aux ((a2::(rev_append_until a1 o1 res)),w1) w1 r2
in aux ([],w1) w1 w2
(* good sharing with w1 *)
@@ -127,11 +127,11 @@ struct
| [] , _ -> (* no addition *) List.rev_append res o1
| a1::_, [] -> (* no addition *) List.rev_append res (List.rev (rev_append_until a1 o1 []))
| a1::r1 , a2::r2 ->
- let c = E.compare a1 a2 in
- if c < 0 then (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 w2
- else if c > 0 then (* skip a2 *) aux acc w1 r2
- else if not (f a1) then (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 r2
- else (* adding a1 *) aux acc r1 r2
+ let c = E.compare a1 a2 in
+ if c < 0 then (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 w2
+ else if c > 0 then (* skip a2 *) aux acc w1 r2
+ else if not (f a1) then (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 r2
+ else (* adding a1 *) aux acc r1 r2
in aux ([],w1) w1 w2
let inter = interf (fun _ -> true)
@@ -143,10 +143,10 @@ struct
| [] , _ -> (* no addition *) List.rev_append res o1
| _ , [] -> (* adding w1 *) List.rev_append res o1
| a1::r1 , a2::r2 ->
- let c = E.compare a1 a2 in
- if c < 0 then (* adding a1 *) aux acc r1 w2
- else if c > 0 then (* skip *) aux acc w1 r2
- else (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 r2
+ let c = E.compare a1 a2 in
+ if c < 0 then (* adding a1 *) aux acc r1 w2
+ else if c > 0 then (* skip *) aux acc w1 r2
+ else (* remove a1 *) aux ((rev_append_until a1 o1 res),r1) r1 r2
in aux ([],w1) w1 w2
let rec subsetf f xs ys =
@@ -154,10 +154,10 @@ struct
| [] , _ -> true
| _::_ , [] -> false
| (x::xtail) , (y::ytail) ->
- let c = E.compare x y in
- if c < 0 then false else
- if c > 0 then subsetf f xs ytail else
- (f x && subsetf f xtail ytail)
+ let c = E.compare x y in
+ if c < 0 then false else
+ if c > 0 then subsetf f xs ytail else
+ (f x && subsetf f xtail ytail)
let subset = subsetf (fun _ -> true)
@@ -165,21 +165,21 @@ struct
match xs , ys with
| [] , _ | _ , [] -> false
| (x::xtail) , (y::ytail) ->
- let c = E.compare x y in
- if c < 0 then intersectf f xtail ys else
- if c > 0 then intersectf f xs ytail else
- f x
+ let c = E.compare x y in
+ if c < 0 then intersectf f xtail ys else
+ if c > 0 then intersectf f xs ytail else
+ f x
let intersect = intersectf (fun _ -> true)
let rec fact rxs cxs rys xs ys =
match xs , ys with
| [] , _ | _ , [] ->
- List.rev_append rxs xs , List.rev cxs , List.rev_append rys ys
+ List.rev_append rxs xs , List.rev cxs , List.rev_append rys ys
| x::xtail , y::ytail ->
- let c = E.compare x y in
- if c < 0 then fact (x::rxs) cxs rys xtail ys else
- if c > 0 then fact rxs cxs (y::rys) xs ytail else
- fact rxs (x::cxs) rys xtail ytail
+ let c = E.compare x y in
+ if c < 0 then fact (x::rxs) cxs rys xtail ys else
+ if c > 0 then fact rxs cxs (y::rys) xs ytail else
+ fact rxs (x::cxs) rys xtail ytail
let factorize xs ys = fact [] [] [] xs ys
diff --git a/src/plugins/qed/plib.ml b/src/plugins/qed/plib.ml
index 5010f6b25232dd7772bbd8c48a4b390152eb2540..f86e39e573f14fec8d12d554bbea54f946d7ea32 100644
--- a/src/plugins/qed/plib.ml
+++ b/src/plugins/qed/plib.ml
@@ -47,23 +47,23 @@ type 'a printer2 = formatter -> 'a -> 'a -> unit
let pp_call_var ~f pp fmt = function
| [] -> pp_print_string fmt f
| x::xs ->
- fprintf fmt "@[<hov 2>%s(%a" f pp x ;
- List.iter (fun y -> fprintf fmt ",@ %a" pp y) xs ;
- fprintf fmt ")@]"
+ fprintf fmt "@[<hov 2>%s(%a" f pp x ;
+ List.iter (fun y -> fprintf fmt ",@ %a" pp y) xs ;
+ fprintf fmt ")@]"
let pp_call_void ~f pp fmt = function
| [] -> fprintf fmt "%s()" f
| x::xs ->
- fprintf fmt "@[<hov 2>%s(%a" f pp x ;
- List.iter (fun y -> fprintf fmt ",@ %a" pp y) xs ;
- fprintf fmt ")@]"
+ fprintf fmt "@[<hov 2>%s(%a" f pp x ;
+ List.iter (fun y -> fprintf fmt ",@ %a" pp y) xs ;
+ fprintf fmt ")@]"
let pp_call_apply ~f pp fmt = function
| [] -> pp_print_string fmt f
| xs ->
- fprintf fmt "@[<hov 2>(%s" f ;
- List.iter (fun y -> fprintf fmt "@ %a" pp y) xs ;
- fprintf fmt ")@]"
+ fprintf fmt "@[<hov 2>(%s" f ;
+ List.iter (fun y -> fprintf fmt "@ %a" pp y) xs ;
+ fprintf fmt ")@]"
let pp_binop ~op pp fmt a b =
fprintf fmt "%a@ %s %a" pp a op pp b
@@ -76,7 +76,7 @@ let print_not_empty s fmt = function
let pp_assoc ?e ~op pp fmt = function
| [] -> print_not_empty op fmt e
| x::xs ->
- pp fmt x ; List.iter (fun y -> fprintf fmt " %s@ %a" op pp y) xs
+ pp fmt x ; List.iter (fun y -> fprintf fmt " %s@ %a" op pp y) xs
let rec pp_fold_binop ?e ~op pp fmt = function
| [] -> print_not_empty op fmt e
@@ -106,14 +106,14 @@ let rec pp_fold_apply_rev ?e ~f pp fmt = function
let pp_listcompact ~sep pp fmt = function
| [] -> ()
| x::xs ->
- pp fmt x ;
- List.iter (fun x -> fprintf fmt "%s@,%a" sep pp x) xs
+ pp fmt x ;
+ List.iter (fun x -> fprintf fmt "%s@,%a" sep pp x) xs
let pp_listsep ~sep pp fmt = function
| [] -> ()
| x::xs ->
- pp fmt x ;
- List.iter (fun x -> fprintf fmt "%s@ %a" sep pp x) xs
+ pp fmt x ;
+ List.iter (fun x -> fprintf fmt "%s@ %a" sep pp x) xs
type index = Isingle | Ifirst | Ilast | Imiddle
@@ -121,11 +121,11 @@ let iteri f = function
| [] -> ()
| [x] -> f Isingle x
| x::xs ->
- let rec iterk f = function
- | [] -> ()
- | [x] -> f Ilast x
- | x::xs -> f Imiddle x ; iterk f xs
- in f Ifirst x ; iterk f xs
+ let rec iterk f = function
+ | [] -> ()
+ | [x] -> f Ilast x
+ | x::xs -> f Imiddle x ; iterk f xs
+ in f Ifirst x ; iterk f xs
let iterk f xs =
let rec step f k = function
@@ -137,8 +137,8 @@ let mapk f xs =
let rec step f k = function
| [] -> []
| x::xs ->
- let y = f k x in
- y :: step f (succ k) xs
+ let y = f k x in
+ y :: step f (succ k) xs
in step f 0 xs
(** the regexp shouldn't match empty *)
diff --git a/src/plugins/qed/pretty.ml b/src/plugins/qed/pretty.ml
index b1d52e4c93666efd3ec2ef56c2883b89b60334c2..b7e1c2837ad8e62d0ed5d0229900dfa885b682c3 100644
--- a/src/plugins/qed/pretty.ml
+++ b/src/plugins/qed/pretty.ml
@@ -64,11 +64,11 @@ struct
let subterms f e =
match T.repr e with
| Rdef fts ->
- begin
- match T.record_with fts with
- | None -> T.lc_iter f e
- | Some(a,fts) -> f a ; List.iter (fun (_,e) -> f e) fts
- end
+ begin
+ match T.record_with fts with
+ | None -> T.lc_iter f e
+ | Some(a,fts) -> f a ; List.iter (fun (_,e) -> f e) fts
+ end
| _ -> T.lc_iter f e
(* -------------------------------------------------------------------------- *)
@@ -169,10 +169,10 @@ struct
and group_collect q k kts = function
| [] -> [q,kts]
| (q0,t) :: qts ->
- if q = q0 && q0 <> Lambda then
- group_collect q (succ k) (group_add t k kts) qts
- else
- (q,kts) :: group_collect q0 (succ k) (group_var t k) qts
+ if q = q0 && q0 <> Lambda then
+ group_collect q (succ k) (group_add t k kts) qts
+ else
+ (q,kts) :: group_collect q0 (succ k) (group_var t k) qts
(* -------------------------------------------------------------------------- *)
(* --- Output Form --- *)
@@ -230,9 +230,9 @@ struct
| Not e -> Unop("not ",e)
| Imply(hs,p) ->Vbox("->",hs@[p])
| Eq(a,b) ->
- if T.sort e = Sprop
- then Vbox("<->",[a;b])
- else Hbox("=",[a;b])
+ if T.sort e = Sprop
+ then Vbox("<->",[a;b])
+ else Hbox("=",[a;b])
| Lt(a,b) -> Hbox("<",[a;b])
| Neq(a,b) -> Hbox("!=",[a;b])
| Leq(a,b) -> Hbox("<=",[a;b])
@@ -301,11 +301,11 @@ struct
List.iter
(function
| With r ->
- fprintf fmt "@ %a with" (pp_atom env) r
+ fprintf fmt "@ %a with" (pp_atom env) r
| Field (f,v) ->
- fprintf fmt "@ @[<hov 2>%a =@ %a ;@]" Field.pretty f (pp_free env) v
+ fprintf fmt "@ @[<hov 2>%a =@ %a ;@]" Field.pretty f (pp_free env) v
| Last (f,v) ->
- fprintf fmt "@ @[<hov 2>%a =@ %a@]" Field.pretty f (pp_free env) v
+ fprintf fmt "@ @[<hov 2>%a =@ %a@]" Field.pretty f (pp_free env) v
) fs ;
fprintf fmt "@]@ }@]"
@@ -323,9 +323,9 @@ struct
and pp_call (env:env) (fmt:formatter) f = function
| [] -> Fun.pretty fmt f
| es ->
- fprintf fmt "@[<hov 2>(%a" Fun.pretty f ;
- List.iter (fun e -> fprintf fmt "@ %a" (pp_atom env) e) es ;
- fprintf fmt ")@]"
+ fprintf fmt "@[<hov 2>(%a" Fun.pretty f ;
+ List.iter (fun e -> fprintf fmt "@ %a" (pp_atom env) e) es ;
+ fprintf fmt ")@]"
(* -------------------------------------------------------------------------- *)
(* --- Sum printer --- *)
@@ -342,9 +342,9 @@ struct
in match ps , ns with
| [] , [] -> pp_print_string fmt "0"
| [] , _ ->
- if free
- then fprintf fmt "(%a)" (pp_factor env "-") ns
- else pp_factor env "-" fmt ns
+ if free
+ then fprintf fmt "(%a)" (pp_factor env "-") ns
+ else pp_factor env "-" fmt ns
| p::ps , ns -> fprintf fmt "%a%a%a"
(pp_atom env) p
(pp_factor env "+") ps
@@ -368,8 +368,8 @@ struct
and pp_vbox (env:env) (sep:string) (fmt:formatter) = function
| [] -> ()
| e::es ->
- pp_atom env fmt e ;
- List.iter (fun e -> fprintf fmt "@ %s %a" sep (pp_atom env) e) es
+ pp_atom env fmt e ;
+ List.iter (fun e -> fprintf fmt "@ %s %a" sep (pp_atom env) e) es
(* -------------------------------------------------------------------------- *)
(* --- Specific Operators --- *)
diff --git a/src/plugins/qed/term.ml b/src/plugins/qed/term.ml
index 41c77b8df9ff19ff74a1684304041ec375067fbb..7100660a427f69befb3ef9b590209145ffee0c59 100644
--- a/src/plugins/qed/term.ml
+++ b/src/plugins/qed/term.ml
@@ -156,7 +156,7 @@ struct
| If(e,a,b) | Aset(e,a,b) -> hash_triple e.hash a.hash b.hash
| Fun(f,xs) -> hash_list hash (Fun.hash f) xs
| Rdef fxs ->
- hash_list (fun (f,x) -> hash_pair (Field.hash f) x.hash) 0 fxs
+ hash_list (fun (f,x) -> hash_pair (Field.hash f) x.hash) 0 fxs
| Rget(e,f) -> hash_pair e.hash (Field.hash f)
| Fvar x -> Var.hash x
| Bvar(k,_) -> k
@@ -227,9 +227,9 @@ struct
| Apply(x,ys) , Apply(x',ys') -> x==x' && eq_list ys ys'
| Rget(x,f) , Rget(x',g) -> x==x' && Field.equal f g
| Rdef fxs , Rdef gys ->
- equal_list (fun (f,x) (g,y) -> x==y && Field.equal f g) fxs gys
+ equal_list (fun (f,x) (g,y) -> x==y && Field.equal f g) fxs gys
| _ ->
- assert (hash_head a <> hash_head b) ; false
+ assert (hash_head a <> hash_head b) ; false
let equal_tau t1 t2 =
match t1, t2 with
@@ -246,11 +246,11 @@ struct
| True | False | Kint _ | Kreal _ -> Vars.empty
| Times(_,x) | Not x | Rget(x,_) | Acst(_,x) -> x.vars
| Add xs | Mul xs | And xs | Or xs | Fun(_,xs) ->
- Hcons.fold_list Vars.union (fun x -> x.vars) Vars.empty xs
+ Hcons.fold_list Vars.union (fun x -> x.vars) Vars.empty xs
| Div(x,y) | Mod(x,y) | Eq(x,y) | Neq(x,y) | Leq(x,y) | Lt(x,y) | Aget(x,y) ->
- Vars.union x.vars y.vars
+ Vars.union x.vars y.vars
| Imply(xs,a) | Apply(a,xs) ->
- Hcons.fold_list Vars.union vars a.vars xs
+ Hcons.fold_list Vars.union vars a.vars xs
| If(e,a,b) | Aset(e,a,b) -> Vars.union e.vars (Vars.union a.vars b.vars)
| Fvar x -> Vars.singleton x
| Bvar _ -> Vars.empty
@@ -261,11 +261,11 @@ struct
| True | False | Kint _ | Kreal _ -> Bvars.empty
| Times(_,x) | Not x | Rget(x,_) | Acst(_,x) -> x.bind
| Add xs | Mul xs | And xs | Or xs | Fun(_,xs) ->
- Hcons.fold_list Bvars.union (fun x -> x.bind) Bvars.empty xs
+ Hcons.fold_list Bvars.union (fun x -> x.bind) Bvars.empty xs
| Div(x,y) | Mod(x,y) | Eq(x,y) | Neq(x,y) | Leq(x,y) | Lt(x,y) | Aget(x,y) ->
- Bvars.union x.bind y.bind
+ Bvars.union x.bind y.bind
| Imply(xs,a) | Apply(a,xs) ->
- Hcons.fold_list Bvars.union bvars a.bind xs
+ Hcons.fold_list Bvars.union bvars a.bind xs
| If(e,a,b) | Aset(e,a,b) -> Bvars.union e.bind (Bvars.union a.bind b.bind)
| Bvar(k,_) -> Bvars.singleton k
| Fvar _ -> Bvars.empty
@@ -296,9 +296,9 @@ struct
| Bind((Forall|Exists),_,_) -> Sprop
| Bind(Lambda,_,e) -> e.sort
| Eq(a,b) | Neq(a,b) ->
- match a.sort , b.sort with
- | Sprop , _ | _ , Sprop -> Sprop
- | _ -> Sbool
+ match a.sort , b.sort with
+ | Sprop , _ | _ , Sprop -> Sprop
+ | _ -> Sbool
let rec size_list n w = function
| [] -> n+w
@@ -504,18 +504,18 @@ struct
| Leq(a1,b1) , Leq(a2,b2)
| Div(a1,b1) , Div(a2,b2)
| Mod(a1,b1) , Mod(a2,b2) ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- let cmp = phi a1 a2 in
- if cmp <> 0 then cmp else phi b1 b2
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ let cmp = phi a1 a2 in
+ if cmp <> 0 then cmp else phi b1 b2
| Fun(f,xs) , Fun(g,ys) ->
- let cmp = fun_rank f - fun_rank g in
+ let cmp = fun_rank f - fun_rank g in
+ if cmp <> 0 then cmp else
+ let cmp = cmp_size a b in
if cmp <> 0 then cmp else
- let cmp = cmp_size a b in
+ let cmp = Fun.compare f g in
if cmp <> 0 then cmp else
- let cmp = Fun.compare f g in
- if cmp <> 0 then cmp else
- Hcons.compare_list phi xs ys
+ Hcons.compare_list phi xs ys
| Fun (_,[]) , _ -> (-1) (* (a) as a variable *)
| _ , Fun (_,[]) -> 1
| Eq _ , _ -> (-1) (* (b) equality *)
@@ -530,24 +530,24 @@ struct
| _ , Fun _ -> 1
| Times(a1,x) , Times(a2,y) ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- let cmp = Z.compare a1 a2 in
- if cmp <> 0 then cmp else phi x y
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ let cmp = Z.compare a1 a2 in
+ if cmp <> 0 then cmp else phi x y
| Times _ , _ -> (-1)
| _ , Times _ -> 1
| Not x , Not y ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- phi x y
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ phi x y
| Not _ , _ -> (-1)
| _ , Not _ -> 1
| Imply(h1,p1) , Imply(h2,p2) ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- Hcons.compare_list phi (p1::h1) (p2::h2)
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ Hcons.compare_list phi (p1::h1) (p2::h2)
| Imply _ , _ -> (-1)
| _ , Imply _ -> 1
@@ -555,9 +555,9 @@ struct
| Mul xs , Mul ys
| And xs , And ys
| Or xs , Or ys ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- Hcons.compare_list phi xs ys
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ Hcons.compare_list phi xs ys
| Add _ , _ -> (-1)
| _ , Add _ -> 1
@@ -573,69 +573,69 @@ struct
| _ , Mod _ -> 1
| If(a1,b1,c1) , If(a2,b2,c2) ->
- let cmp = cmp_size a b in
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ let cmp = phi a1 a2 in
if cmp <> 0 then cmp else
- let cmp = phi a1 a2 in
- if cmp <> 0 then cmp else
- let cmp = phi b1 b2 in
- if cmp <> 0 then cmp else phi c1 c2
+ let cmp = phi b1 b2 in
+ if cmp <> 0 then cmp else phi c1 c2
| If _ , _ -> (-1)
| _ , If _ -> 1
| Acst(t1,v1) , Acst(t2,v2) ->
- let cmp = Tau.compare t1 t2 in
- if cmp<>0 then cmp else phi v1 v2
+ let cmp = Tau.compare t1 t2 in
+ if cmp<>0 then cmp else phi v1 v2
| Acst _ , _ -> (-1)
| _ , Acst _ -> 1
| Aget(a1,b1) , Aget(a2,b2) ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- let cmp = phi a1 a2 in
- if cmp <> 0 then cmp else phi b1 b2
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ let cmp = phi a1 a2 in
+ if cmp <> 0 then cmp else phi b1 b2
| Aget _ , _ -> (-1)
| _ , Aget _ -> 1
| Aset(a1,k1,v1) , Aset(a2,k2,v2) ->
- let cmp = cmp_size a b in
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ let cmp = phi a1 a2 in
if cmp <> 0 then cmp else
- let cmp = phi a1 a2 in
- if cmp <> 0 then cmp else
- let cmp = phi k1 k2 in
- if cmp <> 0 then cmp else phi v1 v2
+ let cmp = phi k1 k2 in
+ if cmp <> 0 then cmp else phi v1 v2
| Aset _ , _ -> (-1)
| _ , Aset _ -> 1
| Rget(r1,f1) , Rget(r2,f2) ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- let cmp = phi r1 r2 in
- if cmp <> 0 then cmp else Field.compare f1 f2
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ let cmp = phi r1 r2 in
+ if cmp <> 0 then cmp else Field.compare f1 f2
| Rget _ , _ -> (-1)
| _ , Rget _ -> 1
| Rdef fxs , Rdef gys ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- Hcons.compare_list (cmp_field phi) fxs gys
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ Hcons.compare_list (cmp_field phi) fxs gys
| Rdef _ , _ -> (-1)
| _ , Rdef _ -> 1
| Apply(a,xs) , Apply(b,ys) ->
- let cmp = cmp_size a b in
- if cmp <> 0 then cmp else
- Hcons.compare_list phi (a::xs) (b::ys)
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ Hcons.compare_list phi (a::xs) (b::ys)
| Apply _ , _ -> (-1)
| _ , Apply _ -> 1
| Bind(q1,t1,p1) , Bind(q2,t2,p2) ->
- let cmp = cmp_size a b in
+ let cmp = cmp_size a b in
+ if cmp <> 0 then cmp else
+ let cmp = cmp_bind q1 q2 in
if cmp <> 0 then cmp else
- let cmp = cmp_bind q1 q2 in
+ let cmp = phi p1 p2 in
if cmp <> 0 then cmp else
- let cmp = phi p1 p2 in
- if cmp <> 0 then cmp else
- Tau.compare t1 t2
+ Tau.compare t1 t2
let rec compare a b =
if a == b then 0 else
@@ -895,16 +895,16 @@ struct
match fxs with
| [] -> insert(Rdef fxs)
| fx::gys ->
- try
- let base (f,v) =
- match v.repr with
- | Rget(r,g) when Field.equal f g -> r
- | _ -> raise Exit
- in
- let r = base fx in
- List.iter (fun gy -> if base gy != r then raise Exit) gys ; r
- with Exit ->
- insert(Rdef (List.sort compare_field fxs))
+ try
+ let base (f,v) =
+ match v.repr with
+ | Rget(r,g) when Field.equal f g -> r
+ | _ -> raise Exit
+ in
+ let r = base fx in
+ List.iter (fun gy -> if base gy != r then raise Exit) gys ; r
+ with Exit ->
+ insert(Rdef (List.sort compare_field fxs))
[@@@ warning "-32"]
let insert _ = assert false (* [insert] should not be used afterwards *)
@@ -913,19 +913,19 @@ struct
let rec subterm e = function
[] -> e
| n :: l ->
- let children = match e.repr with
- | True | False | Kint _ | Kreal _ | Bvar _ | Fvar _ -> []
- | Times (n,e) -> [ e_zint n; e]
- | Add l | Mul l | And l | Or l | Fun (_,l) -> l
- | Div (e1,e2) | Mod (e1,e2) | Eq(e1,e2) | Neq(e1,e2)
- | Leq (e1,e2) | Lt(e1,e2) | Aget(e1,e2) -> [e1;e2]
- | Not e | Bind(_,_,e) | Acst(_,e) -> [e]
- | Imply(l,e) -> l @ [e]
- | If(e1,e2,e3) | Aset(e1,e2,e3) -> [e1;e2;e3]
- | Rget(e,_) -> [e]
- | Rdef fxs -> List.map snd fxs
- | Apply(e,es) -> e::es
- in subterm (List.nth children n) l
+ let children = match e.repr with
+ | True | False | Kint _ | Kreal _ | Bvar _ | Fvar _ -> []
+ | Times (n,e) -> [ e_zint n; e]
+ | Add l | Mul l | And l | Or l | Fun (_,l) -> l
+ | Div (e1,e2) | Mod (e1,e2) | Eq(e1,e2) | Neq(e1,e2)
+ | Leq (e1,e2) | Lt(e1,e2) | Aget(e1,e2) -> [e1;e2]
+ | Not e | Bind(_,_,e) | Acst(_,e) -> [e]
+ | Imply(l,e) -> l @ [e]
+ | If(e1,e2,e3) | Aset(e1,e2,e3) -> [e1;e2;e3]
+ | Rget(e,_) -> [e]
+ | Rdef fxs -> List.map snd fxs
+ | Apply(e,es) -> e::es
+ in subterm (List.nth children n) l
let is_primitive e =
match e.repr with
@@ -992,15 +992,15 @@ struct
let distribute f tau = function
| x::[] as xs ->
- begin
- match x.repr with
- | If(c,a,b) -> !extern_ite c (!extern_fun f [a] tau) (!extern_fun f [b] tau)
- | _ -> operation (FUN(f,xs,tau))
- end
+ begin
+ match x.repr with
+ | If(c,a,b) -> !extern_ite c (!extern_fun f [a] tau) (!extern_fun f [b] tau)
+ | _ -> operation (FUN(f,xs,tau))
+ end
| a::b::[] as xs ->
- distribute_if_over_operation false
- (fun f xs -> operation (FUN(f,xs,tau))) f xs
- (fun a b -> !extern_fun f [a;b] tau) a b
+ distribute_if_over_operation false
+ (fun f xs -> operation (FUN(f,xs,tau))) f xs
+ (fun a b -> !extern_fun f [a;b] tau) a b
| xs -> operation (FUN(f,xs,tau))
let c_builtin_fun f xs tau = distribute f tau xs
@@ -1072,10 +1072,10 @@ struct
let rec op_revassoc phi xs = function
| [] -> xs
| e::es ->
- match e.repr with
- | Fun(f,ts) when Fun.equal f phi ->
- op_revassoc phi (op_revassoc f xs ts) es
- | _ -> op_revassoc phi (e::xs) es
+ match e.repr with
+ | Fun(f,ts) when Fun.equal f phi ->
+ op_revassoc phi (op_revassoc f xs ts) es
+ | _ -> op_revassoc phi (e::xs) es
let rec op_idempotent = function
| [] -> []
@@ -1090,25 +1090,25 @@ struct
let rec walk xs ys =
match xs , ys with
| x::txs , y::tys ->
- let cmp = compare x y in
- if cmp < 0 then (rxs := x :: !rxs ; walk txs ys) else
- if cmp > 0 then (rys := y :: !rys ; walk xs tys) else
- ( modified := true ; walk txs tys )
+ let cmp = compare x y in
+ if cmp < 0 then (rxs := x :: !rxs ; walk txs ys) else
+ if cmp > 0 then (rys := y :: !rys ; walk xs tys) else
+ ( modified := true ; walk txs tys )
| _ ->
- begin
- rxs := List.rev_append !rxs xs ;
- rys := List.rev_append !rys ys ;
- end
+ begin
+ rxs := List.rev_append !rxs xs ;
+ rys := List.rev_append !rys ys ;
+ end
in walk xs ys ; !modified , !rxs , !rys
else
let rec simpl modified turn xs ys = match xs , ys with
| x::xs , y::ys when x==y -> simpl true turn xs ys
| _ ->
- let xs = List.rev xs in
- let ys = List.rev ys in
- if turn
- then simpl modified false xs ys
- else modified,xs,ys
+ let xs = List.rev xs in
+ let ys = List.rev ys in
+ if turn
+ then simpl modified false xs ys
+ else modified,xs,ys
in simpl false true xs ys
let rec element tau = function
@@ -1123,9 +1123,9 @@ struct
| E_true , True -> true
| E_false , False -> false
| E_fun (f,fl) , Fun(g,gl) ->
- Fun.equal f g &&
- List.length fl = List.length gl &&
- List.for_all2 is_element fl gl
+ Fun.equal f g &&
+ List.length fl = List.length gl &&
+ List.for_all2 is_element fl gl
| _ -> false
let isnot_element e x = not (is_element e x)
@@ -1225,10 +1225,10 @@ struct
| [] , _ -> fe (e_real c) (c_add ys)
| _ , [] -> fe (c_add xs) (e_real (Q.neg c))
| _ ->
- let s = Q.sign c in
- if s < 0 then fe (c_add xs) (c_add (e_real (Q.neg c) :: ys)) else
- if s > 0 then fe (c_add (e_real c :: xs)) (c_add ys) else
- fe (c_add xs) (c_add ys)
+ let s = Q.sign c in
+ if s < 0 then fe (c_add xs) (c_add (e_real (Q.neg c) :: ys)) else
+ if s > 0 then fe (c_add (e_real c :: xs)) (c_add ys) else
+ fe (c_add xs) (c_add ys)
let i_affine_rel fc fe c xs ys =
match xs , ys with
@@ -1236,13 +1236,13 @@ struct
| [] , _ -> fe (e_zint c) (c_add ys) (* c+0 R ys <-> c R ys *)
| _ , [] -> fe (c_add xs) (e_zint (Z.neg c)) (* c+xs R 0 <-> xs R -c *)
| _ ->
- match sign c with
- (* 0+xs R ys <-> xs R ys *)
- | Null -> fe (c_add xs) (c_add ys)
- (* c+xs R ys <-> xs R (-c+ys) *)
- | Negative -> fe (c_add xs) (c_add (e_zint (Z.neg c) :: ys))
- (* c+xs R ys <-> (c+xs) R ys *)
- | Positive -> fe (c_add (e_zint c :: xs)) (c_add ys)
+ match sign c with
+ (* 0+xs R ys <-> xs R ys *)
+ | Null -> fe (c_add xs) (c_add ys)
+ (* c+xs R ys <-> xs R (-c+ys) *)
+ | Negative -> fe (c_add xs) (c_add (e_zint (Z.neg c) :: ys))
+ (* c+xs R ys <-> (c+xs) R ys *)
+ | Positive -> fe (c_add (e_zint c :: xs)) (c_add ys)
let i_affine_leq c xs ys =
if Z.equal c Z.one
@@ -1262,23 +1262,23 @@ struct
let i_form = function
| { repr = Kint c } -> c,[]
| { repr = Add es } ->
- ( match es with
- | x::xs ->
- ( match x with
- | { repr = Kint c } -> c , xs
- | _ -> Z.zero , es )
- | [] -> Z.zero,[] )
+ ( match es with
+ | x::xs ->
+ ( match x with
+ | { repr = Kint c } -> c , xs
+ | _ -> Z.zero , es )
+ | [] -> Z.zero,[] )
| e -> Z.zero,[e]
let i_ratio = function
| [{ repr=Div(a,b) }] ->
- (match b.repr with
- | Kint k ->
- (match sign k with
- | Positive -> POS(i_form a,k)
- | Negative -> NEG(i_form a,Z.neg k)
- | Null -> NONE)
- | _ -> NONE)
+ (match b.repr with
+ | Kint k ->
+ (match sign k with
+ | Positive -> POS(i_form a,k)
+ | Negative -> NEG(i_form a,Z.neg k)
+ | Null -> NONE)
+ | _ -> NONE)
| _ -> NONE
let i_opp xs = List.map (times Z.minus_one) xs
@@ -1328,40 +1328,40 @@ struct
and i_affine_ratio_leq c xs ys =
try match i_ratio xs , i_ratio ys with
| POS(a,k) , NONE ->
- (* c + a/k <= ys <==> a/k <= -c+ys *)
- i_ratio_max a k (Z.neg c,ys)
+ (* c + a/k <= ys <==> a/k <= -c+ys *)
+ i_ratio_max a k (Z.neg c,ys)
| NEG(a,k) , NONE ->
- (* c - a/k <= ys <==> c-ys <= a/k *)
- i_ratio_min (c,i_opp ys) a k
+ (* c - a/k <= ys <==> c-ys <= a/k *)
+ i_ratio_min (c,i_opp ys) a k
| NONE , POS(a,k) ->
- (* c + xs <= a/k *)
- i_ratio_min (c,xs) a k
+ (* c + xs <= a/k *)
+ i_ratio_min (c,xs) a k
| NONE , NEG(a,k) ->
- (* c + xs <= -a/k <==> a/k <= -c-xs *)
- i_ratio_max a k (Z.neg c,i_opp xs)
+ (* c + xs <= -a/k <==> a/k <= -c-xs *)
+ i_ratio_max a k (Z.neg c,i_opp xs)
| _ ->
- (* c+xs <= ys *)
- i_affine_leq c xs ys
+ (* c+xs <= ys *)
+ i_affine_leq c xs ys
with Not_found ->
i_affine_leq c xs ys
and i_affine_ratio_lt c xs ys =
try match i_ratio xs , i_ratio ys with
| POS(a,k) , NONE ->
- (* c + a/k < ys <==> a/k <= -c-1+ys *)
- i_ratio_max a k (Z.pred (Z.neg c),ys)
+ (* c + a/k < ys <==> a/k <= -c-1+ys *)
+ i_ratio_max a k (Z.pred (Z.neg c),ys)
| NEG(a,k) , NONE ->
- (* c - a/k < ys <==> c+1-ys <= a/k *)
- i_ratio_min (Z.succ c,i_opp ys) a k
+ (* c - a/k < ys <==> c+1-ys <= a/k *)
+ i_ratio_min (Z.succ c,i_opp ys) a k
| NONE , POS(a,k) ->
- (* c + xs < a/k <==> c+1+xs <= a/k *)
- i_ratio_min (Z.succ c,xs) a k
+ (* c + xs < a/k <==> c+1+xs <= a/k *)
+ i_ratio_min (Z.succ c,xs) a k
| NONE , NEG(a,k) ->
- (* c + xs < -a/k <==> a/k <= -c-1-xs *)
- i_ratio_max a k (Z.pred (Z.neg c),i_opp xs)
+ (* c + xs < -a/k <==> a/k <= -c-1-xs *)
+ i_ratio_max a k (Z.pred (Z.neg c),i_opp xs)
| _ ->
- (* c+xs < ys *)
- i_affine_lt c xs ys
+ (* c+xs < ys *)
+ i_affine_lt c xs ys
with Not_found ->
i_affine_lt c xs ys
@@ -1425,14 +1425,14 @@ struct
(* monoms sorted by terms *)
let rec fold_affine f a = function
| (n1,t1)::(n2,t2)::kts when t1 == t2 ->
- fold_affine f a ((Z.add n1 n2,t1)::kts)
+ fold_affine f a ((Z.add n1 n2,t1)::kts)
| (k,t)::kts ->
- begin match t.repr , kts with
- | Kreal z , ( k' , { repr = Kreal z' } ) :: kts' ->
- let q = Q.add (q_times k z) (q_times k' z') in
- fold_affine f a ((Z.one,e_real q) :: kts')
- | _ -> fold_affine f (f a k t) kts
- end
+ begin match t.repr , kts with
+ | Kreal z , ( k' , { repr = Kreal z' } ) :: kts' ->
+ let q = Q.add (q_times k z) (q_times k' z') in
+ fold_affine f a ((Z.one,e_real q) :: kts')
+ | _ -> fold_affine f (f a k t) kts
+ end
| [] -> a
let affine a : term Logic.affine =
@@ -1466,24 +1466,24 @@ struct
let rec coef_monoms c = function
| [] -> c , Z.one
| (n,e)::w ->
- if e == e_one then coef_monoms (Z.add c n) w else
- let rec coef_gcd c p = function
- | [] -> c , p
- | (n,e)::w ->
- if e == e_one
- then coef_gcd (Z.add c n) p w
- else coef_gcd c Z.(gcd p (abs n)) w
- in coef_gcd c (Z.abs n) w
+ if e == e_one then coef_monoms (Z.add c n) w else
+ let rec coef_gcd c p = function
+ | [] -> c , p
+ | (n,e)::w ->
+ if e == e_one
+ then coef_gcd (Z.add c n) p w
+ else coef_gcd c Z.(gcd p (abs n)) w
+ in coef_gcd c (Z.abs n) w
let rec partition_monoms phi xs ys = function
| [] -> xs,ys
| (k,t) :: kts ->
- if t == e_one
- then partition_monoms phi xs ys kts
- else
- if Z.leq Z.zero k
- then partition_monoms phi (phi xs k t) ys kts
- else partition_monoms phi xs (phi ys (Z.neg k) t) kts
+ if t == e_one
+ then partition_monoms phi xs ys kts
+ else
+ if Z.leq Z.zero k
+ then partition_monoms phi (phi xs k t) ys kts
+ else partition_monoms phi xs (phi ys (Z.neg k) t) kts
let collect_monoms xs k t = if Z.(equal k zero) then xs else (k,t)::xs
@@ -1517,10 +1517,10 @@ struct
| EQ -> e_false (* CONG-EQ *)
| NEQ -> e_true (* CONG-NEQ *)
| LT | LEQ ->
- let xs,ys = partition_monoms (fold_coef g) [] [] kts in
- (* CONG-LEQ|LT-POS|NEQ *)
- let cmp = if Z.(lt zero r) then LT else LEQ in
- affine_cmp cmp k xs ys
+ let xs,ys = partition_monoms (fold_coef g) [] [] kts in
+ (* CONG-LEQ|LT-POS|NEQ *)
+ let cmp = if Z.(lt zero r) then LT else LEQ in
+ affine_cmp cmp k xs ys
else rel x y
(* --- Multiplications --- *)
@@ -1528,10 +1528,10 @@ struct
let rec mul_unfold acc = function
| [] -> acc
| t::others ->
- match t.repr with
- | Times(z,t) -> mul_unfold (e_zint z :: acc) (t::others)
- | Mul ts -> mul_unfold (mul_unfold acc ts) others
- | _ -> mul_unfold (t::acc) others
+ match t.repr with
+ | Times(z,t) -> mul_unfold (e_zint z :: acc) (t::others)
+ | Mul ts -> mul_unfold (mul_unfold acc ts) others
+ | _ -> mul_unfold (t::acc) others
let multiplication ts = (* ts normalized *)
let ts = mul_unfold [] ts in
@@ -1561,27 +1561,27 @@ struct
| _ , Kint z when Z.equal z Z.one -> a
| _ , Kint z when Z.equal z Z.minus_one -> times Z.minus_one a
| Times(k,e) , Kint k' when not (Z.equal k' Z.zero) ->
- let q,r = Z.div_rem k k' in
- if Z.equal r Z.zero
- then e_times q e
- else c_div a b
+ let q,r = Z.div_rem k k' in
+ if Z.equal r Z.zero
+ then e_times q e
+ else c_div a b
| Kint k , Kint k' when not (Z.equal k' Z.zero) -> e_zint (Z.div k k')
| Kreal r , Kint a when not (Z.equal a Z.zero) ->
- e_real Q.(make r.num (Z.mul a r.den))
+ e_real Q.(make r.num (Z.mul a r.den))
| Kint a , Kreal b when not (Q.equal b Q.zero) ->
- e_real Q.(make (Z.mul a b.den) b.num)
+ e_real Q.(make (Z.mul a b.den) b.num)
| Kreal a , Kreal b when not (Q.equal b Q.zero) ->
- e_real (Q.div a b)
+ e_real (Q.div a b)
| _ -> c_div a b
let e_mod a b =
match a.repr , b.repr with
| _ , Kint z when Z.equal z Z.one -> e_zero
| Times(k,e) , Kint k' when not (Z.equal k' Z.zero) ->
- let r = Z.rem k k' in
- if Z.equal r Z.zero
- then e_zero
- else c_mod (e_times r e) b
+ let r = Z.rem k k' in
+ if Z.equal r Z.zero
+ then e_zero
+ else c_mod (e_times r e) b
| Kint k , Kint k' when not (Z.equal k' Z.zero) -> e_zint (Z.rem k k')
| _ -> c_mod a b
@@ -1615,21 +1615,21 @@ struct
match xs with
| [] -> acc
| x::others ->
- match x.repr with
- | False -> raise Absorbant
- | True -> fold_and acc others
- | And xs -> fold_and (fold_and acc xs) others
- | _ -> fold_and (x::acc) others
+ match x.repr with
+ | False -> raise Absorbant
+ | True -> fold_and acc others
+ | And xs -> fold_and (fold_and acc xs) others
+ | _ -> fold_and (x::acc) others
let rec fold_or acc xs =
match xs with
| [] -> acc
| x::others ->
- match x.repr with
- | True -> raise Absorbant
- | False -> fold_or acc others
- | Or xs -> fold_or (fold_or acc xs) others
- | _ -> fold_or (x::acc) others
+ match x.repr with
+ | True -> raise Absorbant
+ | False -> fold_or acc others
+ | Or xs -> fold_or (fold_or acc xs) others
+ | _ -> fold_or (x::acc) others
let conjunction ts =
try
@@ -1656,21 +1656,21 @@ struct
match hs with
| [] -> ts
| h :: hws ->
- match w.polarity with
- | CONJ -> aux w ~absorb:(e_not h) ~filter:h hws ts
- | DISJ -> aux w ~absorb:h ~filter:(e_not h) hws ts
+ match w.polarity with
+ | CONJ -> aux w ~absorb:(e_not h) ~filter:h hws ts
+ | DISJ -> aux w ~absorb:h ~filter:(e_not h) hws ts
and aux w ~absorb ~filter hws ts =
match ts with
| [] -> ts
| t :: tws ->
- if absorb == t then raise Absorbant ;
- let cmp = compare filter t in
- if cmp < 0
- then gen w hws ts else
- if cmp > 0
- then t :: aux (mark w) ~absorb ~filter hws tws
- else gen (mark w) hws tws
+ if absorb == t then raise Absorbant ;
+ let cmp = compare filter t in
+ if cmp < 0
+ then gen w hws ts else
+ if cmp > 0
+ then t :: aux (mark w) ~absorb ~filter hws tws
+ else gen (mark w) hws tws
let filter polarity hs ts =
let w = { modif = false ; polarity } in
@@ -1709,14 +1709,14 @@ struct
match consequence_and hs [b0] with
| [] -> e_true (* [And hs] implies [b0] *)
| _ -> try
- match consequence_and hs0 hs with
- | [] -> b (* [And hs0] implies [And hs] *)
- | hs ->
- match b0.repr with
- | And bs -> implication_and hs0 hs b0 bs
- | Or bs -> implication_or hs0 hs b0 bs
- | _ -> c_imply (merge hs0 hs) b0
- with Absorbant -> e_true (* [False = And (hs@hs0)] *)
+ match consequence_and hs0 hs with
+ | [] -> b (* [And hs0] implies [And hs] *)
+ | hs ->
+ match b0.repr with
+ | And bs -> implication_and hs0 hs b0 bs
+ | Or bs -> implication_or hs0 hs b0 bs
+ | _ -> c_imply (merge hs0 hs) b0
+ with Absorbant -> e_true (* [False = And (hs@hs0)] *)
with Absorbant -> (* [And hs] implies [Not b0] *)
try implication_false (merge hs hs0)
with Absorbant -> e_true (* [False = And (hs@hs0)] *)
@@ -1827,27 +1827,27 @@ struct
| Kint z , Kint z' -> if Z.equal z z' then e_true else e_false
| Kreal z , Kreal z' -> if Q.equal z z' then e_true else e_false
| Kint a , Kreal r | Kreal r , Kint a ->
- if Q.equal r (Q.of_bigint a) then e_true else e_false
+ if Q.equal r (Q.of_bigint a) then e_true else e_false
| True , _ -> y
| _ , True -> x
| False , _ -> e_not y
| _ , False -> e_not x
| Fun(f,xs) , Fun(g,ys) ->
- begin
- match structural f g with
- | S_diff -> e_false
- | S_injection -> e_all2 e_eq xs ys
- | S_functions -> c_builtin_eq x y
- | S_invertible -> eq_invertible x y f xs ys
- | S_invertible_left -> eq_invertible x y f xs [y]
- | S_invertible_right -> eq_invertible x y g [x] ys
- | S_invertible_both -> eq_invertible_both x y f g xs ys
- end
+ begin
+ match structural f g with
+ | S_diff -> e_false
+ | S_injection -> e_all2 e_eq xs ys
+ | S_functions -> c_builtin_eq x y
+ | S_invertible -> eq_invertible x y f xs ys
+ | S_invertible_left -> eq_invertible x y f xs [y]
+ | S_invertible_right -> eq_invertible x y g [x] ys
+ | S_invertible_both -> eq_invertible_both x y f g xs ys
+ end
| Rdef fxs , Rdef gys ->
- begin
- try e_all2 eq_field fxs gys
- with Exit -> e_false
- end
+ begin
+ try e_all2 eq_field fxs gys
+ with Exit -> e_false
+ end
| Acst(_,a) , Acst(_,b) -> e_eq a b
| Acst(_,v0) , Aset(m,_,v) -> conjunction [e_eq v v0 ; e_eq x m]
@@ -1892,27 +1892,27 @@ struct
| Kint z , Kint z' -> if Z.equal z z' then e_false else e_true
| Kreal z , Kreal z' -> if Q.equal z z' then e_false else e_true
| Kreal r , Kint a | Kint a , Kreal r ->
- if Q.equal r (Q.of_bigint a) then e_false else e_true
+ if Q.equal r (Q.of_bigint a) then e_false else e_true
| True , _ -> e_not y
| _ , True -> e_not x
| False , _ -> y
| _ , False -> x
| Fun(f,xs) , Fun(g,ys) ->
- begin
- match structural f g with
- | S_diff -> e_true
- | S_injection -> e_any2 e_neq xs ys
- | S_functions -> c_builtin_neq x y
- | S_invertible -> neq_invertible x y f xs ys
- | S_invertible_left -> neq_invertible x y f xs [y]
- | S_invertible_right -> neq_invertible x y g [x] ys
- | S_invertible_both -> neq_invertible_both x y f g xs ys
- end
+ begin
+ match structural f g with
+ | S_diff -> e_true
+ | S_injection -> e_any2 e_neq xs ys
+ | S_functions -> c_builtin_neq x y
+ | S_invertible -> neq_invertible x y f xs ys
+ | S_invertible_left -> neq_invertible x y f xs [y]
+ | S_invertible_right -> neq_invertible x y g [x] ys
+ | S_invertible_both -> neq_invertible_both x y f g xs ys
+ end
| Rdef fxs , Rdef gys ->
- begin
- try e_any2 neq_field fxs gys
- with Exit -> e_true
- end
+ begin
+ try e_any2 neq_field fxs gys
+ with Exit -> e_true
+ end
| Acst(_,a) , Acst(_,b) -> e_neq a b
| Acst(_,v0) , Aset(m,_,v) -> disjunction [e_neq v v0 ; e_neq x m]
@@ -1971,27 +1971,27 @@ struct
match b.repr with
| And bs -> implication_and [] hs b bs
| _ -> try
- match consequence_and hs [b] with
- | [] -> e_true (* [And hs] implies [b] *)
- | _ ->
- match b.repr with
- | Or bs -> implication_or [] hs b bs
- | Imply(hs0,b0) -> implication_imply hs b hs0 b0
- | _ -> c_imply hs b
- with Absorbant -> implication_false hs (* [And hs] implies [Not b] *)
+ match consequence_and hs [b] with
+ | [] -> e_true (* [And hs] implies [b] *)
+ | _ ->
+ match b.repr with
+ | Or bs -> implication_or [] hs b bs
+ | Imply(hs0,b0) -> implication_imply hs b hs0 b0
+ | _ -> c_imply hs b
+ with Absorbant -> implication_false hs (* [And hs] implies [Not b] *)
let e_imply hs p =
match p.repr with
| True -> e_true
| _ ->
- try
- let hs = fold_and [] hs in
- let hs = List.sort_uniq compare_raising_absorbant hs in
- match hs with
- | [] -> p
- | [a] -> imply1 a p
- | _ -> imply2 hs p
- with Absorbant -> e_true
+ try
+ let hs = fold_and [] hs in
+ let hs = List.sort_uniq compare_raising_absorbant hs in
+ match hs with
+ | [] -> p
+ | [a] -> imply1 a p
+ | _ -> imply2 hs p
+ with Absorbant -> e_true
let () = cached_not := function
| And xs -> e_or (List.map e_not xs)
@@ -2004,17 +2004,17 @@ struct
| True -> a
| False -> b
| _ ->
- if a == b then a else
- match a.repr , b.repr with
- | True , _ -> disjunction [e;b]
- | _ , False -> conjunction [e;a]
- | False , _ -> conjunction [e_not e;b]
- | _ , True -> disjunction [e_not e;a]
- | _ ->
- match e.repr with
- | Not e0 -> c_if e0 b a
- | Neq(u,v) -> c_if (e_eq u v) b a
- | _ -> c_if e a b
+ if a == b then a else
+ match a.repr , b.repr with
+ | True , _ -> disjunction [e;b]
+ | _ , False -> conjunction [e;a]
+ | False , _ -> conjunction [e_not e;b]
+ | _ , True -> disjunction [e_not e;a]
+ | _ ->
+ match e.repr with
+ | Not e0 -> c_if e0 b a
+ | Neq(u,v) -> c_if (e_eq u v) b a
+ | _ -> c_if e a b
let () = extern_ite := e_if
let e_bool = function true -> e_true | false -> e_false
@@ -2038,33 +2038,33 @@ struct
match m.repr with
| Acst(_,v) -> v
| Aset(m0,k0,v0) ->
- begin
- match are_equal k k0 with
- | Yes -> v0
- | No -> e_get m0 k
- | Maybe -> c_get m k
- end
+ begin
+ match are_equal k k0 with
+ | Yes -> v0
+ | No -> e_get m0 k
+ | Maybe -> c_get m k
+ end
| Fun (g,xs) ->
- begin
- try (BUILTIN.find g !state.builtins_get) xs m.tau k
- with Not_found -> c_get m k
- end
+ begin
+ try (BUILTIN.find g !state.builtins_get) xs m.tau k
+ with Not_found -> c_get m k
+ end
| _ -> c_get m k
let rec e_set m k v =
match m.repr with
| Acst(_,v0) ->
- begin
- match are_equal v v0 with
- | Yes -> m
- | No | Maybe -> c_set m k v
- end
+ begin
+ match are_equal v v0 with
+ | Yes -> m
+ | No | Maybe -> c_set m k v
+ end
| Aset(m0,k0,_) ->
- begin
- match are_equal k k0 with
- | Yes -> e_set m0 k0 v
- | No | Maybe -> c_set m k v
- end
+ begin
+ match are_equal k k0 with
+ | Yes -> e_set m0 k0 v
+ | No | Maybe -> c_set m k v
+ end
| _ -> c_set m k v
let e_const (k:tau) v = c_const k v
@@ -2302,11 +2302,11 @@ struct
match e.repr with
| Bvar(k,_) -> Intmap.find k alpha
| Bind _ ->
- (* Not in cache *)
- bind sigma alpha [] e
+ (* Not in cache *)
+ bind sigma alpha [] e
| Apply(e,es) ->
- let phi = incache mu sigma alpha in
- apply sigma Intmap.empty (phi e) (List.map phi es)
+ let phi = incache mu sigma alpha in
+ apply sigma Intmap.empty (phi e) (List.map phi es)
| _ -> rebuild (incache mu sigma alpha) e
in
(* Only put closed terms in cache *)
@@ -2316,35 +2316,35 @@ struct
and bind sigma alpha qs e =
match e.repr with
| Bind(q,t,a) ->
- let k = Bvars.order a.bind in
- let x = Subst.fresh sigma t in
- let alpha = Intmap.add k (e_var x) alpha in
- let qs = (q,x) :: qs in
- bind sigma alpha qs a
+ let k = Bvars.order a.bind in
+ let x = Subst.fresh sigma t in
+ let alpha = Intmap.add k (e_var x) alpha in
+ let qs = (q,x) :: qs in
+ bind sigma alpha qs a
| _ ->
- (* HERE:
- This final binding of variables could be parallelized
- if Bvars is precise enough *)
- List.fold_left
- (fun e (q,x) ->
- if Vars.mem x e.vars then
- let t = tau_of_var x in
- (* HERE:
- possible to insert a recursive call to let-intro
- it will use a new instance of e_subst_var that
- will work on a different sigma *)
- c_bind q t (lc_close x e)
- else e
- ) (subst sigma alpha e) qs
+ (* HERE:
+ This final binding of variables could be parallelized
+ if Bvars is precise enough *)
+ List.fold_left
+ (fun e (q,x) ->
+ if Vars.mem x e.vars then
+ let t = tau_of_var x in
+ (* HERE:
+ possible to insert a recursive call to let-intro
+ it will use a new instance of e_subst_var that
+ will work on a different sigma *)
+ c_bind q t (lc_close x e)
+ else e
+ ) (subst sigma alpha e) qs
and apply sigma beta f vs =
match f.repr, vs with
| Bind(_,_,g) , v::vs ->
- let k = Bvars.order g.bind in
- apply sigma (Intmap.add k v beta) g vs
+ let k = Bvars.order g.bind in
+ apply sigma (Intmap.add k v beta) g vs
| _ ->
- let f' = if Intmap.is_empty beta then f else subst sigma beta f in
- c_apply f' vs
+ let f' = if Intmap.is_empty beta then f else subst sigma beta f in
+ c_apply f' vs
let e_subst sigma e =
Subst.validate "Qed.e_subst (target)" e ;
@@ -2439,25 +2439,25 @@ struct
match a.repr with
| Fvar w -> assert (Var.equal x w); found_term b
| Add e ->
- let is_var t = match t.repr with|Fvar v -> Var.equal x v|_->false in
- let rec add_case es = match es with
- | [] -> assert false (* because [x] is in [e] *)
- | t::ts ->
- if not (Vars.mem x t.vars) then add_case ts else
- if not (is_var t) then false (* [x] is too far in [t] *) else
- if not (List.for_all (fun t -> not (Vars.mem x t.vars)) ts)
- then false (* [x] is also in [ts] *)
- else begin (* var [x] is only in [t] that is also exactly [x] *)
- let rec fold_until_es acc ys = match ys with
- | [] -> assert false
- | _ when ys==es -> acc (* first terms until [es] *)
- | y::ys -> fold_until_es (y::acc) ys
- in
- let extracted = List.rev_append (fold_until_es [] e) ts in
- let reverse = e_sum (b::(List.map e_opp extracted)) in
- found_term reverse
- end
- in add_case e
+ let is_var t = match t.repr with|Fvar v -> Var.equal x v|_->false in
+ let rec add_case es = match es with
+ | [] -> assert false (* because [x] is in [e] *)
+ | t::ts ->
+ if not (Vars.mem x t.vars) then add_case ts else
+ if not (is_var t) then false (* [x] is too far in [t] *) else
+ if not (List.for_all (fun t -> not (Vars.mem x t.vars)) ts)
+ then false (* [x] is also in [ts] *)
+ else begin (* var [x] is only in [t] that is also exactly [x] *)
+ let rec fold_until_es acc ys = match ys with
+ | [] -> assert false
+ | _ when ys==es -> acc (* first terms until [es] *)
+ | y::ys -> fold_until_es (y::acc) ys
+ in
+ let extracted = List.rev_append (fold_until_es [] e) ts in
+ let reverse = e_sum (b::(List.map e_opp extracted)) in
+ found_term reverse
+ end
+ in add_case e
| _ -> false
in
let is_var_ok u v =
@@ -2479,32 +2479,32 @@ struct
match q with
| Lambda -> None
| Forall ->
- let rec forall_case e = match e.repr with
- | Or b -> List.exists is_neq b
- | Imply (hs,b) -> List.exists is_eq hs || is_neq b
- | Bind(Forall,_,b) -> forall_case b (* skip intermediate forall *)
- | _ -> is_neq e
- in ignore(forall_case a); !res
+ let rec forall_case e = match e.repr with
+ | Or b -> List.exists is_neq b
+ | Imply (hs,b) -> List.exists is_eq hs || is_neq b
+ | Bind(Forall,_,b) -> forall_case b (* skip intermediate forall *)
+ | _ -> is_neq e
+ in ignore(forall_case a); !res
| Exists ->
- let rec exists_case e = match e.repr with
- | And b -> List.exists is_eq b
- | Bind(Exists,_,b) -> exists_case b (* skip intermediate exists *)
- | _ -> is_eq e
- in ignore(exists_case a); !res
+ let rec exists_case e = match e.repr with
+ | And b -> List.exists is_eq b
+ | Bind(Exists,_,b) -> exists_case b (* skip intermediate exists *)
+ | _ -> is_eq e
+ in ignore(exists_case a); !res
let e_open ~pool ?(forall=true) ?(exists=true) ?(lambda=true) a =
match a.repr with
| Bind _ ->
- let filter = function
- | Forall -> forall
- | Exists -> exists
- | Lambda -> lambda in
- let rec walk qs a = match a.repr with
- | Bind(q,t,b) when filter q ->
- let x = fresh pool t in
- walk ((q,x)::qs) (lc_open x b)
- | _ -> qs , a
- in walk [] a
+ let filter = function
+ | Forall -> forall
+ | Exists -> exists
+ | Lambda -> lambda in
+ let rec walk qs a = match a.repr with
+ | Bind(q,t,b) when filter q ->
+ let x = fresh pool t in
+ walk ((q,x)::qs) (lc_open x b)
+ | _ -> qs , a
+ in walk [] a
| _ -> [],a
let e_unbind x (lc : lc_term) : term =
@@ -2567,21 +2567,21 @@ struct
match e.repr with
| Apply(a,xs) -> e_apply (f a) (List.map f xs)
| Bind _ ->
- let pool = match pool with
- | None -> raise (Invalid_argument "Qed.ogic.Term.f_map")
- | Some pool -> pool in
- let ctx,a = e_open ~pool ?forall ?exists ?lambda e in
- e_close ctx (rebuild f a)
+ let pool = match pool with
+ | None -> raise (Invalid_argument "Qed.ogic.Term.f_map")
+ | Some pool -> pool in
+ let ctx,a = e_open ~pool ?forall ?exists ?lambda e in
+ e_close ctx (rebuild f a)
| _ -> rebuild f e
let f_iter ?pool ?forall ?exists ?lambda f e =
match e.repr with
| Bind _ ->
- let pool = match pool with
- | None -> raise (Invalid_argument "Qed.ogic.Term.f_iter")
- | Some pool -> pool in
- let _,a = e_open ~pool ?forall ?exists ?lambda e in
- f a
+ let pool = match pool with
+ | None -> raise (Invalid_argument "Qed.ogic.Term.f_iter")
+ | Some pool -> pool in
+ let _,a = e_open ~pool ?forall ?exists ?lambda e in
+ f a
| _ -> repr_iter f e.repr
let e_fun ?result f xs = e_fungen f xs result
@@ -2606,13 +2606,13 @@ struct
| i::l -> begin
match e.repr with
| True | False | Kint _ | Kreal _ | Fvar _ | Bvar _ ->
- bad_position ()
+ bad_position ()
| Times (_,e) when i = 0 && l = [] ->
- begin
- match child.repr with
- Kint n -> times n e
- | _ -> e_mul child e
- end
+ begin
+ match child.repr with
+ Kint n -> times n e
+ | _ -> e_mul child e
+ end
| Times(n,e) when i = 1 -> times n (aux e l)
| Times _ -> bad_position ()
| Add ops -> e_sum (change_in_list ops i l)
@@ -2645,10 +2645,10 @@ struct
| Not e when i = 0 -> e_not (aux e l)
| Not _ -> bad_position ()
| Imply(ops,e) ->
- let nb = List.length ops in
- if i < nb then e_imply (change_in_list ops i l) e
- else if i = nb then e_imply ops (aux e l)
- else bad_position ()
+ let nb = List.length ops in
+ if i < nb then e_imply (change_in_list ops i l) e
+ else if i = nb then e_imply ops (aux e l)
+ else bad_position ()
| If(e1,e2,e3) when i = 0 -> e_if (aux e1 l) e2 e3
| If(e1,e2,e3) when i = 1 -> e_if e1 (aux e2 l) e3
| If(e1,e2,e3) when i = 2 -> e_if e1 e2 (aux e3 l)
@@ -2658,14 +2658,14 @@ struct
| Aset(e1,e2,e3) when i = 2 -> e_set e1 e2 (aux e3 l)
| Aset _ -> bad_position ()
| Rdef _ | Rget _ ->
- failwith "change in place for records not yet implemented"
+ failwith "change in place for records not yet implemented"
| Fun (f,ops) -> e_fungen f (change_in_list ops i l) e.tau
| Bind(q,x,t) when i = 0 -> c_bind q x (aux t l)
| Bind _ -> bad_position ()
| Apply(f,args) when i = 0 ->
- e_apply (aux f l) args
+ e_apply (aux f l) args
| Apply (f,args) ->
- e_apply f (change_in_list args i l)
+ e_apply f (change_in_list args i l)
end
in aux e pos
@@ -2682,29 +2682,29 @@ struct
(fun (f,v) ->
match v.repr with
| Rget(base,g) when Field.equal f g ->
- let count =
- try succ (Tmap.find base !bases)
- with Not_found -> 1
- in
- bases := Tmap.add base count !bases ;
- ( match !best with
- | Some(_,c) when c < count -> ()
- | _ -> best := Some(base,count) )
+ let count =
+ try succ (Tmap.find base !bases)
+ with Not_found -> 1
+ in
+ bases := Tmap.add base count !bases ;
+ ( match !best with
+ | Some(_,c) when c < count -> ()
+ | _ -> best := Some(base,count) )
| _ -> ()
) fvs ;
match !best with
| None -> None
| Some(base,_) ->
- let fothers = List.filter
- (fun (f,v) ->
- match v.repr with
- | Rget( other , g ) ->
- other != base || not (Field.equal f g)
- | _ -> true)
- fvs
- in
- if fothers = [] then None (* suspiscious *)
- else Some ( base , fothers )
+ let fothers = List.filter
+ (fun (f,v) ->
+ match v.repr with
+ | Rget( other , g ) ->
+ other != base || not (Field.equal f g)
+ | _ -> true)
+ fvs
+ in
+ if fothers = [] then None (* suspiscious *)
+ else Some ( base , fothers )
(* ------------------------------------------------------------------------ *)
(* --- Symbol --- *)
@@ -2789,20 +2789,20 @@ struct
begin
match get_mark m e with
| Unmarked ->
- if m.marked e then
- set_mark m e Marked
- else
- begin
- set_mark m e FirstMark ;
- m.subterms (walk m r) e ;
- end
- | FirstMark ->
- if m.shareable e && lc_closed_at r e
- then m.shared <- Tset.add e m.shared
- else m.subterms (walk m r) e ;
+ if m.marked e then
set_mark m e Marked
+ else
+ begin
+ set_mark m e FirstMark ;
+ m.subterms (walk m r) e ;
+ end
+ | FirstMark ->
+ if m.shareable e && lc_closed_at r e
+ then m.shared <- Tset.add e m.shared
+ else m.subterms (walk m r) e ;
+ set_mark m e Marked
| Marked ->
- ()
+ ()
end
let mark m e =
@@ -2876,7 +2876,7 @@ struct
| Int , Int -> Int
| (Int|Real) , (Int|Real) -> Real
| _ ->
- if Tau.equal a b then a else raise Not_found
+ if Tau.equal a b then a else raise Not_found
let rec merge_list t f = function
| [] -> t
@@ -2892,43 +2892,43 @@ struct
match e.tau with
| Some tau -> tau
| None ->
- match e.sort with
- | Sint -> Int
- | Sreal -> Real
- | Sbool -> Bool
- | Sprop -> Prop
- | Sdata | Sarray _ ->
- match e.repr with
- | Bvar (_,ty) -> ty
- | Fvar x -> tau_of_var x
- | Acst(t,v) -> Array(t,typecheck env v)
- | Aset(m,k,v) ->
- (try typecheck env m
- with Not_found ->
- Array(typecheck env k,typecheck env v))
- | Fun(f,es) ->
- (try tau_of_sort (Fun.sort f)
- with Not_found -> env.call f (List.map (typeof env) es))
- | Aget(m,_) ->
- (try match typecheck env m with
- | Array(_,v) -> v
- | _ -> raise Not_found
- with Not_found -> tau_of_arraysort m.sort)
- | Rdef [] -> raise Not_found
- | Rdef ((f,_)::_) -> env.record f
- | Rget (_,f) ->
- (try tau_of_sort (Field.sort f)
- with Not_found -> env.field f)
- | True | False -> Bool
- | Kint _ -> Int
- | Kreal _ -> Real
- | Times(_,e) -> typecheck env e
- | Add es | Mul es -> merge_list Int (typecheck env) es
- | Div (a,b) | Mod (a,b) | If(_,a,b) ->
- tau_merge (typecheck env a) (typecheck env b)
- | Eq _ | Neq _ | Leq _ | Lt _ | And _ | Or _ | Not _ | Imply _ -> Bool
- | Bind((Forall|Exists),_,_) -> Prop
- | Apply _ | Bind(Lambda,_,_) -> raise Not_found
+ match e.sort with
+ | Sint -> Int
+ | Sreal -> Real
+ | Sbool -> Bool
+ | Sprop -> Prop
+ | Sdata | Sarray _ ->
+ match e.repr with
+ | Bvar (_,ty) -> ty
+ | Fvar x -> tau_of_var x
+ | Acst(t,v) -> Array(t,typecheck env v)
+ | Aset(m,k,v) ->
+ (try typecheck env m
+ with Not_found ->
+ Array(typecheck env k,typecheck env v))
+ | Fun(f,es) ->
+ (try tau_of_sort (Fun.sort f)
+ with Not_found -> env.call f (List.map (typeof env) es))
+ | Aget(m,_) ->
+ (try match typecheck env m with
+ | Array(_,v) -> v
+ | _ -> raise Not_found
+ with Not_found -> tau_of_arraysort m.sort)
+ | Rdef [] -> raise Not_found
+ | Rdef ((f,_)::_) -> env.record f
+ | Rget (_,f) ->
+ (try tau_of_sort (Field.sort f)
+ with Not_found -> env.field f)
+ | True | False -> Bool
+ | Kint _ -> Int
+ | Kreal _ -> Real
+ | Times(_,e) -> typecheck env e
+ | Add es | Mul es -> merge_list Int (typecheck env) es
+ | Div (a,b) | Mod (a,b) | If(_,a,b) ->
+ tau_merge (typecheck env a) (typecheck env b)
+ | Eq _ | Neq _ | Leq _ | Lt _ | And _ | Or _ | Not _ | Imply _ -> Bool
+ | Bind((Forall|Exists),_,_) -> Prop
+ | Apply _ | Bind(Lambda,_,_) -> raise Not_found
and typeof env e = try Some (typecheck env e) with Not_found -> None
diff --git a/src/plugins/reduc/hyp.ml b/src/plugins/reduc/hyp.ml
index fc4fabf2763c7db2b26efafaf8ff26481de7d763..478be2e40ea72324d85484a651060284bec8d474 100644
--- a/src/plugins/reduc/hyp.ml
+++ b/src/plugins/reduc/hyp.ml
@@ -20,9 +20,9 @@
(* *)
(**************************************************************************)
-let pred_opt_from_expr_state state e =
+let pred_opt_from_expr_state stmt e =
try
- Value2acsl.lval_to_predicate state e
+ Value2acsl.lval_to_predicate stmt e
with
| Cvalue.V.Not_based_on_null ->
Misc.not_implemented ~what:"Value not based on null";
@@ -36,12 +36,11 @@ class hypotheses_visitor (env: Collect.env) = object(self)
method! vstmt_aux stmt =
let kf = Option.get (self#current_kf) in
- let state = Db.Value.get_stmt_state stmt in
if Collect.should_annotate_stmt env stmt then begin
let vars = Collect.get_relevant_vars_stmt env kf stmt in
List.iter
(fun e ->
- let p_opt = pred_opt_from_expr_state state e in
+ let p_opt = pred_opt_from_expr_state stmt e in
Option.iter (Misc.assert_and_validate ~kf stmt) p_opt)
vars
end;
diff --git a/src/plugins/reduc/value2acsl.ml b/src/plugins/reduc/value2acsl.ml
index c91d1ba6992418ffebcea1371b2b587aa9d5ea36..e5201a791ccb73bde0919c6831745d8c63026293 100644
--- a/src/plugins/reduc/value2acsl.ml
+++ b/src/plugins/reduc/value2acsl.ml
@@ -165,15 +165,13 @@ let value_to_predicate_opt ?(loc=Location.unknown) t v =
with
| Not_based_on_null -> (* base_offsets_to_predicate ~loc t m *) None
-let exp_to_predicate ?(loc=Location.unknown) state e =
- let value = !Db.Value.eval_expr ~with_alarms:CilE.warn_none_mode state e in
+let exp_to_predicate ?(loc=Location.unknown) stmt e =
+ let value = Eva.Results.(before stmt |> eval_exp e |> as_ival) in
let te = Logic_utils.expr_to_term ~coerce:false e in
- value_to_predicate_opt ~loc te value
+ Option.bind (Result.to_option value) (ival_to_predicate_opt ~loc te)
-let lval_to_predicate ?(loc=Location.unknown) state lv =
- let value = snd(!Db.Value.eval_lval
- ~with_alarms:CilE.warn_none_mode None state lv)
- in
+let lval_to_predicate ?(loc=Location.unknown) stmt lv =
+ let value = Eva.Results.(before stmt |> eval_lval lv |> as_ival) in
let e = Cil.new_exp ~loc (Lval lv) in
let te = Logic_utils.expr_to_term ~coerce:false e in
- value_to_predicate_opt ~loc te value
+ Option.bind (Result.to_option value) (ival_to_predicate_opt ~loc te)
diff --git a/src/plugins/reduc/value2acsl.mli b/src/plugins/reduc/value2acsl.mli
index 17546299c2191a9c2c5ea076b463904ccd48ed60..e69aca30b89ac9004dd0ffb548e7ec90d547b8a2 100644
--- a/src/plugins/reduc/value2acsl.mli
+++ b/src/plugins/reduc/value2acsl.mli
@@ -27,5 +27,5 @@ open Cil_types
@return None if no such predicate can be created. *)
val value_to_predicate_opt: ?loc:location -> term -> Cvalue.V.t -> predicate option
-val lval_to_predicate: ?loc:location -> Cvalue.Model.t -> lval -> predicate option
-val exp_to_predicate: ?loc:location -> Cvalue.Model.t -> exp -> predicate option
+val lval_to_predicate: ?loc:location -> stmt -> lval -> predicate option
+val exp_to_predicate: ?loc:location -> stmt -> exp -> predicate option
diff --git a/src/plugins/scope/datascope.ml b/src/plugins/scope/datascope.ml
index 26d5806673e8aca286bbdc294cd813dc5c2202cd..b641d9210882c5779cfe1d5de9363a5d9d4df337 100644
--- a/src/plugins/scope/datascope.ml
+++ b/src/plugins/scope/datascope.ml
@@ -80,53 +80,44 @@ module InitSid = struct
Format.fprintf fmt "Lmap = %a@\n" LM.pretty lmap
end
-let get_lval_zones ~for_writing stmt lval =
- let state = Db.Value.get_stmt_state stmt in
- let dpds, zone, exact =
- !Db.Value.lval_to_zone_with_deps_state
- state ~deps:(Some Locations.Zone.bottom) ~for_writing lval
- in
- dpds, exact, zone
+let get_writes stmt lval =
+ Eva.Results.(before stmt |> eval_address ~for_writing:true lval |> as_zone)
(** Add to [stmt] to [lmap] for all the locations modified by the statement.
* Something to do only for calls and assignments.
* *)
let register_modified_zones lmap stmt =
let register lmap zone = InitSid.add_zone lmap zone stmt in
- let aux_out kf out =
+ let aux_out out kf =
let inout= !Db.Operational_inputs.get_internal_precise ~stmt kf in
Locations.Zone.join out inout.Inout_type.over_outputs
in
match stmt.skind with
| Instr (Set (lval, _, _)) ->
- let _dpds, _, zone =
- get_lval_zones ~for_writing:true stmt lval
- in
+ let zone = get_writes stmt lval in
register lmap zone
| Instr (Local_init(v, i, _)) ->
- let _, _, zone = get_lval_zones ~for_writing:true stmt (Cil.var v) in
+ let zone = get_writes stmt (Cil.var v) in
let lmap_init = register lmap zone in
(match i with
| AssignInit _ -> lmap_init
| ConsInit(f,_,_) ->
let kf = Globals.Functions.get f in
- let out = aux_out kf Locations.Zone.bottom in
+ let out = aux_out Locations.Zone.bottom kf in
register lmap_init out)
| Instr (Call (dst,funcexp,_args,_)) ->
begin
let lmap = match dst with
| None -> lmap
| Some lval ->
- let _dpds, _, zone =
- get_lval_zones ~for_writing:true stmt lval
- in
+ let zone = get_writes stmt lval in
register lmap zone
in
- let _, kfs =
- !Db.Value.expr_to_kernel_function ~deps:None (Kstmt stmt) funcexp
+ let kfs =
+ Eva.Results.(before stmt |> eval_callee funcexp |> default [])
in
let out =
- Kernel_function.Hptset.fold aux_out kfs Locations.Zone.bottom
+ List.fold_left aux_out Locations.Zone.bottom kfs
in
register lmap out
end
@@ -141,7 +132,7 @@ let compute kf =
let f = Kernel_function.get_definition kf in
let do_stmt lmap s =
Cil.CurrentLoc.set (Cil_datatype.Stmt.loc s);
- if Db.Value.is_reachable_stmt s
+ if Eva.Results.is_reachable s
then register_modified_zones lmap s
else lmap
in
@@ -361,7 +352,9 @@ let compute_escaping_zones s1 s2 =
let bases = List.fold_left filter Base.Hptset.empty locals in
if Base.Hptset.is_empty bases
then Locations.Zone.bottom
- else gather_escaping_zones bases (Db.Value.get_stmt_state s1)
+ else
+ let cvalue_state = Eva.Results.(before s1 |> get_cvalue_model) in
+ gather_escaping_zones bases cvalue_state
(* type pair_stmts = stmt * stmt *)
module PairStmts =
@@ -392,7 +385,7 @@ module ModifEdge =
Cil_state_builder.Kernel_function_hashtbl(HashPairStmtsZone)
(struct
let name = "Scope.Datatscope.ModifsEdge"
- let dependencies = [Db.Value.self]
+ let dependencies = [Eva.Analysis.self]
let size = 16
end)
@@ -410,9 +403,7 @@ let is_modified_by_edge kf z s1 s2 =
* @raise Kernel_function.No_Definition if [kf] has no definition
*)
let get_data_scope_at_stmt kf stmt lval =
- let dpds, _, zone = get_lval_zones ~for_writing:false stmt lval in
- (* TODO : is there something to do with 'exact' ? *)
- let zone = Locations.Zone.join dpds zone in
+ let zone = Eva.Results.(before stmt |> lval_deps lval) in
let allstmts, info = compute kf in
let modif_stmts = InitSid.find info zone in
let modifs_edge = is_modified_by_edge kf zone in
@@ -594,7 +585,7 @@ class check_annot_visitor = object(self)
method! vglob_aux g = match g with
| GFun (fdec, _loc) when
- !Db.Value.is_called (Option.get self#current_kf) &&
+ Eva.Results.is_called (Option.get self#current_kf) &&
not (!Db.Value.no_results fdec)
->
Cil.DoChildren
diff --git a/src/plugins/scope/datascope.mli b/src/plugins/scope/datascope.mli
index b34a8589757f06d20c613002c3b5d11828773d93..9b93221fe4f37e443f12a2981aeb04a80965eb44 100644
--- a/src/plugins/scope/datascope.mli
+++ b/src/plugins/scope/datascope.mli
@@ -37,9 +37,3 @@ val rm_asserts : unit -> unit
(** for internal use *)
module R: Plugin.General_services
-
-val get_lval_zones:
- for_writing:bool ->
- Cil_types.stmt ->
- Cil_types.lval ->
- Locations.Zone.t * bool * Locations.Zone.t
diff --git a/src/plugins/scope/defs.ml b/src/plugins/scope/defs.ml
index 565500c763b879c05749244de1dfb148edbbf699..af1e23d78388266822ed34f6e8bbad847c6ef558 100644
--- a/src/plugins/scope/defs.ml
+++ b/src/plugins/scope/defs.ml
@@ -62,10 +62,8 @@ let rec add_callee_nodes z acc nodes =
(fun node acc2 ->
match !Db.Pdg.node_key node with
| PdgIndex.Key.SigCallKey (cid, PdgIndex.Signature.Out out_key) ->
- let callees =
- Db.Value.call_to_kernel_function (PdgIndex.Key.call_from_id cid)
- in
- Kernel_function.Hptset.fold (fun kf (new_nodes, acc) ->
+ let callees = Eva.Results.callee (PdgIndex.Key.call_from_id cid) in
+ List.fold_left (fun (new_nodes, acc) kf ->
let callee_pdg = !Db.Pdg.get kf in
let outputs = match out_key with
| PdgIndex.Signature.OutLoc out ->
@@ -78,8 +76,8 @@ let rec add_callee_nodes z acc nodes =
in
let outputs = List.map fst outputs in
add_list_to_set outputs new_nodes, add_list_to_set outputs acc)
- callees
acc2
+ callees
| _ -> acc2)
nodes
(NSet.empty, acc)
@@ -134,7 +132,7 @@ let rec add_caller_nodes z kf acc (undef, nodes) =
let acc_undef, caller_nodes =
List.fold_left (add_one_call_nodes pdg) (None, NSet.empty) stmts
in add_caller_nodes z kf (NSet.union caller_nodes acc) (acc_undef, caller_nodes)
- in List.fold_left add_one_caller_nodes acc (!Db.Value.callers kf)
+ in List.fold_left add_one_caller_nodes acc (Eva.Results.callsites kf)
let compute_aux kf stmt zone =
debug1 "[Defs.compute] for %a at sid:%d in '%a'@."
@@ -168,9 +166,9 @@ let compute kf stmt lval =
let defs = NSet.fold add_node nodes Stmt.Hptset.empty in
(defs, undef)
in
- !Db.Value.compute ();
- let zone = !Db.Value.lval_to_zone (Kstmt stmt) lval in
- Option.map extract (compute_aux kf stmt zone)
+ Eva.Analysis.compute ();
+ let zone = Eva.Results.(before stmt |> eval_address lval |> as_zone) in
+ compute_aux kf stmt zone |> Option.map extract
(* Variation of the function above. For each PDG node that has been found,
we find whether it directly modifies [zone] through an affectation
@@ -219,8 +217,10 @@ let compute_with_def_type_zone kf stmt zone =
Option.map extract (compute_aux kf stmt zone)
let compute_with_def_type kf stmt lval =
- !Db.Value.compute ();
- let zone = !Db.Value.lval_to_zone (Kstmt stmt) lval in
+ Eva.Analysis.compute ();
+ let zone =
+ Eva.Results.(before stmt |> eval_address lval |> as_zone)
+ in
compute_with_def_type_zone kf stmt zone
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
diff --git a/src/plugins/scope/dpds_gui.ml b/src/plugins/scope/dpds_gui.ml
index d9d87225b1b4a4361133aa4d48040a91fff153fc..b3798da4e558840c00d2d51e005b3c92c503f5b8 100644
--- a/src/plugins/scope/dpds_gui.ml
+++ b/src/plugins/scope/dpds_gui.ml
@@ -114,7 +114,7 @@ struct include State_builder.Ref
(Stmt.Hptset)
(struct
let name = Info.name
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
let default () = Stmt.Hptset.empty
end)
@@ -137,7 +137,7 @@ struct
(Stmt.Map.Make(Datatype.String.Set))
(struct
let name = Info.name
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
let default () = Stmt.Map.empty
end)
@@ -222,7 +222,7 @@ module Pscope (* : (DpdCmdSig with type t_in = code_annotation) *) = struct
(Code_annotation)
(struct
let name = "Dpds_gui.Highlighter.Pscope_warn"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
end)
let clear () = Pscope.clear(); Pscope_warn.clear()
@@ -323,7 +323,7 @@ module Zones : (DpdCmdSig with type t_in = lval) = struct
(Stmt.Hptset))
(struct
let name = "Dpds_gui.Highlighter.ZonesState"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
end)
let set s =
set s;
@@ -392,7 +392,7 @@ module DpdsState =
(Stmt)
(struct
let name = "Dpds_gui.Highlighter.DpdsState"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
end)
let reset () =
@@ -469,7 +469,7 @@ let highlighter (buffer:Design.reactive_buffer) localizable ~start ~stop =
with Not_found -> ()
let check_value (main_ui:Design.main_window_extension_points) =
- if Db.Value.is_computed () then true
+ if Eva.Analysis.is_computed () then true
else
let answer = GToolbox.question_box
~title:("Eva Needed")
@@ -478,7 +478,7 @@ let check_value (main_ui:Design.main_window_extension_points) =
^"Do you want to run Eva with its current settings now?")
in
if answer = 1 then
- match main_ui#full_protect ~cancelable:true !Db.Value.compute with
+ match main_ui#full_protect ~cancelable:true Eva.Analysis.compute with
| Some _ ->
main_ui#redisplay (); (* New alarms *)
true
diff --git a/src/plugins/scope/zones.ml b/src/plugins/scope/zones.ml
index 9a9e18e7c26c5060b93725f7bbc5c1ca7964ea13..938b3630758808c5697d4bda0560436832efdff9 100644
--- a/src/plugins/scope/zones.ml
+++ b/src/plugins/scope/zones.ml
@@ -64,6 +64,14 @@ let compute_new_data old_zone l_zone l_dpds exact r_dpds =
(true, zone)
else (false, old_zone)
+let get_lval_zones ~for_writing stmt lval =
+ let state = Db.Value.get_stmt_state stmt in
+ let dpds, zone, exact =
+ !Db.Value.lval_to_zone_with_deps_state
+ state ~deps:(Some Locations.Zone.bottom) ~for_writing lval
+ in
+ dpds, exact, zone
+
(* the call result can be processed like a normal assignment *)
let process_call_res data stmt lvaloption froms =
let data = match lvaloption with
@@ -73,7 +81,7 @@ let process_call_res data stmt lvaloption froms =
let r_dpds = Function_Froms.Memory.collapse_return ret_dpds in
let r_dpds = Function_Froms.Deps.to_zone r_dpds in
let l_dpds, exact, l_zone =
- Datascope.get_lval_zones ~for_writing:true stmt lval in
+ get_lval_zones ~for_writing:true stmt lval in
compute_new_data data l_zone l_dpds exact r_dpds
in data
@@ -144,20 +152,20 @@ let process_one_call data stmt lvaloption froms =
used, data
let process_call data_after stmt lvaloption funcexp args _loc =
- let funcexp_dpds, called_functions =
- !Db.Value.expr_to_kernel_function
- (Kstmt stmt) ~deps:(Some Data.bottom) funcexp
+ let funcexp_dpds = Eva.Results.(before stmt |> expr_deps funcexp)
+ and called_functions =
+ Eva.Results.(before stmt |> eval_callee funcexp |> default [])
in
let used, data =
try
let froms = !Db.From.Callwise.find (Kstmt stmt) in
process_one_call data_after stmt lvaloption froms
with Not_found -> (* don't have callwise (-calldeps option) *)
- let do_call kf acc =
+ let do_call acc kf =
(* notice that we use the same old data for each possible call *)
(process_one_call data_after stmt lvaloption (!Db.From.get kf))::acc
in
- let l = Kernel_function.Hptset.fold do_call called_functions [] in
+ let l = List.fold_left do_call [] called_functions in
(* in l, we have one result for each possible function called *)
List.fold_left
(fun (acc_u,acc_d) (u,d) -> (acc_u || u), Data.merge acc_d d)
@@ -167,10 +175,9 @@ let process_call data_after stmt lvaloption funcexp args _loc =
if used then
let data =
(* no problem of order because parameters are disjoint for sure *)
- Kernel_function.Hptset.fold
- (fun kf data -> process_call_args data kf stmt args)
- called_functions
- data
+ List.fold_left
+ (fun data kf -> process_call_args data kf stmt args)
+ data called_functions
in
let data = Data.merge funcexp_dpds data in
used, data
@@ -213,7 +220,7 @@ module Computer (Param:sig val states : Ctx.t end) = struct
let do_assign stmt lval exp data =
let l_dpds, exact, l_zone =
- Datascope.get_lval_zones ~for_writing:true stmt lval in
+ get_lval_zones ~for_writing:true stmt lval in
let r_dpds = Data.exp_zone stmt exp in
let used, data = compute_new_data data l_zone l_dpds exact r_dpds in
let _ = if used then add_used_stmt stmt in
@@ -299,7 +306,7 @@ let compute_ctrl_info pdg ctrl_part used_stmts =
let compute kf stmt lval =
let f = Kernel_function.get_definition kf in
let dpds, _exact, zone =
- Datascope.get_lval_zones ~for_writing:false stmt lval in
+ get_lval_zones ~for_writing:false stmt lval in
let zone = Data.merge dpds zone in
debug1 "[zones] build for %a before %d in %a@\n"
Data.pretty zone stmt.sid Kernel_function.pretty kf;
diff --git a/src/plugins/security_slicing/components.ml b/src/plugins/security_slicing/components.ml
index af605036f174476ed91396a80eb74727be868928..329a0ff7af5262bf323d0358cd777ee6d00fad39 100644
--- a/src/plugins/security_slicing/components.ml
+++ b/src/plugins/security_slicing/components.ml
@@ -398,7 +398,7 @@ module Component = struct
todolist
callsites)
todolist
- (!Db.Value.callers kf)
+ (Eva.Results.callsites kf)
let related_nodes_of_nodes kind result nodes =
let initial_nodes =
@@ -460,7 +460,7 @@ module Component = struct
in
List.fold_left do_call todolist callsites
in
- List.fold_left do_caller todolist (!Db.Value.callers kf)
+ List.fold_left do_caller todolist (Eva.Results.callsites kf)
| _ ->
todolist
in
@@ -502,11 +502,7 @@ module Component = struct
todolist
else
let stmt = Key.call_from_id id in
- let called_kfs =
- Kernel_function.Hptset.elements
- (try Db.Value.call_to_kernel_function stmt
- with Db.Value.Not_a_call -> assert false)
- in
+ let called_kfs = Eva.Results.callee stmt in
let todolist =
List.fold_left
(fun todolist called_kf ->
@@ -629,7 +625,7 @@ module Component = struct
~level:3 "computing initial nodes for %d" stmt.sid;
let pdg = !Db.Pdg.get kf in
let nodes =
- if Db.Value.is_reachable_stmt stmt then
+ if Eva.Results.is_reachable stmt then
try !Db.Pdg.find_simple_stmt_nodes pdg stmt
with Not_found -> assert false
else begin
@@ -783,7 +779,7 @@ end = struct
(struct
let name = "Components"
let size = 7
- let dependencies = [ Ast.self; Db.Value.self ]
+ let dependencies = [ Ast.self; Eva.Analysis.self ]
end)
let () =
diff --git a/src/plugins/slicing/api.ml b/src/plugins/slicing/api.ml
index 3ece47ef72315659e3f2c4756382c7912a072c2a..13b39597d7dac0e6acfd53fbd6011bf9679978a6 100644
--- a/src/plugins/slicing/api.ml
+++ b/src/plugins/slicing/api.ml
@@ -413,10 +413,9 @@ module Slice = struct
let get_called_funcs ff stmt =
match stmt.skind with
- | Instr (Call (_,expr_f,_,_)) ->
+ | Instr (Call _) ->
if snd (Fct_slice.get_called_slice ff stmt) then
- Kernel_function.Hptset.elements
- (snd (!Db.Value.expr_to_kernel_function (Kstmt stmt) ~deps:None expr_f))
+ Eva.Results.callee stmt
else
[]
| Instr (Local_init (_, ConsInit (f, _, _), _)) -> [ Globals.Functions.get f ]
diff --git a/src/plugins/slicing/fct_slice.ml b/src/plugins/slicing/fct_slice.ml
index 47d922e5bb064d78c4ae8b3c1baacae9bf839769..22285f900b9f9a04bf5aa331cdbef9bd32c215b2 100644
--- a/src/plugins/slicing/fct_slice.ml
+++ b/src/plugins/slicing/fct_slice.ml
@@ -54,9 +54,7 @@ let exists_fun_callers fpred kf =
then false (* no way to call the initial [kf]. *)
else begin
table := Kernel_function.Set.add kf !table ;
- List.exists
- (fun (kf,_) -> exists_fun_callers kf)
- (!Db.Value.callers kf)
+ List.exists exists_fun_callers (Eva.Results.callers kf)
end
in
exists_fun_callers kf
@@ -146,16 +144,7 @@ end = struct
let indirectly_called_src_functions call_id =
let _, stmt = call_id in
- let funcexp = match stmt.skind with
- | Instr (Call (_,funcexp,_,_)) -> funcexp
- | Instr (Local_init (_, ConsInit (f, _, _), _)) -> Cil.evar f
- | _ -> assert false
- in
- let _, called_functions =
- !Db.Value.expr_to_kernel_function
- (Kstmt stmt) ~deps:(Some Locations.Zone.bottom) funcexp
- in
- Kernel_function.Hptset.elements called_functions
+ Eva.Results.callee stmt
(** [call_id] is a call to [g] in [f].
* we don't want [f] to call [g] anymore, so we have to update [g] [called_by]
@@ -1463,12 +1452,11 @@ let merge_fun_callers get_list get_value merge is_top acc kf =
raise StopMerging (* acceleration when top is reached *)
in
let rec merge_fun_callers kf =
- let merge_fun_caller (kf,_) = merge_fun_callers kf in
let vf = Kernel_function.get_vi kf in
if not (Cil_datatype.Varinfo.Set.mem vf !table) then begin
table := Cil_datatype.Varinfo.Set.add vf !table ;
List.iter (fun x -> merge (get_value x)) (get_list kf) ;
- List.iter merge_fun_caller (!Db.Value.callers kf)
+ List.iter merge_fun_callers (Eva.Results.callers kf)
end
(* else no way to add something, the [kf] contribution is already
accumulated. *)
diff --git a/src/plugins/slicing/printSlice.ml b/src/plugins/slicing/printSlice.ml
index 63986e183ebb85760f6c4a16023d4139946f9927..9c5bd9baed6a1c0a0d18839fdf42c04c818018b5 100644
--- a/src/plugins/slicing/printSlice.ml
+++ b/src/plugins/slicing/printSlice.ml
@@ -204,10 +204,10 @@ module PrintProject = struct
let iter_edges_src_fun f =
let do_kf_calls kf =
let fi = SlicingMacros.get_kf_fi kf in
- let doit (kf_caller,_) =
+ let doit kf_caller =
let fi_caller = SlicingMacros.get_kf_fi kf_caller in
f ((Src fi_caller, Src fi), None)
- in List.iter doit (!Db.Value.callers kf)
+ in List.iter doit (Eva.Results.callers kf)
in
Globals.Functions.iter do_kf_calls
diff --git a/src/plugins/slicing/register.ml b/src/plugins/slicing/register.ml
index 3f32606a217928ce557bfcc06f7d7b5c98c0dbea..4166762d3cc86694daf02f82b23262376cb39f89 100644
--- a/src/plugins/slicing/register.ml
+++ b/src/plugins/slicing/register.ml
@@ -27,7 +27,7 @@ let main () =
(* have to do the value analysis before the selections
* because some functions use its results,
* and the value analysis is not launched automatically. *)
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
let project_name = SlicingParameters.ProjectName.get () in
Api.Project.reset_slicing ();
diff --git a/src/plugins/slicing/register_gui.ml b/src/plugins/slicing/register_gui.ml
index 0650a8a5d7d4ec67b06399f6dc4e4f0420060acc..92251b205bb8a73540f113861d13586c14e7b284 100644
--- a/src/plugins/slicing/register_gui.ml
+++ b/src/plugins/slicing/register_gui.ml
@@ -92,7 +92,7 @@ let msg_help_libraries =
undefined functions."
let check_value_computed (main_ui:Design.main_window_extension_points) =
- if Db.Value.is_computed () then true
+ if Eva.Analysis.is_computed () then true
else
let answer = GToolbox.question_box
~title:("Eva Needed")
@@ -102,7 +102,7 @@ let check_value_computed (main_ui:Design.main_window_extension_points) =
^"Do you want to run Eva with its current settings now?")
in
if answer = 1 then
- match main_ui#full_protect ~cancelable:true !Db.Value.compute with
+ match main_ui#full_protect ~cancelable:true Eva.Analysis.compute with
| Some _ ->
main_ui#redisplay (); (* New alarms *)
true
@@ -116,7 +116,7 @@ let gui_apply_action (main_ui:Design.main_window_extension_points) f x ~info =
let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
(main_ui:Design.main_window_extension_points) ~button localizable =
- if (not (Db.Value.is_computed ()))
+ if (not (Eva.Analysis.is_computed ()))
then
ignore
(popup_factory#add_item "Enable _slicing"
@@ -126,7 +126,7 @@ let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
Enabled.set true;
!update_column `Visibility
in
- if (not (Db.Value.is_computed ())) then begin
+ if (not (Eva.Analysis.is_computed ())) then begin
if check_value_computed main_ui then enable ()
end
else enable ()
@@ -344,7 +344,7 @@ let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
in
let some_kf_from_vi vi =
try let kf = Globals.Functions.get vi in
- if !Db.Value.is_called kf then Some kf else None
+ if Eva.Results.is_called kf then Some kf else None
with Not_found -> None in
let some_kf_from_lv lv =
match lv with
@@ -352,7 +352,7 @@ let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
| _ -> None
in
let some_kf_ki_lv kf stmt lvopt =
- if !Db.Value.is_called kf && Db.Value.is_reachable_stmt stmt
+ if Eva.Results.is_called kf && Eva.Results.is_reachable stmt
then Some (kf, stmt, lvopt) else None
in
begin (* add menu for slicing and scope plug-in *)
@@ -386,7 +386,7 @@ let slicing_highlighter(buffer:Design.reactive_buffer) localizable ~start ~stop=
let highlight () =
let buffer = buffer#buffer in
let ki = Pretty_source.ki_of_localizable localizable in
- if Db.Value.is_accessible ki then
+ if Eva.Results.is_reachable_kinstr ki then
let unused_code_area =
Gtk_helper.make_tag buffer
~name:"slicing_unused" [`STRIKETHROUGH true ]
@@ -443,7 +443,7 @@ let slicing_highlighter(buffer:Design.reactive_buffer) localizable ~start ~stop=
end
in
let tag_stmt kf stmt pb pe =
- assert (Db.Value.is_reachable_stmt stmt) ;
+ assert (Eva.Results.is_reachable stmt) ;
apply_on_one_project_and_merge_slices
kf
pb
@@ -554,7 +554,7 @@ let slicing_panel (main_ui:Design.main_window_extension_points) =
(gui_set_slicing_level main_ui)
in
let refresh () =
- let value_is_computed = Db.Value.is_computed () in
+ let value_is_computed = Eva.Analysis.is_computed () in
let enabled = Enabled.get () in
enabled_button#misc#set_sensitive value_is_computed ;
slice_undef_button#misc#set_sensitive enabled ;
diff --git a/src/plugins/slicing/slicingCmds.ml b/src/plugins/slicing/slicingCmds.ml
index 79b59cc0fd5ac7c7124e56e0f1517303def29d20..86b4a5646fab0d4998df0607ff6662a119db266c 100644
--- a/src/plugins/slicing/slicingCmds.ml
+++ b/src/plugins/slicing/slicingCmds.ml
@@ -55,6 +55,10 @@ let apply_all ~propagate_to_callers =
let get_select_kf (fvar, _select) = Globals.Functions.get fvar
+let get_lval_zone ?(for_writing=false) stmt lval =
+ let open Eva.Results in
+ before stmt |> eval_address ~for_writing lval |> as_zone
+
(** Utilities for [kinstr]. *)
module Kinstr: sig
val iter_from_func : (stmt -> unit) -> kernel_function -> unit
@@ -71,17 +75,14 @@ struct
* i.e. directly means when [ki] is a call,
it doesn't don't look at the assigns clause of the called function. *)
let get_rw_zone stmt = (* returns [Zone.t read],[Zone.t written] *)
- assert (Db.Value.is_computed ());
+ assert (Eva.Analysis.is_computed ());
let lval_process read_zone stmt lv =
(* returns [read_zone] joined to [Zone.t read] by [lv], [Zone.t written] by [lv] *)
(* The modified locations are [looking_for], those address are
function of [deps]. *)
- let state = Db.Value.get_stmt_state stmt in
- let deps, zloc, _exact =
- !Db.Value.lval_to_zone_with_deps_state
- state ~deps:(Some read_zone) ~for_writing:true lv
- in
- deps, zloc
+ let zloc = get_lval_zone ~for_writing:true stmt lv in
+ let deps = Eva.Results.(before stmt |> address_deps lv) in
+ Locations.Zone.join read_zone deps, zloc
in
let call_process lv f args _loc =
(* returns [Zone.t read] by [lv, f, args], [Zone.t written] by [lv] *)
@@ -184,8 +185,8 @@ let select_entry_point_and_some_inputs_outputs set ~mark kf ~return ~outputs ~in
add_to_selection set selection
in if ((Locations.Zone.equal Locations.Zone.bottom outputs) && not return) ||
(try
- let ki = Kernel_function.find_return kf
- in if Db.Value.is_reachable_stmt ki then
+ let stmt = Kernel_function.find_return kf
+ in if Eva.Results.is_reachable stmt then
false
else
begin
@@ -210,8 +211,8 @@ let select_entry_point_and_some_inputs_outputs set ~mark kf ~return ~outputs ~in
(* apply [select ~spare] on each callsite of [kf] and add the returned selection
to [set]. *)
let generic_select_func_calls select_stmt set ~spare kf =
- assert (Db.Value.is_computed ());
- let callers = !Db.Value.callers kf in
+ assert (Eva.Analysis.is_computed ());
+ let callers = Eva.Results.callsites kf in
let select_calls acc (caller, stmts) =
List.fold_left (fun acc s -> select_stmt acc ~spare s caller) acc stmts
in
@@ -245,7 +246,7 @@ let select_func_calls_to set ~spare kf =
let nspare = not spare in
SlicingMarks.mk_user_mark ~data:nspare ~addr:nspare ~ctrl:nspare
in
- assert (Db.Value.is_computed ());
+ assert (Eva.Analysis.is_computed ());
let outputs = !Db.Outputs.get_external kf in
select_entry_point_and_some_inputs_outputs set ~mark kf
~return:true
@@ -308,7 +309,7 @@ let select_stmt_zone set mark zone ~before ki kf =
or after (c.f. boolean [~before]) the statement [ki].
Note: add also a transparent selection on the whole statement. *)
let select_stmt_lval set mark lval_str ~before ki ~eval kf =
- assert (Db.Value.is_computed ());
+ assert (Eva.Analysis.is_computed ());
if Datatype.String.Set.is_empty lval_str
then set
else
@@ -319,11 +320,7 @@ let select_stmt_lval set mark lval_str ~before ki ~eval kf =
let lval =
!Db.Properties.Interp.term_lval_to_lval ~result:None lval_term
in
- let state = Db.Value.get_stmt_state eval in
- let _deps, zone, _exact =
- !Db.Value.lval_to_zone_with_deps_state
- ~deps:None ~for_writing:false state lval
- in
+ let zone = get_lval_zone eval lval in
Locations.Zone.join zone acc)
lval_str
Locations.Zone.bottom
@@ -342,7 +339,7 @@ let select_stmt_lval set mark lval_str ~before ki ~eval kf =
i.e. when [ki_opt] is a call, the selection doesn't look at the assigns clause
of a call. *)
let select_lval_rw set mark ~rd ~wr ~eval kf ki_opt=
- assert (Db.Value.is_computed ());
+ assert (Eva.Analysis.is_computed ());
let zone_option ~for_writing lval_str =
if Datatype.String.Set.is_empty lval_str
then None
@@ -352,11 +349,7 @@ let select_lval_rw set mark ~rd ~wr ~eval kf ki_opt=
(fun lval_str acc ->
let lval_term = !Db.Properties.Interp.term_lval kf lval_str in
let lval = !Db.Properties.Interp.term_lval_to_lval ~result:None lval_term in
- let state = Db.Value.get_stmt_state eval in
- let _deps, zone, _exact =
- !Db.Value.lval_to_zone_with_deps_state
- state ~for_writing ~deps:None lval
- in
+ let zone = get_lval_zone ~for_writing eval lval in
Locations.Zone.join zone acc)
lval_str Locations.Zone.bottom
in SlicingParameters.debug ~level:3
@@ -389,7 +382,7 @@ let select_lval_rw set mark ~rd ~wr ~eval kf ki_opt=
| None ->
Globals.Functions.iter
(fun kf ->
- if !Db.Value.is_called kf then
+ if Eva.Results.is_called kf then
if not (!Db.Value.use_spec_instead_of_definition kf)
then (* Called function with source code: just looks at its stmt *)
Kinstr.iter_from_func (select_rw_from_stmt kf) kf
@@ -413,7 +406,7 @@ let select_lval_rw set mark ~rd ~wr ~eval kf ki_opt=
~return:false ~inputs ~outputs:Locations.Zone.bottom
in
- assert (!Db.Value.is_called kf) ; (* otherwise [!Db.Outputs.get_external kf] gives weird results *)
+ assert (Eva.Results.is_called kf) ; (* otherwise [!Db.Outputs.get_external kf] gives weird results *)
select_inter_zone select_wr zone_wr_opt (!Db.Outputs.get_external kf) ;
select_inter_zone select_rd zone_rd_opt (!Db.Inputs.get_external kf)
end
diff --git a/src/plugins/slicing/slicingMacros.ml b/src/plugins/slicing/slicingMacros.ml
index d49a3f596c1632a67974dc3aefcfe1553699c28d..ebb985bc1985e17a25ddb057e273ed32aef42a9c 100644
--- a/src/plugins/slicing/slicingMacros.ml
+++ b/src/plugins/slicing/slicingMacros.ml
@@ -173,12 +173,9 @@ let is_call_stmt stmt =
| Instr (Call _ | Local_init(_, ConsInit _,_)) -> true | _ -> false
let get_called_kf call_stmt = match call_stmt.skind with
- | Instr (Call (_, funcexp,_,_)) ->
- let _funcexp_dpds, called_functions =
- !Db.Value.expr_to_kernel_function ~deps:None (Kstmt call_stmt) funcexp
- in
- (match Kernel_function.Hptset.contains_single_elt called_functions with
- | Some kf -> kf
+ | Instr (Call _) ->
+ (match Eva.Results.callee call_stmt with
+ | [kf] -> kf
| _ -> raise SlicingTypes.PtrCallExpr)
| Instr (Local_init(_, ConsInit (f, _, _), _)) -> Globals.Functions.get f
| _ -> invalid_arg "Not a call statement !"
diff --git a/src/plugins/slicing/slicingProject.ml b/src/plugins/slicing/slicingProject.ml
index 73532548cc680d1e25e1d22b8fa9a079ccb49a9b..010cbdd86d44d86398a97ab5efe9e2f392998268 100644
--- a/src/plugins/slicing/slicingProject.ml
+++ b/src/plugins/slicing/slicingProject.ml
@@ -222,13 +222,13 @@ let apply_appli_crit appli_crit =
match appli_crit with
| T.CaCall fi_to_call ->
let kf_to_call = M.get_fi_kf fi_to_call in
- let add_actions actions (kf_caller,_) =
+ let add_actions actions kf_caller =
let fi_caller = M.get_kf_fi kf_caller in
let mark = SlicingMarks.mk_user_spare in
let action =
SlicingActions.mk_crit_mark_calls fi_caller kf_to_call mark in
action :: actions
- in List.fold_left add_actions [] (!Db.Value.callers kf_to_call)
+ in List.fold_left add_actions [] (Eva.Results.callers kf_to_call)
| _ ->
SlicingParameters.not_yet_implemented
"This slicing criterion on application"
diff --git a/src/plugins/slicing/slicingSelect.ml b/src/plugins/slicing/slicingSelect.ml
index 5775c6ecbe4f45d9c3540775f6a1062325efd5a6..b4b331aabe20174accb29534e0e15179b06d3aec 100644
--- a/src/plugins/slicing/slicingSelect.ml
+++ b/src/plugins/slicing/slicingSelect.ml
@@ -105,7 +105,7 @@ let select_stmt_zone kf ?(select=empty_db_select kf) stmt ~before loc mark =
Locations.Zone.pretty loc
(if before then "before" else "after") stmt.sid
SlicingMarks.pretty_mark mark;
- if not (Db.Value.is_reachable_stmt stmt) then
+ if not (Eva.Results.is_reachable stmt) then
begin
SlicingParameters.feedback
"@[Nothing to select for @[%a@]@ %s unreachable stmt of %a@]"
@@ -194,7 +194,7 @@ let stmt_nodes_to_select pdg stmt =
let select_stmt_computation kf ?(select=empty_db_select kf) stmt mark =
SlicingParameters.debug ~level:1 "[Register.select_stmt_computation] on stmt %d" stmt.sid;
- if not (Db.Value.is_reachable_stmt stmt) then
+ if not (Eva.Results.is_reachable stmt) then
begin
SlicingParameters.feedback
"@[Nothing to select for an unreachable stmt of %a@]"
diff --git a/src/plugins/slicing/slicingState.ml b/src/plugins/slicing/slicingState.ml
index 93a4ad676a17dfd508df128dec7f32b16c2fe1b8..4b9a224a47538ed45941692170d9cea09894a585 100644
--- a/src/plugins/slicing/slicingState.ml
+++ b/src/plugins/slicing/slicingState.ml
@@ -49,7 +49,7 @@ let may_map ~none f = match P.get_option () with
| Some _ -> f ()
let reset_slicing () =
- !Db.Value.compute () ;
+ Eva.Analysis.compute () ;
let initialized = match P.get_option () with | None -> false | Some _ -> true in
if not initialized then
SlicingParameters.feedback ~level:1 "initializing slicing ..."
diff --git a/src/plugins/slicing/slicingTransform.ml b/src/plugins/slicing/slicingTransform.ml
index c27b8a15e3be1be8bb12135b32ffba67d21e6533..9a4723f972394a8c7158259f38c6a7a6d69e01a6 100644
--- a/src/plugins/slicing/slicingTransform.ml
+++ b/src/plugins/slicing/slicingTransform.ml
@@ -234,7 +234,7 @@ module Visibility (SliceName : sig
let annotation_visible ff_opt stmt annot =
SlicingParameters.debug ~current:true ~level:2
"[SlicingTransform.Visibility.annotation_visible] ?";
- Db.Value.is_reachable_stmt stmt &&
+ Eva.Results.is_reachable stmt &&
Alarms.find annot = None && (* Always drop alarms: the alarms table
in the new project is not synchronized *)
match ff_opt with
diff --git a/src/plugins/sparecode/register.ml b/src/plugins/sparecode/register.ml
index a6c985c0dc8ebfa6dc8f75311a28460c62ad48b9..a6a1fa9a5bfab44f202049b1b4c4b67773b30e78 100644
--- a/src/plugins/sparecode/register.ml
+++ b/src/plugins/sparecode/register.ml
@@ -35,7 +35,7 @@ module Result =
(struct
let name = "Sparecode"
let size = 7
- let dependencies = [ Ast.self; Db.Value.self ] (* delayed, see below *)
+ let dependencies = [ Ast.self; Eva.Analysis.self ] (* delayed, see below *)
end)
let () =
diff --git a/src/plugins/sparecode/transform.ml b/src/plugins/sparecode/transform.ml
index ce447c3fb94eecd147f1fd0adf0f111c4854a471..8c9fb9a68f6d4fde5b84a591d0600cfa59161639 100644
--- a/src/plugins/sparecode/transform.ml
+++ b/src/plugins/sparecode/transform.ml
@@ -81,7 +81,7 @@ module BoolInfo = struct
key_visible "label_visible" fm lab_key
let annotation_visible _ stmt annot =
- Db.Value.is_reachable_stmt stmt && Alarms.find annot = None
+ Eva.Results.is_reachable stmt && Alarms.find annot = None
(* Keep annotations on reachable, but not alarms: they can be resynthesized,
and the alarms table is not synchronized in the new project anyway *)
(* TODO: does not seem really coherent with the fact that almost everything
@@ -126,13 +126,11 @@ module BoolInfo = struct
let called_info (project, _fm) call_stmt =
match call_stmt.skind with
| Instr (Call (_, _, _, _) | Local_init(_, ConsInit _, _)) ->
- let called_functions = Db.Value.call_to_kernel_function call_stmt in
+ let called_functions = Eva.Results.callee call_stmt in
let call_info =
- match
- Kernel_function.Hptset.contains_single_elt called_functions
- with
- | None -> None
- | Some kf ->
+ match called_functions with
+ | [] | _ :: _ :: _ -> None
+ | [kf] ->
match Spare_marks.get_marks project kf with
| None ->
if Spare_marks.kf_visible project kf
diff --git a/src/plugins/studia/reads.ml b/src/plugins/studia/reads.ml
index 3685d8cba7b689b4e0ee46f1408db61985065d61..0a432ee23a669275b49c37bbc8324b1974c869c3 100644
--- a/src/plugins/studia/reads.ml
+++ b/src/plugins/studia/reads.ml
@@ -44,15 +44,13 @@ class find_read zlval = object
let deps = match lvopt with
| None -> deps
| Some lv ->
- let dlv, _ =
- !Db.Value.lval_to_loc_with_deps (Kstmt stmt) ~deps:Zone.bottom lv
- in
+ let dlv = Eva.Results.(before stmt |> address_deps lv) in
Zone.join dlv deps
in
let direct = Zone.intersects deps zlval in
(* now determine if the functions called at [stmt] read directly or
indirectly [zlval] *)
- let aux_kf kf effects =
+ let aux_kf effects kf =
let inputs = !Db.Inputs.get_internal kf in
(* TODO: change to this once we can get "full" inputs through Inout.
Currently, non operational inputs disappear, and this function
@@ -68,9 +66,9 @@ class find_read zlval = object
else
effects (* this function pointer does not read [zlval] *)
in
- let kfs = Db.Value.call_to_kernel_function stmt in
+ let kfs = Eva.Results.callee stmt in
let effects =
- Kernel_function.Hptset.fold aux_kf kfs {direct; indirect = false}
+ List.fold_left aux_kf {direct; indirect = false} kfs
in
res <- (stmt, effects) :: res
end
diff --git a/src/plugins/studia/studia_gui.ml b/src/plugins/studia/studia_gui.ml
index 9008db351027fc01dcfd385aba799782e8a4f718..c7b1425c394d7c776424631c55b840ec99640425 100644
--- a/src/plugins/studia/studia_gui.ml
+++ b/src/plugins/studia/studia_gui.ml
@@ -90,7 +90,7 @@ struct
(Stmt.Map.Make(Datatype.String.Set))
(struct
let name = Info.name
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
let default () = Stmt.Map.empty
end)
@@ -184,7 +184,7 @@ module StudiaState =
(Stmt)
(struct
let name = "Studia.Highlighter.StudiaState"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Eva.Analysis.self ]
end)
let reset () =
@@ -226,7 +226,7 @@ let highlighter (buffer:Design.reactive_buffer) localizable ~start ~stop =
with Not_found -> ()
let check_value (main_ui:Design.main_window_extension_points) =
- Db.Value.is_computed () ||
+ Eva.Analysis.is_computed () ||
let answer = GToolbox.question_box
~title:("Eva Needed")
~buttons:[ "Run"; "Cancel" ]
@@ -234,7 +234,7 @@ let check_value (main_ui:Design.main_window_extension_points) =
^"Do you want to run Eva now ?")
in
answer = 1 &&
- match main_ui#full_protect ~cancelable:true !Db.Value.compute with
+ match main_ui#full_protect ~cancelable:true Eva.Analysis.compute with
| Some _ -> true
| None -> false
diff --git a/src/plugins/studia/studia_request.ml b/src/plugins/studia/studia_request.ml
index ff3f94c3d1061bc178020507cb565241d5cb20dc..2e44a1b8e8f0d4c9503225954eefa4578b65d3b9 100644
--- a/src/plugins/studia/studia_request.ml
+++ b/src/plugins/studia/studia_request.ml
@@ -81,7 +81,8 @@ let compute kind zone =
let empty = { direct = []; indirect = []; } in
List.fold_left add empty stmts
-let lval_location kinstr lval = !Db.Value.lval_to_zone kinstr lval
+let lval_location kinstr lval =
+ Eva.Results.(before_kinstr kinstr |> eval_address lval |> as_zone)
let () = Request.register ~package
~kind:`GET ~name:"getReadsLval"
diff --git a/src/plugins/studia/writes.ml b/src/plugins/studia/writes.ml
index fa29b18e974c25b9234fa1e95b11f4f3fd8005aa..dbcbcfc04cea20a2596da29b264f3ea0e4b852ee 100644
--- a/src/plugins/studia/writes.ml
+++ b/src/plugins/studia/writes.ml
@@ -35,7 +35,7 @@ type effects = {
(** Does the functions called at [stmt] modify directly or indirectly [zlval] *)
let effects_of_call stmt zlval effects =
- let aux_kf kf effects =
+ let aux_kf effects kf =
let inout = !Db.Operational_inputs.get_internal_precise ~stmt kf in
let out = inout.Inout_type.over_outputs in
if Zone.intersects out zlval then
@@ -47,8 +47,8 @@ let effects_of_call stmt zlval effects =
else
effects
in
- let kfs = Db.Value.call_to_kernel_function stmt in
- Kernel_function.Hptset.fold aux_kf kfs effects
+ let kfs = Eva.Results.callee stmt in
+ List.fold_left aux_kf effects kfs
class find_write zlval = object (self)
inherit Visitor.frama_c_inplace
@@ -66,8 +66,8 @@ class find_write zlval = object (self)
let direct_write = match lvopt with
| None -> false
| Some lv ->
- let zlv = !Db.Value.lval_to_zone (Kstmt stmt) lv in
- Zone.intersects zlv zlval
+ Eva.Results.(before stmt |> eval_address lv |> as_zone_result) |>
+ Result.fold ~ok:(Zone.intersects zlval) ~error:(fun _ -> false)
in
let effects =
effects_of_call stmt zlval {direct = direct_write; indirect =false}
diff --git a/src/plugins/users/users_register.ml b/src/plugins/users/users_register.ml
index f556af9526d47558f4ee79c364b2a0db5cb08162..f54caf8bbdad18a92cf2f1cc202edfe0c9be2142 100644
--- a/src/plugins/users/users_register.ml
+++ b/src/plugins/users/users_register.ml
@@ -44,7 +44,7 @@ module Users =
(struct
let name = "Users"
let size = 17
- let dependencies = [ Db.Value.self; ForceUsers.self ]
+ let dependencies = [ Eva.Analysis.self; ForceUsers.self ]
end)
let call_for_users (_state, call_stack) =
@@ -53,7 +53,7 @@ let call_for_users (_state, call_stack) =
| (current_function, _call_site) :: tail ->
if tail = [] then begin
(* End of Value analysis, we record that Users has run. We should not
- do this after the explicit call to Db.Value.compute later in this
+ do this after the explicit call to Eva.Analysis.compute later in this
file, as Value can run on its own and execute Users while doing so.*)
Users.mark_as_computed ()
end;
@@ -79,15 +79,15 @@ let get kf =
if Users.is_computed () then
find kf
else begin
- if Db.Value.is_computed () then begin
+ if Eva.Analysis.is_computed () then begin
feedback "requiring again the computation of the value analysis";
Project.clear
- ~selection:(State_selection.with_dependencies Db.Value.self)
+ ~selection:(State_selection.with_dependencies Eva.Analysis.self)
()
end else
feedback ~level:2 "requiring the computation of the value analysis";
add_value_hook ();
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
find kf
end
diff --git a/src/plugins/value/Eva.mli b/src/plugins/value/Eva.mli
index 74ac173305e0e35d0eecdebbcca95a211bf0a8b4..7b6776718948e5ecec37c97108ad24a046e4c653 100644
--- a/src/plugins/value/Eva.mli
+++ b/src/plugins/value/Eva.mli
@@ -1,38 +1,307 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2007-2021 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It is distributed in the hope that it will be useful, *)
-(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
-(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
-(* GNU Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-(** Analysis for values and pointers *)
-
-module Value_results: sig
- type results
+(** Eva public API.
+
+ The main modules are:
+ - Analysis: run the analysis.
+ - Results: access analysis results, especially the values of expressions
+ and memory locations of lvalues at each program point.
+
+ The following modules allow configuring the Eva analysis:
+ - Parameters: change the configuration of the analysis.
+ - Eva_annotations: add local annotations to guide the analysis.
+ - Builtins: register ocaml builtins to be used by the cvalue domain
+ instead of analysing the body of some C functions.
+
+ Other modules are for internal use only. *)
+
+(* This file is generated. Do not edit. *)
+
+module Analysis: sig
+ val compute : unit -> unit
+ (** Computes the Eva analysis, if not already computed, using the entry point
+ of the current project. You may set it with {!Globals.set_entry_point}.
+ @raise Globals.No_such_entry_point if the entry point is incorrect
+ @raise Db.Value.Incorrect_number_of_arguments if some arguments are
+ specified for the entry point using {!Db.Value.fun_set_args}, and
+ an incorrect number of them is given.
+ @plugin development guide *)
+
+ val is_computed : unit -> bool
+ (** Return [true] iff the Eva analysis has been done. *)
+
+ val self : State.t
+ (** Internal state of Eva analysis from projects viewpoint. *)
+end
+
+module Results: sig
+ (** Eva's result API is a work-in-progress interface to allow accessing the
+ analysis results once its completed. It is experimental and is very likely
+ to change in the future. It aims at replacing [Db.Value] but does not
+ completely covers all its usages yet. As for now, this interface has some
+ advantages over Db's :
+
+ - evaluations uses every available domains and not only Cvalue;
+ - the caller may distinguish failure cases when a request is unsucessful;
+ - working with callstacks is easy;
+ - some common shortcuts are provided (e.g. for extracting ival directly);
+ - overall, individual functions are simpler.
+
+ The idea behind this API is that requests must be decomposed in several
+ steps. For instance, to evaluate an expression :
+
+ 1. first, you have to state where you want to evaluate it,
+ 2. optionally, you may specify in which callstack,
+ 3. you choose the expression to evaluate,
+ 4. you require a destination type to evaluate into.
+
+ Usage sketch :
+
+ Eva.Results.(
+ before stmt |> in_callstack cs |>
+ eval_var vi |> as_int |> default 0)
+
+ or equivalently, if you prefer
+
+ Eva.Results.(
+ default O (as_int (eval_var vi (in_callstack cs (before stmt))))
+ *)
+
+
+ type callstack = (Cil_types.kernel_function * Cil_types.kinstr) list
+
+ type request
+
+ type value
+ type address
+ type 'a evaluation
+
+ type error = Bottom | Top | DisabledDomain
+ type 'a result = ('a,error) Result.t
+
+
+ (** Results handling *)
+
+ (** Translates an error to a human readable string. *)
+ val string_of_error : error -> string
+
+ (** Pretty printer for errors. *)
+ val pretty_error : Format.formatter -> error -> unit
+
+ (** Pretty printer for API's results. *)
+ val pretty_result : (Format.formatter -> 'a -> unit) ->
+ Format.formatter -> 'a result -> unit
+
+ (** [default d r] extracts the value of [r] if [r] is Ok,
+ or use the default value [d] otherwise.
+ Equivalent to [Result.value ~default:d r] *)
+ val default : 'a -> 'a result -> 'a
+
+
+ (** Control point selection *)
+
+ (** At the start of the analysis, but after the initialization of globals. *)
+ val at_start : request
+
+ (** At the end of the analysis, after the main function has returned. *)
+ val at_end : unit -> request
+
+ (** At the start of the given function. *)
+ val at_start_of : Cil_types.kernel_function -> request
+
+ (** At the end of the given function.
+ @raises Kernel_function.No_statement if the function has no body. *)
+ val at_end_of : Cil_types.kernel_function -> request
+
+ (** Just before a statement is executed. *)
+ val before : Cil_types.stmt -> request
+
+ (** Just after a statement is executed. *)
+ val after : Cil_types.stmt -> request
+
+ (** Just before a statement or at the start of the analysis. *)
+ val before_kinstr : Cil_types.kinstr -> request
+
+
+ (** Callstack selection *)
+
+ (** Only consider the given callstack.
+ Replaces previous calls to [in_callstack] or [in_callstacks]. *)
+ val in_callstack : callstack -> request -> request
+
+ (** Only consider the callstacks from the given list.
+ Replaces previous calls to [in_callstack] or [in_callstacks]. *)
+ val in_callstacks : callstack list -> request -> request
+
+ (** Only consider callstacks satisfying the given predicate. Several filters
+ can be added. If callstacks are also selected with [in_callstack] or
+ [in_callstacks], only the selected callstacks will be filtered. *)
+ val filter_callstack : (callstack -> bool) -> request -> request
+
+
+ (** Working with callstacks *)
+
+ (** Returns the list of reachable callstacks from the given request.
+ An empty list is returned if the request control point has not been
+ reached by the analysis, or if no information has been saved at this point
+ (for instance with the -eva-no-results option).
+ Use [is_empty request] to distinguish these two cases. *)
+ val callstacks : request -> callstack list
+
+ (** Returns a list of subrequests for each reachable callstack from
+ the given request. *)
+ val by_callstack : request -> (callstack * request) list
+
+
+ (** State requests *)
+
+ (** Returns the list of expressions which have been inferred to be equal to
+ the given expression by the Equality domain. *)
+ val equality_class : Cil_types.exp -> request -> Cil_types.exp list result
+
+ (** Returns the Cvalue state. Error cases are converted into the bottom or top
+ cvalue state accordingly. *)
+ val get_cvalue_model : request -> Cvalue.Model.t
+
+ (** Returns the Cvalue model. *)
+ val get_cvalue_model_result : request -> Cvalue.Model.t result
+
+
+ (** Dependencies *)
+
+ (** Computes (an overapproximation of) the memory zones that must be read to
+ evaluate the given expression, including all adresses computations. *)
+ val expr_deps : Cil_types.exp -> request -> Locations.Zone.t
+
+ (** Computes (an overapproximation of) the memory zones that must be read to
+ evaluate the given lvalue, including the lvalue zone itself. *)
+ val lval_deps : Cil_types.lval -> request -> Locations.Zone.t
+
+ (** Computes (an overapproximation of) the memory zones that must be read to
+ evaluate the given lvalue, excluding the lvalue zone itself. *)
+ val address_deps : Cil_types.lval -> request -> Locations.Zone.t
+
+
+ (** Evaluation *)
+
+ (** Returns (an overapproximation of) the possible values of the variable. *)
+ val eval_var : Cil_types.varinfo -> request -> value evaluation
+
+ (** Returns (an overapproximation of) the possible values of the lvalue. *)
+ val eval_lval : Cil_types.lval -> request -> value evaluation
+
+ (** Returns (an overapproximation of) the possible values of the expression. *)
+ val eval_exp : Cil_types.exp -> request -> value evaluation
+
+
+ (** Returns (an overapproximation of) the possible addresses of the lvalue. *)
+ val eval_address : ?for_writing:bool ->
+ Cil_types.lval -> request -> address evaluation
+
+
+ (** Returns the kernel functions into which the given expression may evaluate.
+ If the callee expression doesn't always evaluate to a function, those
+ spurious values are ignored. If it always evaluate to a non-function value
+ then the returned list is empty.
+ Raises [Stdlib.Invalid_argument] if the callee expression is not an lvalue
+ without offset.
+ Also see [callee] for a function which applies directly on Call
+ statements. *)
+ val eval_callee : Cil_types.exp -> request -> Kernel_function.t list result
+
+
+ (** Evaluated values conversion *)
+
+ (** In all functions below, if the abstract value inferred by Eva does not fit
+ in the required type, [Error Top] is returned, as Top is the only possible
+ over-approximation of the request. *)
+
+ (** Converts the value into a singleton ocaml int. *)
+ val as_int : value evaluation -> int result
+
+ (** Converts the value into a singleton unbounded integer. *)
+ val as_integer : value evaluation -> Integer.t result
+
+ (** Converts the value into a floating point number. *)
+ val as_float : value evaluation -> float result
+
+ (** Converts the value into a C number abstraction. *)
+ val as_ival : value evaluation -> Ival.t result
+
+ (** Converts the value into a floating point abstraction. *)
+ val as_fval : value evaluation -> Fval.t result
+
+ (** Converts the value into a Cvalue abstraction. Converts error cases
+ into bottom and top values accordingly. *)
+ val as_cvalue : value evaluation -> Cvalue.V.t
+
+ (** Converts the value into a Cvalue abstraction. *)
+ val as_cvalue_result : value evaluation -> Cvalue.V.t result
+
+
+ (** Converts into a C location abstraction. *)
+ val as_location : address evaluation -> Locations.location result
+
+ (** Converts into a Zone. Error cases are converted into bottom or top zones
+ accordingly. *)
+ val as_zone: address evaluation -> Locations.Zone.t
+
+ (** Converts into a Zone result. *)
+ val as_zone_result : address evaluation -> Locations.Zone.t result
+
+
+ (** Evaluation properties *)
+
+ (** Returns whether the evaluated value is initialized or not. If the value have
+ been evaluated from a Cil expression, it is always initialized. *)
+ val is_initialized : value evaluation -> bool
+
+ (** Returns the set of alarms emitted during the evaluation. *)
+ val alarms : 'a evaluation -> Alarms.t list
+
+
+ (** Reachability *)
+
+ (** Returns true if there are no reachable states for the given request. *)
+ val is_empty : request -> bool
+
+ (** Returns true if an evaluation leads to bottom, i.e. if the given expression
+ or lvalue cannot be evaluated to a valid result for the given request. *)
+ val is_bottom : 'a evaluation -> bool
+
+ (** Returns true if the function has been analyzed. *)
+ val is_called : Cil_types.kernel_function -> bool
+
+ (** Returns true if the statement has been reached by the analysis. *)
+ val is_reachable : Cil_types.stmt -> bool
+
+ (** Returns true if the statement has been reached by the analysis, or if
+ the main function has been analyzed for [Kglobal]. *)
+ val is_reachable_kinstr : Cil_types.kinstr -> bool
+
+
+ (*** Callers / Callees / Callsites *)
+
+ (** Returns the list of inferred callers of the given function. *)
+ val callers : Cil_types.kernel_function -> Cil_types.kernel_function list
+
+ (** Returns the list of inferred callers, and for each of them, the list
+ of callsites (the call statements) inside. *)
+ val callsites : Cil_types.kernel_function ->
+ (Cil_types.kernel_function * Cil_types.stmt list) list
+
+
+ (** Returns the kernel functions called in the given statement.
+ If the callee expression doesn't always evaluate to a function, those
+ spurious values are ignored. If it always evaluate to a non-function value
+ then the returned list is empty.
+ Raises [Stdlib.Invalid_argument] if the statement is not a [Call]
+ instruction or a [Local_init] with [ConsInit] initializer. *)
+ val callee : Cil_types.stmt -> Kernel_function.t list
- val get_results: unit -> results
- val set_results: results -> unit
- val merge: results -> results -> results
- val change_callstacks:
- (Value_types.callstack -> Value_types.callstack) -> results -> results
end
-module Value_parameters: sig
+module Parameters: sig
+ (** Configuration of the analysis. *)
+
(** Returns the list (name, descr) of currently enabled abstract domains. *)
val enabled_domains: unit -> (string * string) list
@@ -46,36 +315,16 @@ module Value_parameters: sig
val use_global_value_partitioning: Cil_types.varinfo -> unit
end
-module Eval_terms: sig
- (** Evaluation environment, built by [env_annot]. *)
- type eval_env
-
- (** Dependencies needed to evaluate a term or a predicate. *)
- type logic_deps = Locations.Zone.t Cil_datatype.Logic_label.Map.t
-
- type labels_states = Db.Value.state Cil_datatype.Logic_label.Map.t
-
- val env_annot :
- ?c_labels:labels_states -> pre:Db.Value.state -> here:Db.Value.state ->
- unit -> eval_env
-
- (** [predicate_deps env p] computes the logic dependencies needed to evaluate
- [p] in the given evaluation environment [env].
- @return None on either an evaluation error or on unsupported construct. *)
- val predicate_deps: eval_env -> Cil_types.predicate -> logic_deps option
-end
-
-
-module Unit_tests: sig
- (** Runs the unit tests of Eva. *)
- val run: unit -> unit
-end
-
-(** Register special annotations to locally guide the partitioning of states
- performed by an Eva analysis. *)
module Eva_annotations: sig
+ (** Register special annotations to locally guide the Eva analysis:
+
+ - slevel annotations: "slevel default", "slevel merge" and "slevel i"
+ - loop unroll annotations: "loop unroll term"
+ - value partitioning annotations: "split term" and "merge term"
+ - subdivision annotations: "subdivide i"
+ *)
- (** Annotations tweaking the behavior of the -eva-slevel paramter. *)
+ (** Annotations tweaking the behavior of the -eva-slevel parameter. *)
type slevel_annotation =
| SlevelMerge (** Join all states separated by slevel. *)
| SlevelDefault (** Use the limit defined by -eva-slevel. *)
@@ -88,6 +337,7 @@ module Eva_annotations: sig
| UnrollFull (** Unroll amount defined by -eva-default-loop-unroll. *)
type split_kind = Static | Dynamic
+
type split_term =
| Expression of Cil_types.exp
| Predicate of Cil_types.predicate
@@ -99,10 +349,13 @@ module Eva_annotations: sig
| FlowMerge of split_term
(** Merge states separated by a previous split. *)
+ type allocation_kind = By_stack | Fresh | Fresh_weak | Imprecise
+
val get_slevel_annot : Cil_types.stmt -> slevel_annotation option
val get_unroll_annot : Cil_types.stmt -> unroll_annotation list
val get_flow_annot : Cil_types.stmt -> flow_annotation list
val get_subdivision_annot : Cil_types.stmt -> int list
+ val get_allocation: Cil_types.stmt -> allocation_kind
val add_slevel_annot : emitter:Emitter.t ->
Cil_types.stmt -> slevel_annotation -> unit
@@ -114,33 +367,105 @@ module Eva_annotations: sig
Cil_types.stmt -> int -> unit
end
-(** Analysis builtins for the cvalue domain, more efficient than the analysis
- of the C functions. See {builtins.mli} for more details. *)
+module Eval: sig
+ (** Can the results of a function call be cached with memexec? *)
+ type cacheable =
+ | Cacheable (** Functions whose result can be safely cached. *)
+ | NoCache (** Functions whose result should not be cached, but for
+ which the caller can still be cached. Typically,
+ functions printing something during the analysis. *)
+ | NoCacheCallers (** Functions for which neither the call, neither the
+ callers, can be cached. *)
+end
+
module Builtins: sig
+ (** Eva analysis builtins for the cvalue domain, more efficient than their
+ equivalent in C. *)
+
open Cil_types
exception Invalid_nb_of_args of int
exception Outside_builtin_possibilities
+ (* Signature of a builtin: type of the result, and type of the arguments. *)
type builtin_type = unit -> typ * typ list
- type cacheable = Cacheable | NoCache | NoCacheCallers
+
+ (** Can the results of a builtin be cached? See {eval.mli} for more details.*)
+ type cacheable = Eval.cacheable = Cacheable | NoCache | NoCacheCallers
type full_result = {
c_values: (Cvalue.V.t option * Cvalue.Model.t) list;
+ (** A list of results, consisting of:
+ - the value returned (ie. what is after the 'return' C keyword)
+ - the memory state after the function has been executed. *)
c_clobbered: Base.SetLattice.t;
+ (** An over-approximation of the bases in which addresses of local variables
+ might have been written *)
c_from: (Function_Froms.froms * Locations.Zone.t) option;
+ (** If not None, the froms of the function, and its sure outputs;
+ i.e. the dependencies of the result and of each zone written to. *)
}
+ (** The result of a builtin can be given in different forms. *)
type call_result =
| States of Cvalue.Model.t list
+ (** A disjunctive list of post-states at the end of the C function.
+ Can only be used if the C function does not write the address of local
+ variables, does not read other locations than the call arguments, and
+ does not write other locations than the result. *)
| Result of Cvalue.V.t list
+ (** A disjunctive list of resulting values. The specification is used to
+ compute the post-state, in which the result is replaced by the values
+ computed by the builtin. *)
| Full of full_result
+ (** See [full_result] type. *)
+ (** Type of a cvalue builtin, whose arguments are:
+ - the memory state at the beginning of the function call;
+ - the list of arguments of the function call. *)
type builtin = Cvalue.Model.t -> (exp * Cvalue.V.t) list -> call_result
+ (** [register_builtin name ?replace ?typ cacheable f] registers the function [f]
+ as a builtin to be used instead of the C function of name [name].
+ If [replace] is provided, the builtin is also used instead of the C function
+ of name [replace], unless option -eva-builtin-auto is disabled.
+ If [typ] is provided, consistency between the expected [typ] and the type of
+ the C function is checked before using the builtin.
+ The results of the builtin are cached according to [cacheable]. *)
val register_builtin:
- string -> ?replace:string -> ?typ:builtin_type -> cacheable ->
- builtin -> unit
+ string -> ?replace:string -> ?typ:builtin_type -> cacheable -> builtin -> unit
+ (** Has a builtin been registered with the given name? *)
val is_builtin: string -> bool
end
+
+module Eval_terms: sig
+ (** [annot_predicate_deps ~pre ~here p] computes the logic dependencies needed
+ to evaluate the predicate [p] in a code annotation in cvalue state [here],
+ in a function whose pre-state is [pre].
+ Returns None on either an evaluation error or on unsupported construct. *)
+ val annot_predicate_deps:
+ pre:Cvalue.Model.t -> here:Cvalue.Model.t ->
+ Cil_types.predicate -> Locations.Zone.t option
+end
+
+module Eva_results: sig
+ type results
+
+ val get_results: unit -> results
+ val set_results: results -> unit
+ val merge: results -> results -> results
+ val change_callstacks:
+ (Value_types.callstack -> Value_types.callstack) -> results -> results
+ (** Change the callstacks for the results for which this is meaningful.
+ For technical reasons, the top of the callstack must currently
+ be preserved. *)
+end
+
+module Unit_tests: sig
+ (** Currently tested by this module:
+ - semantics of sign values. *)
+
+ (** Runs some programmatic tests on Eva. *)
+ val run: unit -> unit
+end
diff --git a/src/plugins/value/alarmset.ml b/src/plugins/value/alarmset.ml
index e65daf45024938b8589daf977653a1725fbe491c..a401f52df2d32e92c9d92629b4c134a7ea710e91 100644
--- a/src/plugins/value/alarmset.ml
+++ b/src/plugins/value/alarmset.ml
@@ -180,7 +180,7 @@ let combine s1 s2 =
this alarm should be consistent. *)
try merge ~combine:true intersect s1 s2
with Inconsistent ->
- Value_parameters.fatal ~current:true
+ Self.fatal ~current:true
"Inconsistent combination of two alarm maps %a and %a."
pretty s1 pretty s2
@@ -207,7 +207,7 @@ let for_all test ~default = function
open CilE
-let emitter = Value_util.emitter
+let emitter = Eva_utils.emitter
(* Printer that shows additional information about temporaries *)
let local_printer: Printer.extensible_printer =
@@ -260,7 +260,7 @@ module Alarm_cache =
State_builder.Hashtbl (Alarm_key.Hashtbl) (Datatype.Unit)
(struct
let name = "Value_messages.Alarm_cache"
- let dependencies = [Db.Value.self]
+ let dependencies = [Self.state]
let size = 35
end)
@@ -272,8 +272,8 @@ let loc = function
| Cil_types.Kstmt s -> Cil_datatype.Stmt.loc s
let report_alarm ki annot msg =
- Value_util.alarm_report ~source:(fst (loc ki)) "@[%s.@ @[<hov 2>%a@]@]%t"
- msg pr_annot annot Value_util.pp_callstack
+ Eva_utils.alarm_report ~source:(fst (loc ki)) "@[%s.@ @[<hov 2>%a@]@]%t"
+ msg pr_annot annot Eva_utils.pp_callstack
let string_fkind = function
| Cil_types.FFloat -> "float"
@@ -372,7 +372,7 @@ let emit_alarm kinstr alarm (status:status) =
| Alarms.Invalid_bool _ ->
register_alarm "trap representation of a _Bool lvalue"
-let height_alarm = let open Value_util in function
+let height_alarm = let open Eva_utils in function
| Alarms.Division_by_zero e
| Alarms.Index_out_of_bound (e,_)
| Alarms.Invalid_pointer e
@@ -426,14 +426,14 @@ let emit_alarms kinstr map =
let list = M.bindings map in
let sorted_list = List.sort cmp list in
List.iter (fun (alarm, status) -> emit_alarm kinstr alarm status) sorted_list;
- if Alarm_cache.length () >= Value_parameters.StopAtNthAlarm.get ()
- then Value_parameters.abort "Stopping at nth alarm"
+ if Alarm_cache.length () >= Parameters.StopAtNthAlarm.get ()
+ then Self.abort "Stopping at nth alarm"
let emit kinstr = function
| Just map -> if not (M.is_empty map) then emit_alarms kinstr map
(* TODO: use GADT to avoid this assert false ? *)
| AllBut _ ->
- Value_parameters.abort ~current:true ~once:true
+ Self.abort ~current:true ~once:true
"All alarms may arise: \
abstract state too imprecise to continue the analysis."
diff --git a/src/plugins/value/api/general_requests.ml b/src/plugins/value/api/general_requests.ml
index 1b226d8e8d271a6d3b5a718d3b81e5c33d6c96e8..3ec95cd8ca8ce4bd76a267ceab94d7c6b53a088f 100644
--- a/src/plugins/value/api/general_requests.ml
+++ b/src/plugins/value/api/general_requests.ml
@@ -45,6 +45,7 @@ module ComputationState = struct
| Analysis.NotComputed -> `String "not_computed"
| Computing -> `String "computing"
| Computed -> `String "computed"
+ | Aborted -> `String "aborted"
end
let _computation_signal =
@@ -57,7 +58,7 @@ let _computation_signal =
()
let is_computed kf =
- Db.Value.is_computed () &&
+ Analysis.is_computed () &&
match kf with
| { fundec = Definition (fundec, _) } ->
Mark_noresults.should_memorize_function fundec
@@ -66,7 +67,7 @@ let is_computed kf =
module CallSite = Data.Jpair (Kernel_ast.Kf) (Kernel_ast.Stmt)
let callers kf =
- let list = !Db.Value.callers kf in
+ let list = Eva_results.callers kf in
List.concat (List.map (fun (kf, l) -> List.map (fun s -> kf, s) l) list)
let () = Request.register ~package
diff --git a/src/plugins/value/domains/abstract_domain.mli b/src/plugins/value/domains/abstract_domain.mli
index dcd64ed822256755b0a1ccbd1517ca56cc11a8b4..fcb5b3083f08585924b0555529a6a3f52c0c25bb 100644
--- a/src/plugins/value/domains/abstract_domain.mli
+++ b/src/plugins/value/domains/abstract_domain.mli
@@ -467,8 +467,8 @@ module type S = sig
include Reuse with type t := t
(** Category for the messages about the domain.
- Must be created through {!Value_parameters.register_category}. *)
- val log_category : Value_parameters.category
+ Must be created through {!Self.register_category}. *)
+ val log_category : Self.category
(** This function is called after the analysis. The argument is the state
computed at the return statement of the main function. The function can
diff --git a/src/plugins/value/domains/apron/apron_domain.ml b/src/plugins/value/domains/apron/apron_domain.ml
index 02df6dedf82d0602cd775295e6e4a5edf5d48c00..83ac36b2b23dd36a4fb14a428834a050423c8163 100644
--- a/src/plugins/value/domains/apron/apron_domain.ml
+++ b/src/plugins/value/domains/apron/apron_domain.ml
@@ -24,13 +24,13 @@ open Cil_types
open Eval
open Apron
-let dkey = Value_parameters.register_category "d-apron"
+let dkey = Self.register_category "d-apron"
let debug = false
let abort exclog =
let open Manager in
- Value_parameters.fatal
+ Self.fatal
"Apron manager error : %a in function %a.@.%s"
print_exc exclog.exn print_funid exclog.funid exclog.msg
@@ -151,7 +151,7 @@ let reduce eval expr range =
Since the denominator is not 1, the translation will fail later in
[scalar_to_mpzf]. Thus we should catch this case here. *)
if Interval.is_top interval then begin
- if debug then Value_parameters.result ~current:true ~once:true
+ if debug then Self.result ~current:true ~once:true
"imprecise expr %a" Apron.Texpr1.print_expr expr;
top ()
end
@@ -291,7 +291,7 @@ let rec constraint_expr eval oracle env expr positive =
let typ = translate_typ (Cil.unrollType typ) in
let e = Texpr1.Binop (Texpr1.Sub, e1'', e2'', typ, round) in
let expr = Texpr1.of_expr env e in
- let binop = Value_util.conv_comp binop in
+ let binop = Eva_utils.conv_comp binop in
let binop = if positive then binop else Abstract_interp.Comp.inv binop in
translate_relation expr typ binop
| _ -> raise (Out_of_Scope "constraint_expr not handled")
@@ -495,7 +495,7 @@ module Make (Man : Input) = struct
compute state expr (Cil.typeOf expr)
let extract_lval ~oracle:_ _context state lval typ _loc =
- let expr = Value_util.lval_to_exp lval in
+ let expr = Eva_utils.lval_to_exp lval in
compute state expr typ
let maybe_bottom state =
@@ -633,7 +633,7 @@ module Make (Man : Input) = struct
let start_call _stmt call recursion valuation state =
if recursion <> None
then
- Value_parameters.abort ~current:true
+ Self.abort ~current:true
"The binding to APRON domains does not support recursive calls.";
update valuation state >>- fun state ->
let eval = make_eval state in
diff --git a/src/plugins/value/domains/cvalue/builtins.ml b/src/plugins/value/domains/cvalue/builtins.ml
index 6dc0b78d39ac562b844c825419398cb11db4e7b5..ca1f01b8dfe1720690a23cf30ee7be3336f656cc 100644
--- a/src/plugins/value/domains/cvalue/builtins.ml
+++ b/src/plugins/value/domains/cvalue/builtins.ml
@@ -50,13 +50,13 @@ let builtins_table = Hashtbl.create 17
module Info = struct
let name = "Eva.Builtins.BuiltinsOverride"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Self.state ]
end
(** Set of functions overridden by a builtin. *)
module BuiltinsOverride = State_builder.Set_ref (Kernel_function.Set) (Info)
let register_builtin name ?replace ?typ cacheable f =
- Value_parameters.register_builtin name;
+ Parameters.register_builtin name;
let builtin = (name, f, cacheable, typ) in
Hashtbl.replace table name builtin;
match replace with
@@ -84,7 +84,7 @@ let builtin_names_and_replacements () =
let () =
Cmdline.run_after_configuring_stage
(fun () ->
- if Value_parameters.BuiltinsList.get () then begin
+ if Parameters.BuiltinsList.get () then begin
let stand_alone, replacements = builtin_names_and_replacements () in
Log.print_on_output
(fun fmt ->
@@ -152,8 +152,8 @@ let warn_builtin_override kf source bname =
if Kernel_function.is_definition kf && not internal
then
let fname = Kernel_function.get_name kf in
- Value_parameters.warning ~source ~once:true
- ~wkey:Value_parameters.wkey_builtins_override
+ Self.warning ~source ~once:true
+ ~wkey:Self.wkey_builtins_override
"function %s: definition will be overridden by %s"
fname (if fname = bname then "its builtin" else "builtin " ^ bname)
@@ -161,8 +161,8 @@ let prepare_builtin kf (name, builtin, cacheable, expected_typ) =
let source = fst (Kernel_function.get_location kf) in
if inconsistent_builtin_typ kf expected_typ
then
- Value_parameters.warning ~source ~once:true
- ~wkey:Value_parameters.wkey_builtins_override
+ Self.warning ~source ~once:true
+ ~wkey:Self.wkey_builtins_override
"The builtin %s will not be used for function %a of incompatible type.@ \
(got: %a)."
name Kernel_function.pretty kf
@@ -170,8 +170,8 @@ let prepare_builtin kf (name, builtin, cacheable, expected_typ) =
else
match find_builtin_specification kf with
| None ->
- Value_parameters.warning ~source ~once:true
- ~wkey:Value_parameters.wkey_builtins_missing_spec
+ Self.warning ~source ~once:true
+ ~wkey:Self.wkey_builtins_missing_spec
"The builtin for function %a will not be used, as its frama-c libc \
specification is not available."
Kernel_function.pretty kf
@@ -183,7 +183,7 @@ let prepare_builtin kf (name, builtin, cacheable, expected_typ) =
let prepare_builtins () =
BuiltinsOverride.clear ();
Hashtbl.clear builtins_table;
- let autobuiltins = Value_parameters.BuiltinsAuto.get () in
+ let autobuiltins = Parameters.BuiltinsAuto.get () in
(* Links kernel functions to the registered builtins. *)
Hashtbl.iter
(fun name (bname, f, cacheable, typ) ->
@@ -195,7 +195,7 @@ let prepare_builtins () =
with Not_found -> ())
table;
(* Overrides builtins attribution according to the -eva-builtin option. *)
- Value_parameters.BuiltinsOverrides.iter
+ Parameters.BuiltinsOverrides.iter
(fun (kf, name) ->
prepare_builtin kf (Hashtbl.find table (Option.get name)))
@@ -264,7 +264,7 @@ let apply_builtin (builtin:builtin) call ~pre ~post =
let arguments = compute_arguments call.arguments call.rest in
try
let call_result = builtin pre arguments in
- let call_stack = Value_util.call_stack () in
+ let call_stack = Eva_utils.call_stack () in
let froms =
match call_result with
| Full result -> `Builtin result.c_from
@@ -275,11 +275,11 @@ let apply_builtin (builtin:builtin) call ~pre ~post =
process_result call post call_result
with
| Invalid_nb_of_args n ->
- Value_parameters.abort ~current:true
+ Self.abort ~current:true
"Invalid number of arguments for builtin %a: %d expected, %d found"
Kernel_function.pretty call.kf n (List.length arguments)
| Outside_builtin_possibilities ->
- Value_parameters.fatal ~current:true
+ Self.fatal ~current:true
"Call to builtin %a failed" Kernel_function.pretty call.kf
(*
diff --git a/src/plugins/value/domains/cvalue/builtins.mli b/src/plugins/value/domains/cvalue/builtins.mli
index 353be4b52e81e4b3ef4ee8c9b868a391d0f7f2e8..ac9751b56a819843af15c3d267555c1966c253f9 100644
--- a/src/plugins/value/domains/cvalue/builtins.mli
+++ b/src/plugins/value/domains/cvalue/builtins.mli
@@ -20,6 +20,7 @@
(* *)
(**************************************************************************)
+[@@@ api_start]
(** Eva analysis builtins for the cvalue domain, more efficient than their
equivalent in C. *)
@@ -78,6 +79,7 @@ val register_builtin:
(** Has a builtin been registered with the given name? *)
val is_builtin: string -> bool
+[@@@ api_end]
(** Prepares the builtins to be used for an analysis. Must be called at the
beginning of each Eva analysis. Warns about builtins of incompatible types,
diff --git a/src/plugins/value/domains/cvalue/builtins_float.ml b/src/plugins/value/domains/cvalue/builtins_float.ml
index f950c308568da01b587e7d9c0a39c9b333214cc5..71dd8418d093a71a5a7ebcae5981b53eb51cb393 100644
--- a/src/plugins/value/domains/cvalue/builtins_float.ml
+++ b/src/plugins/value/domains/cvalue/builtins_float.ml
@@ -87,7 +87,7 @@ let arity1 name fk caml_fun _state actuals =
if Cvalue.V.is_bottom arg then begin
V.bottom
end else begin
- Value_parameters.result ~once:true ~current:true
+ Self.result ~once:true ~current:true
"function %s applied to address" name;
Cvalue.V.topify_arith_origin arg
end
diff --git a/src/plugins/value/domains/cvalue/builtins_malloc.ml b/src/plugins/value/domains/cvalue/builtins_malloc.ml
index dd27fe5eca32e88f8c9f79e491182deb7a6d29bb..437eb83a825846d5b40fdae1ec4f516e7152a787 100644
--- a/src/plugins/value/domains/cvalue/builtins_malloc.ml
+++ b/src/plugins/value/domains/cvalue/builtins_malloc.ml
@@ -25,12 +25,12 @@ open Abstract_interp
open Locations
open Cvalue
-let dkey = Value_parameters.register_category "malloc"
+let dkey = Self.register_category "malloc"
-let wkey_weak_alloc = Value_parameters.register_warn_category "malloc:weak"
-let () = Value_parameters.set_warn_status wkey_weak_alloc Log.Winactive
+let wkey_weak_alloc = Self.register_warn_category "malloc:weak"
+let () = Self.set_warn_status wkey_weak_alloc Log.Winactive
-let wkey_imprecise_alloc = Value_parameters.register_warn_category
+let wkey_imprecise_alloc = Self.register_warn_category
"malloc:imprecise"
(* ---------------------- Dynamically allocated bases ----------------------- *)
@@ -56,7 +56,7 @@ let () = Ast.add_monotonic_state Dynamic_Alloc_Bases.self
(* -------------------------- Auxiliary functions -------------------------- *)
let current_call_site () =
- match Value_util.call_stack () with
+ match Eva_utils.call_stack () with
| (_kf, Kstmt stmt) :: _ -> stmt
| _ -> Cil.dummyStmt
@@ -66,9 +66,9 @@ let current_call_site () =
these call site correspond to a different use of a malloc function,
so it is interesting to keep their bases separated. *)
let call_stack_no_wrappers () =
- let stack = Value_util.call_stack () in
+ let stack = Eva_utils.call_stack () in
assert (stack != []);
- let wrappers = Value_parameters.AllocFunctions.get() in
+ let wrappers = Parameters.AllocFunctions.get() in
let rec bottom_filter = function
| [] -> assert false
| [_] as stack -> stack (* Do not empty the stack completely *)
@@ -158,16 +158,16 @@ let create_new_var stack prefix type_base weak =
| Strong -> prefix
in
let name = Cabs2cil.fresh_global (base_name prefix stack) in
- Value_util.create_new_var name type_base
+ Eva_utils.create_new_var name type_base
(* This function adds a "_w" information to a variable. It should be used
when a variable becomes weak, and supposes that the variable has been
created by one of the functions of this module. Mutating variables name
is not a good idea in general, but we take the risk here. *)
let mutate_name_to_weak vi =
- Value_parameters.warning ~wkey:wkey_weak_alloc ~current:true ~once:false
+ Self.warning ~wkey:wkey_weak_alloc ~current:true ~once:false
"@[marking variable `%s' as weak@]%t" vi.vname
- Value_util.pp_callstack;
+ Eva_utils.pp_callstack;
try
let prefix, remainder =
Scanf.sscanf vi.vname "__%s@_%s" (fun s1 s2 -> (s1, s2))
@@ -299,7 +299,7 @@ let add_zeroes = add_v (V_Or_Uninitialized.initialized Cvalue.V.singleton_zero)
[returns_null]: if given, forces the result to consider/ignore the
possibility of failure, despite -eva-alloc-returns-null. *)
let wrap_fallible_alloc ?returns_null ret orig_state state_after_alloc =
- let default_returns_null = Value_parameters.AllocReturnsNull.get () in
+ let default_returns_null = Parameters.AllocReturnsNull.get () in
let returns_null = Option.value ~default:default_returns_null returns_null in
let success = Some ret, state_after_alloc in
if returns_null
@@ -325,10 +325,10 @@ let alloc_fresh weak deallocation prefix sizev _state =
let tsize = guess_intended_malloc_type stack sizev (weak = Strong) in
let type_base = type_from_nb_elems tsize in
let var = create_new_var stack prefix type_base weak in
- Value_parameters.result ~current:true ~once:true
+ Self.result ~current:true ~once:true
"@[allocating %svariable %a@]%t"
(if weak = Weak then "weak " else "") Printer.pp_varinfo var
- Value_util.pp_callstack;
+ Eva_utils.pp_callstack;
let size_char = Bit_utils.sizeofchar () in
(* Sizes are in bits *)
let min_alloc = Int.(pred (mul size_char tsize.min_bytes)) in
@@ -384,7 +384,7 @@ let create_weakest_base region =
TArray (Cil.charType, None, [])
in
let var = create_new_var stack "alloc" type_base Weak in
- Value_parameters.warning ~wkey:wkey_imprecise_alloc ~current:true ~once:true
+ Self.warning ~wkey:wkey_imprecise_alloc ~current:true ~once:true
"allocating a single weak variable for ALL dynamic allocations %s: %a"
(string_of_region region) Printer.pp_varinfo var;
let min_alloc = Int.minus_one in
@@ -434,7 +434,7 @@ let update_variable_validity ?(make_weak=false) base sizev =
if not (Int.equal variable_v.Base.min_alloc min_sure_bits) ||
not (Int.equal variable_v.Base.max_alloc max_valid_bits)
then begin
- Value_parameters.result ~dkey ~current:true ~once:false
+ Self.result ~dkey ~current:true ~once:false
"@[resizing variable `%a'@ (%a) to fit %a@]"
Printer.pp_varinfo vi
pp_validity (variable_v.Base.min_alloc, variable_v.Base.max_alloc)
@@ -447,11 +447,11 @@ let update_variable_validity ?(make_weak=false) base sizev =
Base.update_variable_validity variable_v
~weak:make_weak ~min_alloc:min_sure_bits ~max_alloc:max_valid_bits;
base, max_valid_bits
- | _ -> Value_parameters.fatal "base is not Allocated: %a" Base.pretty base
+ | _ -> Self.fatal "base is not Allocated: %a" Base.pretty base
let alloc_by_stack region prefix sizev state =
let stack = call_stack_no_wrappers () in
- let max_level = Value_parameters.MallocLevel.get () in
+ let max_level = Parameters.MallocLevel.get () in
let all_vars =
try MallocedByStack.find stack
with Not_found -> []
@@ -530,7 +530,7 @@ let calloc_builtin state args =
let size = Cvalue.V.mul nmemb sizev in
let size_ok = alloc_size_ok size in
if size_ok <> Alarmset.True then
- Value_util.warning_once_current
+ Eva_utils.warning_once_current
"calloc out of bounds: assert(nmemb * size <= SIZE_MAX)";
let c_values =
if size_ok = Alarmset.False (* size always overflows *)
@@ -635,11 +635,11 @@ let resolve_bases_to_free arg =
let free_aux state ~strong bases_to_remove =
(* TODO: reduce on arg if it is an lval *)
if strong then begin
- Value_parameters.debug ~current:true ~dkey "strong free on bases: %a"
+ Self.debug ~current:true ~dkey "strong free on bases: %a"
Base.Hptset.pretty bases_to_remove;
free ~exact:true bases_to_remove state
end else begin
- Value_parameters.debug ~current:true ~dkey "weak free on bases: %a"
+ Self.debug ~current:true ~dkey "weak free on bases: %a"
Base.Hptset.pretty bases_to_remove;
free ~exact:false bases_to_remove state
end
@@ -692,7 +692,7 @@ let free_automatic_bases stack state =
in
if Base.Hptset.is_empty bases_to_free then state
else begin
- Value_parameters.result ~current:true ~once:true
+ Self.result ~current:true ~once:true
"freeing automatic bases: %a" Base.Hptset.pretty bases_to_free;
let state', _changed = free_aux state ~strong:true bases_to_free in
(* TODO: propagate 'freed' bases for From? *)
@@ -738,7 +738,7 @@ let realloc_copy_one size ~src_state ~dst_state new_base b =
be created: if [Weak], convergence is ensured using a malloc builtin
that converges. If [Strong], a new base is created for each call. *)
let realloc_alloc_copy weak bases_to_realloc null_in_arg sizev state =
- Value_parameters.debug ~dkey "bases_to_realloc: %a"
+ Self.debug ~dkey "bases_to_realloc: %a"
Base.Hptset.pretty bases_to_realloc;
assert (not (Model.(equal state bottom || equal state top)));
let _size_valid, size_max = extract_size sizev in (* bytes everywhere *)
@@ -876,7 +876,7 @@ let check_leaked_malloced_bases state _ =
let alloced_bases = Dynamic_Alloc_Bases.get () in
Base_hptmap.iter
(fun base _ -> if check_if_base_is_leaked base state then
- Value_util.warning_once_current "memory leak detected for %a"
+ Eva_utils.warning_once_current "memory leak detected for %a"
Base.pretty base)
alloced_bases;
let c_clobbered = Base.SetLattice.bottom in
diff --git a/src/plugins/value/domains/cvalue/builtins_malloc.mli b/src/plugins/value/domains/cvalue/builtins_malloc.mli
index fecaa6ca53cc987d818429bd810e6671263d6097..9ec31b65b1c22a1d181b4a18037db57c75a7c3d4 100644
--- a/src/plugins/value/domains/cvalue/builtins_malloc.mli
+++ b/src/plugins/value/domains/cvalue/builtins_malloc.mli
@@ -36,7 +36,7 @@ val alloc_size_ok: Cvalue.V.t -> Alarmset.status
val free_automatic_bases: Value_types.Callstack.t -> Cvalue.Model.t -> Cvalue.Model.t
(** Performs the equivalent of [free] for each location that was allocated via
- [alloca()] in the current function (as per [Value_util.call_stack ()]).
+ [alloca()] in the current function (as per [Eva_utils.call_stack ()]).
This function must be called during finalization of a function call. *)
val freeable: Cvalue.V.t -> Abstract_interp.truth
diff --git a/src/plugins/value/domains/cvalue/builtins_memory.ml b/src/plugins/value/domains/cvalue/builtins_memory.ml
index 6309adb64fb18947419e58d53a12c82ffc069644..f3c5b263871f32e300683c9b107f675004849bf5 100644
--- a/src/plugins/value/domains/cvalue/builtins_memory.ml
+++ b/src/plugins/value/domains/cvalue/builtins_memory.ml
@@ -28,7 +28,7 @@ open Locations
let register_builtin name ?replace builtin =
Builtins.register_builtin name ?replace Cacheable builtin
-let dkey = Value_parameters.register_category "imprecision"
+let dkey = Self.register_category "imprecision"
let frama_C_is_base_aligned _state = function
| [_, x; _, y] ->
@@ -58,7 +58,7 @@ let frama_c_offset _state = function
let offsets = Location_Bytes.fold_i (fun _b -> Ival.join) x acc in
Cvalue.V.inject_ival offsets
with Abstract_interp.Error_Top ->
- Value_parameters.error ~current:true
+ Self.error ~current:true
"Builtin Frama_C_offset is applied to a value not \
guaranteed to be an address";
Cvalue.V.top_int
@@ -75,7 +75,7 @@ exception Indeterminate of V_Or_Uninitialized.t
(* Called by the [memcpy] builtin. Warns when the offsetmap contains
an indeterminate value, when the imprecision category is enabled *)
let memcpy_check_indeterminate_offsetmap offsm =
- if Value_parameters.is_debug_key_enabled dkey then
+ if Self.is_debug_key_enabled dkey then
try
let aux_offset _ (v, _, _) =
match v with
@@ -84,15 +84,15 @@ let memcpy_check_indeterminate_offsetmap offsm =
in
V_Offsetmap.iter aux_offset offsm
with Indeterminate v ->
- Value_parameters.debug ~current:true ~dkey ~once:true
+ Self.debug ~current:true ~dkey ~once:true
"@[In memcpy@ builtin:@ precise@ copy of@ indeterminate@ values %a@]%t"
- V_Or_Uninitialized.pretty v Value_util.pp_callstack
+ V_Or_Uninitialized.pretty v Eva_utils.pp_callstack
(* Create a dependency [\from arg_n] where n is the nth argument of the
currently called function. *)
let deps_nth_arg n =
let open Function_Froms in
- let (kf,_) = List.hd (Value_util.call_stack()) in
+ let (kf,_) = List.hd (Eva_utils.call_stack()) in
try
let vi = List.nth (Kernel_function.get_formals kf) n in
Deps.add_data_dep Deps.bottom (Locations.zone_of_varinfo vi)
@@ -101,7 +101,7 @@ let deps_nth_arg n =
let frama_c_memcpy state actuals =
let compute (_exp_dst,dst_bytes) (_exp_src,src_bytes) (_exp_size,size) =
- let plevel = Value_parameters.ArrayPrecisionLevel.get() in
+ let plevel = Parameters.ArrayPrecisionLevel.get() in
let size =
try Cvalue.V.project_ival size
with Cvalue.V.Not_based_on_null -> Ival.top (* TODO: use size_t *)
@@ -229,7 +229,7 @@ let frama_c_memcpy state actuals =
raise (Memcpy_result (state,c_from,sure_zone))
with
| Abstract_interp.Not_less_than ->
- Value_parameters.debug ~dkey ~once:true
+ Self.debug ~dkey ~once:true
~current:true "In memcpy builtin: too many sizes to enumerate, \
possible loss of precision";
(* Too many slices in the size. We read the entire range
@@ -240,9 +240,9 @@ let frama_c_memcpy state actuals =
in
begin match v with
| V_Or_Uninitialized.C_init_noesc _ -> ()
- | _ -> Value_parameters.result ~dkey ~current:true ~once:true
+ | _ -> Self.result ~dkey ~current:true ~once:true
"@[In memcpy@ builtin:@ imprecise@ copy of@ indeterminate@ values@]%t"
- Value_util.pp_callstack
+ Eva_utils.pp_callstack
end;
let updated_state =
Cvalue.Model.add_indeterminate_binding
@@ -600,10 +600,10 @@ let frama_c_memset state actuals =
in
try frama_c_memset_precise state dst v (exp_size, size)
with ImpreciseMemset reason ->
- Value_parameters.debug ~dkey ~current:true
+ Self.debug ~dkey ~current:true
"Call to builtin precise_memset(%a) failed; %a%t"
- Value_util.pretty_actuals actuals pretty_imprecise_memset_reason reason
- Value_util.pp_callstack;
+ Eva_utils.pretty_actuals actuals pretty_imprecise_memset_reason reason
+ Eva_utils.pp_callstack;
frama_c_memset_imprecise state dst v size
end
| _ -> raise (Builtins.Invalid_nb_of_args 3)
@@ -627,9 +627,9 @@ let frama_c_interval_split _state actuals =
with
| Cvalue.V.Not_based_on_null
| Ival.Not_Singleton_Int ->
- Value_parameters.abort
+ Self.abort
"Invalid call to Frama_C_interval_split%a"
- Value_util.pretty_actuals actuals
+ Eva_utils.pretty_actuals actuals
end
| _ -> raise (Builtins.Invalid_nb_of_args 2)
diff --git a/src/plugins/value/domains/cvalue/builtins_misc.ml b/src/plugins/value/domains/cvalue/builtins_misc.ml
index c4112b70f8b004939b2a5bf9e0aa890e5c36e15d..3beae3f9189abdfb3a94ef851ecec4fe33db794a 100644
--- a/src/plugins/value/domains/cvalue/builtins_misc.ml
+++ b/src/plugins/value/domains/cvalue/builtins_misc.ml
@@ -20,7 +20,7 @@
(* *)
(**************************************************************************)
-open Value_util
+open Eva_utils
let frama_C_assert state actuals =
diff --git a/src/plugins/value/domains/cvalue/builtins_print_c.ml b/src/plugins/value/domains/cvalue/builtins_print_c.ml
index d73d76bde382eb383e0563235a544ff8801e88e9..2b2b2b0707be66c0ed425fefe3fbeb22f236dfaa 100644
--- a/src/plugins/value/domains/cvalue/builtins_print_c.ml
+++ b/src/plugins/value/domains/cvalue/builtins_print_c.ml
@@ -216,7 +216,7 @@ let value_pretty cas print_ampamp lv s_bytes fmt v =
else find_typ_assignment candidate_types
with
| V.Not_based_on_null -> ()
- | Not_found -> Value_parameters.result "Unknown size %d for %s" s_bytes lv
+ | Not_found -> Self.result "Unknown size %d for %s" s_bytes lv
let value_uninit_pretty cas prampamp lv s fmt = function
@@ -282,8 +282,8 @@ let state_pretty cas fmt m =
with
| Z.Overflow
| Too_large_to_enumerate ->
- Value_parameters.warning "base %s too large, \
- will not print it" name
+ Self.warning "base %s too large, \
+ will not print it" name
end
| _ -> ())
m
@@ -323,14 +323,14 @@ let pretty_state_as_c_assignments fmt state =
let frama_c_dump_assert state _actuals =
- Value_parameters.result ~current:true "Frama_C_dump_assert_each called:@\n(%a)@\nEnd of Frama_C_dump_assert_each output"
+ Self.result ~current:true "Frama_C_dump_assert_each called:@\n(%a)@\nEnd of Frama_C_dump_assert_each output"
pretty_state_as_c_assert state;
Builtins.States [state]
let () = Builtins.register_builtin "Frama_C_dump_assert_each" NoCache frama_c_dump_assert
let frama_c_dump_assignments state _actuals =
- Value_parameters.result ~current:true "Frama_C_dump_assignment_each called:@\n%a@\nEnd of Frama_C_dump_assignment_each output"
+ Self.result ~current:true "Frama_C_dump_assignment_each called:@\n%a@\nEnd of Frama_C_dump_assignment_each output"
pretty_state_as_c_assignments state;
Builtins.States [state]
diff --git a/src/plugins/value/domains/cvalue/builtins_split.ml b/src/plugins/value/domains/cvalue/builtins_split.ml
index 1b628c5876a293f554206e1ffe05906b7d8eab6f..b7dbebcb9e52c0973e83c0159a046062888b2236 100644
--- a/src/plugins/value/domains/cvalue/builtins_split.ml
+++ b/src/plugins/value/domains/cvalue/builtins_split.ml
@@ -65,7 +65,7 @@ let () =
let warning warn s =
if warn then
- Value_parameters.result ~current:true ~once:true s
+ Self.result ~current:true ~once:true s
else
Pretty_utils.nullprintf s
@@ -182,13 +182,13 @@ let aux_split f state = function
in
f ~warn:true lv state max_card
with V.Not_based_on_null | Ival.Not_Singleton_Int ->
- Value_parameters.warning ~current:true ~once:true
+ Self.warning ~current:true ~once:true
"Cannot use non-constant split level %a" V.pretty card;
[state]
in
Builtins.States states
| _ ->
- Value_parameters.warning ~current:true ~once:true
+ Self.warning ~current:true ~once:true
"Cannot interpret split directive. Ignoring";
Builtins.States [state]
diff --git a/src/plugins/value/domains/cvalue/builtins_watchpoint.ml b/src/plugins/value/domains/cvalue/builtins_watchpoint.ml
index 9b74eeb416fd416cf0dd14aae0fea58150fb4d0c..bb788c492440aac52f159b6691ac5c399d951897 100644
--- a/src/plugins/value/domains/cvalue/builtins_watchpoint.ml
+++ b/src/plugins/value/domains/cvalue/builtins_watchpoint.ml
@@ -113,18 +113,18 @@ let watch_hook (stmt, _callstack, states) =
in
if watching
then begin
- Value_parameters.feedback ~once:true ~current:true
+ Self.feedback ~once:true ~current:true
"Watchpoint: %a %a%t"
Printer.pp_exp name
V.pretty vs
- Value_util.pp_callstack;
+ Eva_utils.pp_callstack;
if Integer.is_zero current ||
(Cil_datatype.Stmt.Set.mem stmt set)
then ()
else
let current = Integer.pred current in
if Integer.is_zero current then
- Value_parameters.abort "Watchpoint builtin: countdown to zero";
+ Self.abort "Watchpoint builtin: countdown to zero";
w.remaining_count <- current;
w.stmts <- Cil_datatype.Stmt.Set.add stmt set;
end)
diff --git a/src/plugins/value/domains/cvalue/cvalue_domain.ml b/src/plugins/value/domains/cvalue/cvalue_domain.ml
index cd9f4376d4ef60a4c288d294eb3bca0ec1345b88..30f759714e8cfc17ba224a5d46b96a26c68e2ddf 100644
--- a/src/plugins/value/domains/cvalue/cvalue_domain.ml
+++ b/src/plugins/value/domains/cvalue/cvalue_domain.ml
@@ -22,7 +22,7 @@
open Eval
-let dkey_card = Value_parameters.register_category "cardinal"
+let dkey_card = Self.register_category "cardinal"
module Model = struct
@@ -161,7 +161,7 @@ module State = struct
type state = Model.t * Locals_scoping.clobbered_set
- let log_category = Value_parameters.dkey_cvalue_domain
+ let log_category = Self.dkey_cvalue_domain
include Datatype.Make_with_collections (
struct
@@ -405,7 +405,7 @@ module State = struct
let bind_local state vi =
let b = Base.of_varinfo vi in
let offsm =
- if Value_parameters.InitializedLocals.get () then
+ if Parameters.InitializedLocals.get () then
let v = Cvalue.(V_Or_Uninitialized.initialized V.top_int) in
match Cvalue.V_Offsetmap.size_from_validity (Base.validity b) with
| `Bottom -> assert false
@@ -451,7 +451,7 @@ module State = struct
module Storage =
State_builder.Ref (Datatype.Bool)
(struct
- let dependencies = [Db.Value.self]
+ let dependencies = [Self.state]
let name = name ^ ".Storage"
let default () = false
end)
@@ -525,7 +525,7 @@ module State = struct
if Cvalue.Model.is_reachable fst_values
&& not (Cvalue.Model.is_top fst_values)
then begin
- let print_cardinal = Value_parameters.is_debug_key_enabled dkey_card in
+ let print_cardinal = Self.is_debug_key_enabled dkey_card in
let estimate =
if print_cardinal
then Cvalue.Model.cardinal_estimate values
@@ -551,22 +551,22 @@ module State = struct
| _ -> ())
(fun fmt -> Cvalue.Model.pretty_filter fmt values outs) in
match fmt with
- | None -> Value_parameters.printf
- ~dkey:Value_parameters.dkey_final_states ~header "%t" body
+ | None -> Self.printf
+ ~dkey:Self.dkey_final_states ~header "%t" body
| Some fmt -> Format.fprintf fmt "%t@.%t@," header body
end
with Kernel_function.No_Statement -> ()
let display_results () =
- Value_parameters.result "====== VALUES COMPUTED ======";
+ Self.result "====== VALUES COMPUTED ======";
Eva_dynamic.Callgraph.iter_in_rev_order display;
- Value_parameters.result "%t" Value_perf.display
+ Self.result "%t" Eva_perf.display
let post_analysis _state =
- if Value_parameters.ForceValues.get ()
- && Value_parameters.verbose_atleast 1
+ if Parameters.ForceValues.get ()
+ && Self.verbose_atleast 1
&& Plugin.is_present "inout"
- then Value_parameters.ForceValues.output display_results
+ then Parameters.ForceValues.output display_results
end
let () = Db.Value.display := (fun fmt kf -> State.display ~fmt kf)
diff --git a/src/plugins/value/domains/cvalue/cvalue_init.ml b/src/plugins/value/domains/cvalue/cvalue_init.ml
index 4faee93725faf82ad6fc7c6ee1cf5f88ca332381..67dd09d472b0a611fd210fc8eb3dbd570fcb6f52 100644
--- a/src/plugins/value/domains/cvalue/cvalue_init.ml
+++ b/src/plugins/value/domains/cvalue/cvalue_init.ml
@@ -25,7 +25,7 @@
open Cil_types
open Locations
-let dkey = Value_parameters.register_category "initial-state"
+let dkey = Self.register_category "initial-state"
let add_initialized state loc v =
Cvalue.Model.add_binding ~exact:true state loc v
@@ -45,8 +45,8 @@ let make_well hidden_base state loc =
let warn_unknown_size_aux pp v (messt, t) =
- Value_parameters.warning ~once:true ~current:true
- ~wkey:Value_parameters.wkey_unknown_size
+ Self.warning ~once:true ~current:true
+ ~wkey:Self.wkey_unknown_size
"@[during initialization@ of %a,@ size of@ type '%a'@ cannot be@ computed@ \
(%s)@]" pp v Printer.pp_typ t messt
@@ -62,7 +62,7 @@ type validity_hidden_base =
let stdlib_attribute = Attr ("fc_stdlib_generated", [])
let create_hidden_base ~libc ~valid ~hidden_var_name ~name_desc pointed_typ =
- let hidden_var = Value_util.create_new_var hidden_var_name pointed_typ in
+ let hidden_var = Eva_utils.create_new_var hidden_var_name pointed_typ in
if libc
then hidden_var.vattr <- Cil.addAttribute stdlib_attribute hidden_var.vattr;
hidden_var.vdescr <- Some name_desc;
@@ -75,7 +75,7 @@ let create_hidden_base ~libc ~valid ~hidden_var_name ~name_desc pointed_typ =
in
match validity with
| Base.Known (a,b)
- when not (Value_parameters.AllocatedContextValid.get ()) ->
+ when not (Parameters.AllocatedContextValid.get ()) ->
(* Weaken validity, because the created variables are not supposed
to be valid *)
(match valid with
@@ -86,8 +86,8 @@ let create_hidden_base ~libc ~valid ~hidden_var_name ~name_desc pointed_typ =
| UnknownValidity -> Base.Unknown (a, None, b)
)
| Base.Unknown _ -> (* Unknown validity is caused by strange type *)
- Value_parameters.result ~dkey "creating variable %s with imprecise \
- size (type %a)" hidden_var_name Printer.pp_typ pointed_typ;
+ Self.result ~dkey "creating variable %s with imprecise \
+ size (type %a)" hidden_var_name Printer.pp_typ pointed_typ;
validity
| Base.Empty | Base.Known _ | Base.Invalid -> validity
| Base.Variable _ -> (* should never happen (validity_from_type cannot
@@ -100,7 +100,7 @@ let reject_empty_struct b offset typ =
match Cil.unrollType typ with
| TComp (ci, _) ->
if ci.cfields = Some [] && not (Cil.acceptEmptyCompinfo ()) then
- Value_parameters.abort ~current:true
+ Self.abort ~current:true
"@[empty %ss@ are unsupported@ (type '%a',@ location %a%a)@ \
in C99 (only allowed on GCC/MSVC machdep).@ Aborting.@]"
(if ci.cstruct then "struct" else "union")
@@ -131,11 +131,11 @@ let initialize_var_using_type varinfo state =
| TFun _ -> state
| TPtr (typ, _) as full_typ
- when depth <= Value_parameters.AutomaticContextMaxDepth.get () ->
+ when depth <= Parameters.AutomaticContextMaxDepth.get () ->
let attr = Cil.typeAttrs full_typ in
let libc = Cil.is_in_libc varinfo.vattr in
let context_max_width =
- Value_parameters.AutomaticContextMaxWidth.get ()
+ Parameters.AutomaticContextMaxWidth.get ()
in begin
match Cil.isVoidType typ, Cil.isFunctionType typ with
| false, false -> (* non-void, non-function *)
@@ -176,7 +176,7 @@ let initialize_var_using_type varinfo state =
in
let value = Cvalue.V.inject hidden_base (Ival.zero) in
let value =
- if Value_parameters.AllocatedContextValid.get ()
+ if Parameters.AllocatedContextValid.get ()
then value
else Cvalue.V.join Cvalue.V.singleton_zero value
in
@@ -204,7 +204,7 @@ let initialize_var_using_type varinfo state =
let state = ref state in
let typ = Cil.unrollType typ in
let max_precise_size =
- Value_parameters.AutomaticContextMaxWidth.get ()
+ Parameters.AutomaticContextMaxWidth.get ()
in
let locs = ref [] in
for i = 0 to min psize (pred max_precise_size) do
@@ -272,7 +272,7 @@ let initialize_var_using_type varinfo state =
(* We have probably initialized a struct with different fields.
We must perform offsetmap copies, that are slower *)
if nb_fields * psize >= 5000 then
- Value_parameters.result ~once:true ~current:true
+ Self.result ~once:true ~current:true
"Initializing a complex array of %d elements. This may \
take some time" size;
let loc = ref last_loc.loc in
@@ -288,7 +288,7 @@ let initialize_var_using_type varinfo state =
!state
with
| Cil.LenOfArray cause ->
- Value_parameters.result ~once:true ~current:true
+ Self.result ~once:true ~current:true
"problem with array size (%a), assuming 0"
Cil.pp_incorrect_array_length cause;
(* This is either a flexible array member (for which Cil
@@ -326,7 +326,7 @@ let initialize_var_using_type varinfo state =
(* Union of arithmetic types *)
bind_entire_loc Cvalue.V.top_int
- | TPtr _ when Value_parameters.AllocatedContextValid.get () ->
+ | TPtr _ when Parameters.AllocatedContextValid.get () ->
(* deep pointers map to NULL in this case *)
bind_entire_loc Cvalue.V.singleton_zero
@@ -340,7 +340,7 @@ let initialize_var_using_type varinfo state =
Cabs2cil.fresh_global ("WELL_"^name)
in
let hidden_var =
- Value_util.create_new_var hidden_var_name Cil.charType
+ Eva_utils.create_new_var hidden_var_name Cil.charType
in
hidden_var.vdescr <- Some (name_desc^"_WELL");
let validity = Base.Known (Integer.zero, Bit_utils.max_bit_address ()) in
diff --git a/src/plugins/value/domains/cvalue/cvalue_specification.ml b/src/plugins/value/domains/cvalue/cvalue_specification.ml
index fdedf776bb94083159a966c7c9085b5e978c1ccd..be23b77474b7124896818d02592919dfee9aa936 100644
--- a/src/plugins/value/domains/cvalue/cvalue_specification.ml
+++ b/src/plugins/value/domains/cvalue/cvalue_specification.ml
@@ -66,8 +66,8 @@ let check_from pre_state asgn assigns_zone from found_froms =
let found_direct_deps = found_deps.Function_Froms.Deps.data in
let found_indirect_deps = found_deps.Function_Froms.Deps.indirect in
let res_for_unknown txt =
- Value_parameters.debug "found_direct deps %a stated_direct_deps %a \
- found_indirect_deps %a stated_indirect_deps %a"
+ Self.debug "found_direct deps %a stated_direct_deps %a \
+ found_indirect_deps %a stated_indirect_deps %a"
Zone.pretty found_direct_deps Zone.pretty stated_direct_deps
Zone.pretty found_indirect_deps Zone.pretty stated_indirect_deps;
"unknown (cannot validate "^txt^" dependencies)",
@@ -84,12 +84,12 @@ let check_from pre_state asgn assigns_zone from found_froms =
(* Display the message as result/warning depending on [status] *)
let msg_status status ?current ?once ?source fmt =
if status = Alarmset.True then
- if Value_parameters.ValShowProgress.get ()
- then Value_parameters.result ?current ?once ?source fmt
- else Value_parameters.result ?current ?once ?source ~level:2 fmt
+ if Parameters.ValShowProgress.get ()
+ then Self.result ?current ?once ?source fmt
+ else Self.result ?current ?once ?source ~level:2 fmt
else
- Value_parameters.warning
- ~wkey:Value_parameters.wkey_alarm ?current ?once ?source fmt
+ Self.warning
+ ~wkey:Self.wkey_alarm ?current ?once ?source fmt
let pp_bhv fmt b =
if not (Cil.is_default_behavior b)
@@ -139,7 +139,7 @@ let check_fct_assigns kf ab ~pre_state found_froms =
let status_txt, vstatus, status =
if not (Zone.is_included outputs assigns_union)
then (
- Value_parameters.debug
+ Self.debug
"@[Cannot prove assigns clause@]@ \
@[<2>found assigns: %a@]@ @[<2>stated assigns: %a@]"
Zone.pretty outputs Zone.pretty assigns_union;
@@ -151,10 +151,10 @@ let check_fct_assigns kf ab ~pre_state found_froms =
(pp_header kf) b
status_txt
pp_activity activity
- Value_util.pp_callstack;
+ Eva_utils.pp_callstack;
let emit_status ppt status =
Property_status.emit
- ~distinct:true Value_util.emitter ~hyps:[] ppt status
+ ~distinct:true Eva_utils.emitter ~hyps:[] ppt status
in
emit_status ip status;
(* Now, checks the individual froms. *)
@@ -172,7 +172,7 @@ let check_fct_assigns kf ab ~pre_state found_froms =
(pp_header kf) b
status_txt
pp_activity activity
- Value_util.pp_callstack;
+ Eva_utils.pp_callstack;
emit_status ip (conv_status status)
in
List.iter2 check_from assigns_deps assigns_zones)
diff --git a/src/plugins/value/domains/cvalue/cvalue_transfer.ml b/src/plugins/value/domains/cvalue/cvalue_transfer.ml
index 59adfa1136bf985c422ea254a7eacaf2c33c9e01..467228d64dbac95363a3359f809f992cd05d62b6 100644
--- a/src/plugins/value/domains/cvalue/cvalue_transfer.ml
+++ b/src/plugins/value/domains/cvalue/cvalue_transfer.ml
@@ -98,10 +98,10 @@ let write_abstract_value state (lval, loc, typ) assigned_value =
in
match loc.Locations.loc with
| Locations.Location_Bits.Top (Base.SetLattice.Top, orig) ->
- Value_parameters.result
+ Self.result
"State before degeneration:@\n======%a@\n======="
Cvalue.Model.pretty state;
- Value_parameters.fatal ~current:true
+ Self.fatal ~current:true
"writing at a completely unknown address@[%a@].@\nAborting."
Origin.pretty_as_reason orig
| _ ->
@@ -205,7 +205,7 @@ let actualize_formals state arguments =
let start_call _stmt call _recursion _valuation state =
let with_formals = actualize_formals state call.arguments in
- let stack_with_call = Value_util.call_stack () in
+ let stack_with_call = Eva_utils.call_stack () in
Db.Value.Call_Value_Callbacks.apply (with_formals, stack_with_call);
`Value with_formals
@@ -214,7 +214,7 @@ let finalize_call stmt call _recursion ~pre:_ ~post:state =
To minimize computations, only do it for function definitions. *)
let state' =
if Kernel_function.is_definition call.kf then
- let stack = (call.kf, Kstmt stmt) :: (Value_util.call_stack ()) in
+ let stack = (call.kf, Kstmt stmt) :: (Eva_utils.call_stack ()) in
Builtins_malloc.free_automatic_bases stack state
else state
in
diff --git a/src/plugins/value/domains/cvalue/warn.ml b/src/plugins/value/domains/cvalue/warn.ml
index 9f931b0f3c75ab5baf3b8161250f52f08d613e2a..ef7ecfa432145ceb7b3802ebdd382652a28f10ba 100644
--- a/src/plugins/value/domains/cvalue/warn.ml
+++ b/src/plugins/value/domains/cvalue/warn.ml
@@ -27,14 +27,14 @@ let warn_locals_escape is_block fundec k locals =
let pretty_base = Base.pretty in
let pretty_block fmt = Pretty_utils.pp_cond is_block fmt "a block of " in
let sv = fundec.svar in
- Value_parameters.warning
- ~wkey:Value_parameters.wkey_locals_escaping
+ Self.warning
+ ~wkey:Self.wkey_locals_escaping
~current:true ~once:true
"locals %a escaping the scope of %t%a through %a"
Base.Hptset.pretty locals pretty_block Printer.pp_varinfo sv pretty_base k
let warn_imprecise_lval_read lv loc contents =
- if Value_parameters.verbose_atleast 1 then
+ if Self.verbose_atleast 1 then
let pretty_gm fmt s =
let s = Base.SetLattice.(inject (O.remove Base.null s)) in
Base.SetLattice.pretty fmt s
@@ -62,7 +62,7 @@ let warn_imprecise_lval_read lv loc contents =
in
if something_to_warn
then
- Value_parameters.result ~current:true ~once:true
+ Self.result ~current:true ~once:true
"@[<v>@[Reading left-value %a.@]@ %t%t%t@]"
Printer.pp_lval lv
(fun fmt ->
@@ -91,7 +91,7 @@ let warn_imprecise_lval_read lv loc contents =
pretty_param_b param
Origin.pretty orig
| Location_Bytes.Map _ -> ())
- Value_util.pp_callstack
+ Eva_utils.pp_callstack
(* Auxiliary function for [do_assign] below. When computing the
result of [lv = exp], warn if the evaluation of [exp] results in
@@ -100,7 +100,7 @@ let warn_imprecise_lval_read lv loc contents =
let warn_right_exp_imprecision lv loc_lv exp_val =
match exp_val with
| Location_Bytes.Top(_topparam,origin) ->
- Value_parameters.result ~once:true ~current:true
+ Self.result ~once:true ~current:true
"@[<v>@[Assigning imprecise value to %a%t.@]%a%t@]"
Printer.pp_lval lv
(fun fmt -> match lv with
@@ -114,7 +114,7 @@ let warn_right_exp_imprecision lv loc_lv exp_val =
"@ @[The imprecision@ originates@ from@ %a@]"
Origin.pretty org)
origin
- Value_util.pp_callstack
+ Eva_utils.pp_callstack
| Location_Bytes.Map _ -> ()
diff --git a/src/plugins/value/domains/domain_builder.ml b/src/plugins/value/domains/domain_builder.ml
index 24a1b2effb86cb319813b9cbdc7826ba8f50e04f..8505c33b87e56f450f9079ec43491aa8d4682982 100644
--- a/src/plugins/value/domains/domain_builder.ml
+++ b/src/plugins/value/domains/domain_builder.ml
@@ -106,7 +106,7 @@ module Make_Minimal
include Domain
- let log_category = Value_parameters.register_category ("d-" ^ name)
+ let log_category = Self.register_category ("d-" ^ name)
type value = Value.t
type location = Location.location
@@ -132,7 +132,7 @@ module Make_Minimal
| None -> `Value (Domain.start_call stmt (simplify_call call) state)
| Some _ ->
(* TODO *)
- Value_parameters.abort
+ Self.abort
"The domain %s does not support recursive call." Domain.name
let finalize_call stmt call recursion ~pre ~post =
@@ -217,7 +217,7 @@ module Complete_Simple_Cvalue (Domain: Simpler_domains.Simple_Cvalue)
(Domain) (struct let module_name = Domain.name end)
: Datatype.S_with_collections with type t := t)
- let log_category = Value_parameters.register_category ("d-" ^ name)
+ let log_category = Self.register_category ("d-" ^ name)
type value = Cvalue.V.t
type location = Precise_locs.precise_location
@@ -258,7 +258,7 @@ module Complete_Simple_Cvalue (Domain: Simpler_domains.Simple_Cvalue)
| None -> `Value (Domain.start_call stmt call (record valuation) state)
| Some _ ->
(* TODO *)
- Value_parameters.abort
+ Self.abort
"The domain %s does not support recursive call." Domain.name
let finalize_call stmt call recursion =
diff --git a/src/plugins/value/domains/domain_product.ml b/src/plugins/value/domains/domain_product.ml
index 3069d90b752a5aee918f5169532921b8d364e705..ef11c0a44abca4a45b4e6d432b7dac742d89e624 100644
--- a/src/plugins/value/domains/domain_product.ml
+++ b/src/plugins/value/domains/domain_product.ml
@@ -24,7 +24,7 @@ open Eval
let counter = ref 0
-let product_category = Value_parameters.register_category "domain_product"
+let product_category = Self.register_category "domain_product"
module Make
(Value: Abstract_value.S)
@@ -174,7 +174,7 @@ module Make
let show_expr =
let (|-) f g = fun fmt exp -> f fmt exp; g fmt exp in
let show_expr_one_side category name show_expr = fun fmt exp ->
- if Value_parameters.is_debug_key_enabled category
+ if Self.is_debug_key_enabled category
then Format.fprintf fmt "@,@]@[<v># %s: @[<hov>%a@]" name show_expr exp
in
let right_log = Right.log_category
@@ -204,7 +204,7 @@ module Make
let pretty =
let print_one_side fmt category name dump state =
- if Value_parameters.is_debug_key_enabled category
+ if Self.is_debug_key_enabled category
then Format.fprintf fmt "# %s:@ @[<hv>%a@]@ " name dump state
in
let right_log = Right.log_category
diff --git a/src/plugins/value/domains/domain_product.mli b/src/plugins/value/domains/domain_product.mli
index 49ca1c6a62b2deb26400060de5a11a55929c08a8..8e5a3b9de23e5dcbe01d18549d5a9338d8304414 100644
--- a/src/plugins/value/domains/domain_product.mli
+++ b/src/plugins/value/domains/domain_product.mli
@@ -20,7 +20,7 @@
(* *)
(**************************************************************************)
-val product_category: Value_parameters.category
+val product_category: Self.category
module Make
(Value: Abstract_value.S)
diff --git a/src/plugins/value/domains/domain_store.ml b/src/plugins/value/domains/domain_store.ml
index 716bb29bb57404a8f56baf0ed268f1e1684ff6d9..4bfa88ec212360792cd1fc8eba6764be6d32585b 100644
--- a/src/plugins/value/domains/domain_store.ml
+++ b/src/plugins/value/domains/domain_store.ml
@@ -58,9 +58,9 @@ module Make (Domain: InputDomain) = struct
(* This module stores the resulting states of an Eva analysis. They depends on
the set of parameters with which the analysis has been run, and must be
cleared each time one of this parameter is changed. Thus, the tables of
- this module have as dependencies Db.Value.self, the internal state of Eva
+ this module have as dependencies Self.state, the internal state of Eva
(all parameters of Eva are added as codependencies of this state). *)
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Self.state ]
let size = 16
module type Ref = sig
diff --git a/src/plugins/value/domains/equality/equality.ml b/src/plugins/value/domains/equality/equality.ml
index b7c63e5652b137666a50f6cb7350054c6e413e4a..f8ed19d95c233a51eb22d380640b7748169ff440 100644
--- a/src/plugins/value/domains/equality/equality.ml
+++ b/src/plugins/value/domains/equality/equality.ml
@@ -184,12 +184,12 @@ module Set = struct
let pick_representative set =
let choose elt (current, height) =
let elt = HCE.to_exp elt in
- let h = Value_util.height_expr elt in
+ let h = Eva_utils.height_expr elt in
if h < height then (elt, h) else (current, height)
in
let head = HCESet.choose set in
let current = HCE.to_exp head in
- let height = Value_util.height_expr current in
+ let height = Eva_utils.height_expr current in
fst (HCESet.fold choose (HCESet.remove head set) (current, height))
(* Binds the terms of the [equality] to [equality] in the [map].
diff --git a/src/plugins/value/domains/equality/equality.mli b/src/plugins/value/domains/equality/equality.mli
index 87ef746f453b17bf99e21e3dfe59610aa01c1a0c..3e92e268f8a59aa7c7364038d0d3ed9e74f985f5 100644
--- a/src/plugins/value/domains/equality/equality.mli
+++ b/src/plugins/value/domains/equality/equality.mli
@@ -88,6 +88,8 @@ module Equality : sig
val choose: t -> elt
(** Return the representative of the equality. *)
+ val elements: t -> elt list
+ (** Returns the list of all elements of the given set. *)
end
type equality = Equality.t
diff --git a/src/plugins/value/domains/equality/equality_domain.ml b/src/plugins/value/domains/equality/equality_domain.ml
index 9d0299b703635aeb4146832b5564dc7638a6d753..7c1a455765424073106a36061a5e5c54add67251 100644
--- a/src/plugins/value/domains/equality/equality_domain.ml
+++ b/src/plugins/value/domains/equality/equality_domain.ml
@@ -30,8 +30,8 @@ type call_init_state =
let call_init_state kf =
let str =
- try Value_parameters.EqualityCallFunction.find kf
- with Not_found -> Value_parameters.EqualityCall.get ()
+ try Parameters.EqualityCallFunction.find kf
+ with Not_found -> Parameters.EqualityCall.get ()
in
match str with
| "all" -> ISCaller
@@ -39,7 +39,7 @@ let call_init_state kf =
| "none" -> ISEmpty
| _ -> assert false
-let dkey = Value_parameters.register_category "d-equality"
+let dkey = Self.register_category "d-equality"
open Hcexprs
@@ -123,9 +123,6 @@ module Internal = struct
let log_category = dkey
- type equalities = Equality.Set.t
- let project (t, _, _) = t
-
let pretty fmt (eqs, _, _) = Equality.Set.pretty fmt eqs
let pretty_debug fmt (eqs, deps, modified) =
@@ -170,6 +167,10 @@ end
module Store = Domain_builder.Complete (Internal)
+type t = Internal.t
+let key = Store.key
+let project (t, _, _) = t
+
(* ------------------------- Abstract Domain -------------------------------- *)
@@ -316,7 +317,7 @@ module Make
| Var vi, NoOffset -> Locations.zone_of_varinfo vi
| _ ->
let expr = Cil.dummy_exp (Lval lv) in
- Value_util.zone_of_expr (find_loc valuation) expr
+ Eva_utils.zone_of_expr (find_loc valuation) expr
in
Deps.add lval zone deps
@@ -397,9 +398,9 @@ module Make
let right_expr = Cil.constFold true right_expr in
try
let indirect_left_zone =
- Value_util.indirect_zone_of_lval (find_loc valuation) left_value.lval
+ Eva_utils.indirect_zone_of_lval (find_loc valuation) left_value.lval
and right_zone =
- Value_util.zone_of_expr (find_loc valuation) right_expr
+ Eva_utils.zone_of_expr (find_loc valuation) right_expr
in
(* After an assignment lv = e, the equality [lv == eq] holds iff the value
of [e] and the location of [lv] are not modified by the assignment,
diff --git a/src/plugins/value/domains/equality/equality_domain.mli b/src/plugins/value/domains/equality/equality_domain.mli
index 7adbbb6f9e6e6e267581c54e845c2e79271e92e1..b903b6e82d0b3e4a8112ac574d4307bb32bab492 100644
--- a/src/plugins/value/domains/equality/equality_domain.mli
+++ b/src/plugins/value/domains/equality/equality_domain.mli
@@ -31,12 +31,14 @@ type call_init_state =
| ISEmpty (** completely empty state, without impact on Memexec. *)
+type t
+val key: t Abstract_domain.key
+val project: t -> Equality.Set.t
+
module Make (Value : Abstract.Value.External) : sig
include Abstract_domain.Leaf with type value = Value.t
and type location = Precise_locs.precise_location
+ and type state = t
val pretty_debug : Format.formatter -> t -> unit
-
- type equalities
- val project : t -> equalities
end
diff --git a/src/plugins/value/domains/gauges/gauges_domain.ml b/src/plugins/value/domains/gauges/gauges_domain.ml
index c51111bbd3f1a9f4c8f8806c203b9e4a15971928..4960424c455ed43c95643543a65a100c340bff8e 100644
--- a/src/plugins/value/domains/gauges/gauges_domain.ml
+++ b/src/plugins/value/domains/gauges/gauges_domain.ml
@@ -1108,7 +1108,7 @@ module G = struct
end
-let dkey = Value_parameters.register_category "d-gauges"
+let dkey = Self.register_category "d-gauges"
module D : Abstract_domain.Leaf
with type state = G.t
diff --git a/src/plugins/value/domains/hcexprs.ml b/src/plugins/value/domains/hcexprs.ml
index 71de08879f34c3415bd168aedcb211dd42d8d070..5b2bea75710e3e0b806e810c1578f3da4445660f 100644
--- a/src/plugins/value/domains/hcexprs.ml
+++ b/src/plugins/value/domains/hcexprs.ml
@@ -125,7 +125,7 @@ module HCE = struct
let to_exp h = match get h with
| E e -> e
- | LV lv -> Value_util.lval_to_exp lv
+ | LV lv -> Eva_utils.lval_to_exp lv
let to_lval h = match get h with
| E _ -> None
@@ -138,7 +138,7 @@ module HCE = struct
let replace kind ~late ~heir h = match get h with
| E e ->
let e = E.replace kind ~late ~heir e in
- if Value_util.height_expr e > height_limit
+ if Eva_utils.height_expr e > height_limit
then raise NonExchangeable
else of_exp e
| LV lval -> if Lval.equal lval late then of_exp heir else h
diff --git a/src/plugins/value/domains/inout_domain.ml b/src/plugins/value/domains/inout_domain.ml
index 946b34461d059ea28d0c5cbc00a844d411cb9ef8..7b6714b25a39a7def5e05ea561da1803aea1ee77 100644
--- a/src/plugins/value/domains/inout_domain.ml
+++ b/src/plugins/value/domains/inout_domain.ml
@@ -162,7 +162,7 @@ module Transfer = struct
in [e] into locations. Nothing is written, the memory locations
present in [e] are read. *)
let effects_assume to_z e =
- let inputs = Value_util.zone_of_expr to_z e in
+ let inputs = Eva_utils.zone_of_expr to_z e in
{
over_outputs = Zone.bottom;
over_inputs = inputs;
@@ -173,8 +173,8 @@ module Transfer = struct
(* Effects of an assigment [lv = e]. [to_z] converts the lvalues present
in [lv] and [e] into locations. *)
let effects_assign to_z lv e =
- let inputs_e = Value_util.zone_of_expr to_z e in
- let inputs_lv = Value_util.indirect_zone_of_lval to_z lv.Eval.lval in
+ let inputs_e = Eva_utils.zone_of_expr to_z e in
+ let inputs_lv = Eva_utils.indirect_zone_of_lval to_z lv.Eval.lval in
let inputs = Zone.join inputs_e inputs_lv in
let outputs =
Precise_locs.enumerate_valid_bits Locations.Write lv.Eval.lloc
@@ -222,7 +222,7 @@ module D
include Domain_builder.Complete (LatticeInout)
- let log_category = Value_parameters.register_category "d-inout"
+ let log_category = Self.register_category "d-inout"
let enter_scope _kind _vars state = state
let leave_scope _kf vars state = Transfer.remove_variables vars state
diff --git a/src/plugins/value/domains/multidim_domain.ml b/src/plugins/value/domains/multidim_domain.ml
index 90abdbb2f7bdaa9de528c55ec6cdeedf28a25d4b..f7c5a591d739519341fa3c3a7505617fa820eff2 100644
--- a/src/plugins/value/domains/multidim_domain.ml
+++ b/src/plugins/value/domains/multidim_domain.ml
@@ -23,7 +23,7 @@
open Cil_types
open Eval
-let dkey = Value_parameters.register_category "d-multidim"
+let dkey = Self.register_category "d-multidim"
let map_to_singleton map =
let aux base offset = function
@@ -451,7 +451,7 @@ struct
let start_call _stmt call recursion valuation state =
if recursion <> None
then
- Value_parameters.abort ~current:true
+ Self.abort ~current:true
"The multidim domain does not support recursive calls yet";
let oracle = make_oracle valuation in
let bind state arg =
diff --git a/src/plugins/value/domains/numerors/numerors_domain.ml b/src/plugins/value/domains/numerors/numerors_domain.ml
index eaec32fbb9f436c37b2580dddcd6f49e080fdfa3..b5ed4180e900c0a8fc648f54fca9d220fef63cfd 100644
--- a/src/plugins/value/domains/numerors/numerors_domain.ml
+++ b/src/plugins/value/domains/numerors/numerors_domain.ml
@@ -86,10 +86,10 @@ module Domain = struct
include Simple_memory.Make_Domain (Name) (Numerors_Value)
let post_analysis f =
- if not (Value_parameters.NumerorsLogFile.is_empty ()) then
+ if not (Parameters.NumerorsLogFile.is_empty ()) then
match f with
| `Value _ ->
- let log = open_out (Value_parameters.NumerorsLogFile.get ():>string) in
+ let log = open_out (Parameters.NumerorsLogFile.get ():>string) in
let fmt = Format.formatter_of_out_channel log in
List.iter (fun f -> f fmt ()) !Numerors_Value.dprint_callstack ;
close_out log
diff --git a/src/plugins/value/domains/octagons.ml b/src/plugins/value/domains/octagons.ml
index f44600a260c0819b362f33a4e16e58a5059e9484..ac289e408eb1716fb403acef038920c94d2f2b4d 100644
--- a/src/plugins/value/domains/octagons.ml
+++ b/src/plugins/value/domains/octagons.ml
@@ -42,7 +42,7 @@ let saturate_octagons = true
option. In this case, the analysis of each function starts with an empty
state, and the relations inferred in a function are not propagated back to
the caller either. *)
-let intraprocedural () = not (Value_parameters.OctagonCall.get ())
+let intraprocedural () = not (Parameters.OctagonCall.get ())
(* -------------------------------------------------------------------------- *)
(* Basic types: pair of variables and Ival.t *)
@@ -319,7 +319,7 @@ module Rewriting = struct
|| (Ival.contains_zero ival && Ival.contains_non_zero ival)
then []
else
- let comp = Value_util.conv_comp binop in
+ let comp = Eva_utils.conv_comp binop in
let comp =
if Ival.is_zero ival then Abstract_interp.Comp.inv comp else comp
in
@@ -382,7 +382,7 @@ module Rewriting = struct
else ival, overflow_alarms typ expr ival
| BinOp ((Lt | Gt | Le | Ge | Eq as binop), e1, e2, _typ)
when Cil.isIntegralType (Cil.typeOf e1) ->
- let comp = Value_util.conv_comp binop in
+ let comp = Eva_utils.conv_comp binop in
(* Evaluate [e1 - e2] and compare the resulting interval to the interval
for which the comparison [e1 # e2] holds. *)
let range = comparison_range comp in
@@ -732,7 +732,7 @@ module State = struct
Format.fprintf fmt "@[%a@]" Octagons.pretty octagons
end)
- let log_category = Value_parameters.register_category "d-octagon"
+ let log_category = Self.register_category "d-octagon"
let pretty_debug fmt { octagons; intervals; relations } =
Format.fprintf fmt "@[<v> Octagons: %a@; Intervals: %a@; Relations: %a@]"
@@ -758,7 +758,7 @@ module State = struct
if Octagons.for_all check_octagon t.octagons
then t
else
- Value_parameters.abort
+ Self.abort
"Incorrect octagon state computed by function %s:@ %a"
msg pretty_debug t
diff --git a/src/plugins/value/domains/offsm_domain.ml b/src/plugins/value/domains/offsm_domain.ml
index 235d98ba9909b29645acd381f1348c3704a07685..a05dc30f5f2c7bd14b3285e4a1a4606f81a9d68f 100644
--- a/src/plugins/value/domains/offsm_domain.ml
+++ b/src/plugins/value/domains/offsm_domain.ml
@@ -30,7 +30,7 @@ let store_redundant = false
unsoundnesses in the domain through testing, because many more expressions
end up being handled. *)
-let dkey = Value_parameters.register_category "d-bitwise"
+let dkey = Self.register_category "d-bitwise"
module Default_offsetmap = struct
open Cvalue
diff --git a/src/plugins/value/domains/printer_domain.ml b/src/plugins/value/domains/printer_domain.ml
index 0be9f3fb61d85bd030a328335354874f295f89e8..e899e14a70d41870f7ffe1dc9281c2a0ff1366fa 100644
--- a/src/plugins/value/domains/printer_domain.ml
+++ b/src/plugins/value/domains/printer_domain.ml
@@ -27,7 +27,7 @@ open Eval
what goes through it. *)
module Simple : Simpler_domains.Simple_Cvalue = struct
- let feedback = Value_parameters.feedback ~current:true
+ let feedback = Self.feedback ~current:true
(* --- Datatype --- *)
diff --git a/src/plugins/value/domains/simple_memory.ml b/src/plugins/value/domains/simple_memory.ml
index fa09688306a1d5aff2d62bad75740884394c2306..70a77a3f08af796ea1dd34ffa65c0c65b3579f7c 100644
--- a/src/plugins/value/domains/simple_memory.ml
+++ b/src/plugins/value/domains/simple_memory.ml
@@ -196,7 +196,7 @@ module Make_Domain (Info: sig val name: string end) (Value: Value) = struct
type location = Precise_locs.precise_location
type origin
- let log_category = Value_parameters.register_category ("d-" ^ Info.name)
+ let log_category = Self.register_category ("d-" ^ Info.name)
let widen _kf _stmt = widen
diff --git a/src/plugins/value/domains/symbolic_locs.ml b/src/plugins/value/domains/symbolic_locs.ml
index b787c686b12e2763f8988d99d1d28ab7bee6a3dc..04fd2a0c8d7dafe5f561c2f94bc50e4efce8e573 100644
--- a/src/plugins/value/domains/symbolic_locs.ml
+++ b/src/plugins/value/domains/symbolic_locs.ml
@@ -24,7 +24,7 @@ open Cil_types
open Eval
open Locations
-let dkey = Value_parameters.register_category "d-symblocs"
+let dkey = Self.register_category "d-symblocs"
module K = Hcexprs
module V = Cvalue.V (* TODO: functorize (with locations too ?) *)
@@ -275,7 +275,7 @@ module Memory = struct
let z =
try K2Z.find k state.zones
with Not_found ->
- Value_parameters.abort "Missing zone for %a@.%a"
+ Self.abort "Missing zone for %a@.%a"
K.HCE.pretty k pretty state
in
add_deps k v z acc
@@ -379,7 +379,7 @@ module Memory = struct
else
let k = K.HCE.of_lval lv in
let z_lv = Precise_locs.enumerate_valid_bits Locations.Read (get_z lv) in
- let z_lv_indirect = Value_util.indirect_zone_of_lval get_z lv in
+ let z_lv_indirect = Eva_utils.indirect_zone_of_lval get_z lv in
if Locations.Zone.intersects z_lv z_lv_indirect then
(* The location of [lv] intersects with the zones needed to compute
itself, the equality would not hold. *)
@@ -395,7 +395,7 @@ module Memory = struct
state
else
let k = K.HCE.of_exp e in
- let z = Value_util.zone_of_expr get_z e in
+ let z = Eva_utils.zone_of_expr get_z e in
add_key k v z state
let find k state =
@@ -489,7 +489,7 @@ module D : Abstract_domain.Leaf
| `Value loc -> loc.Eval.loc
in
if Precise_locs.(equal_loc loc_top r) then
- Value_parameters.fatal "Unknown location for %a" Printer.pp_lval lv
+ Self.fatal "Unknown location for %a" Printer.pp_lval lv
else r
let get_val valuation = fun lv ->
diff --git a/src/plugins/value/domains/taint_domain.ml b/src/plugins/value/domains/taint_domain.ml
index c4ab2b01ecc7fbb25a10f70ab7e85aab6ee9046d..7a3fa0157042c13468bfbb6509ed69296b3d3b82 100644
--- a/src/plugins/value/domains/taint_domain.ml
+++ b/src/plugins/value/domains/taint_domain.ml
@@ -41,13 +41,13 @@ type taint = {
dependent_call: bool;
}
-let dkey = Value_parameters.register_category "d-taint"
+let dkey = Self.register_category "d-taint"
(* Debug key to also include [assume_stmts] in the output of the
Frama_C_domain_show_each directive. *)
-let dkey_debug = Value_parameters.register_category "d-taint-debug"
+let dkey_debug = Self.register_category "d-taint-debug"
-let wkey = Value_parameters.register_warn_category "taint"
+let wkey = Self.register_warn_category "taint"
module LatticeTaint = struct
@@ -93,7 +93,7 @@ module LatticeTaint = struct
let equal = Datatype.from_compare
let pretty fmt t =
- if Value_parameters.is_debug_key_enabled dkey_debug
+ if Self.is_debug_key_enabled dkey_debug
then pp_state fmt t
else pp_locs_only fmt t
@@ -199,13 +199,13 @@ module TransferTaint = struct
let loc = Precise_locs.imprecise_location ploc in
Locations.enumerate_valid_bits Write loc
in
- let lv_indirect_zone = Value_util.indirect_zone_of_lval to_loc lval in
+ let lv_indirect_zone = Eva_utils.indirect_zone_of_lval to_loc lval in
lv_zone, lv_indirect_zone, singleton
(* Propagates data- and control-taints for an assignement [lval = exp]. *)
let assign_aux lval exp to_loc state =
let lv_zone, lv_indirect_zone, singleton = compute_zones lval to_loc in
- let exp_zone = Value_util.zone_of_expr to_loc exp in
+ let exp_zone = Eva_utils.zone_of_expr to_loc exp in
(* [lv] becomes data-tainted if a memory location on which the value of
[exp] depends on is data-tainted. *)
let data_tainted = Zone.intersects state.locs_data exp_zone in
@@ -246,7 +246,7 @@ module TransferTaint = struct
let state = filter_active_tainted_assumes stmt state in
(* Add [stmt] as assume statement in [state] as soon as [exp] is tainted. *)
let to_loc = loc_of_lval valuation in
- let exp_zone = Value_util.zone_of_expr to_loc exp in
+ let exp_zone = Eva_utils.zone_of_expr to_loc exp in
let state =
if not state.dependent_call && LatticeTaint.intersects state exp_zone
then { state with assume_stmts = Stmt.Set.add stmt state.assume_stmts; }
@@ -279,7 +279,7 @@ module TransferTaint = struct
let show_expr valuation state fmt exp =
let to_loc = loc_of_lval valuation in
- let exp_zone = Value_util.zone_of_expr to_loc exp in
+ let exp_zone = Eva_utils.zone_of_expr to_loc exp in
Format.fprintf fmt "%B" (LatticeTaint.intersects state exp_zone)
end
@@ -507,14 +507,14 @@ module TaintLogic = struct
let taint_term taint term =
match eval_tlval_zone cvalue_env term with
| None ->
- Value_parameters.warning ~wkey ~current:true ~once:true
+ Self.warning ~wkey ~current:true ~once:true
"Cannot evaluate term %a in taint annotation; ignoring."
Printer.pp_term term;
taint
| Some (under, over) ->
if not (Zone.equal under over)
then
- Value_parameters.warning ~wkey ~current:true ~once:true
+ Self.warning ~wkey ~current:true ~once:true
"Cannot precisely evaluate term %a in taint annotation; \
over-approximating."
Printer.pp_term term;
@@ -568,7 +568,7 @@ let interpret_taint_logic
in
Abstract.Dom.set key taint state
| _ ->
- Value_parameters.warning ~wkey ~current:true ~once:true
+ Self.warning ~wkey ~current:true ~once:true
"Invalid taint annotation %a; ignoring."
Printer.pp_extended extension;
state
diff --git a/src/plugins/value/domains/traces_domain.ml b/src/plugins/value/domains/traces_domain.ml
index 88ccb4412c530ed6713e09d7eac5739dbddbde61..4231ef461f95a2f126fcbb1b4e4ea7877635b3c3 100644
--- a/src/plugins/value/domains/traces_domain.ml
+++ b/src/plugins/value/domains/traces_domain.ml
@@ -665,7 +665,7 @@ module Traces = struct
let join c1 c2 =
if c1.call_declared_function <> c2.call_declared_function
then
- Value_parameters.fatal "@[<hv>@[At the same time inside and outside a function call:@]@ %a@ %a@]"
+ Self.fatal "@[<hv>@[At the same time inside and outside a function call:@]@ %a@ %a@]"
pretty c1 pretty c2
else
match view c1, view c2 with
@@ -728,7 +728,7 @@ module Traces = struct
else
Format.printf "@[<hv 2>@[widen %a@]@]@." Stmt.pretty_sid stmt'
end;
- if not (Value_parameters.TracesUnrollLoop.get ())
+ if not (Parameters.TracesUnrollLoop.get ())
then c2
else begin
match c2.current with
@@ -954,7 +954,7 @@ let rec stmts_of_cfg cfg current var_map locals return_exp acc =
Some (exp1, n1', b1, n2')
| _ -> None in
match is_while with
- | None -> Value_parameters.not_yet_implemented "Traces_domain: Loop without condition"
+ | None -> Self.not_yet_implemented "Traces_domain: Loop without condition"
| Some(exp,nloop,bloop,n2) ->
let exp = subst_in_exp var_map exp in
let exp = if bloop then exp else Cil.new_exp ~loc:dummy_loc (UnOp(LNot,exp,Cil.intType)) in
@@ -972,7 +972,7 @@ let rec stmts_of_cfg cfg current var_map locals return_exp acc =
| _ -> None in
let stmt =
match is_if with
- | None -> Value_parameters.not_yet_implemented "Traces_domain: switch at node(%a)" Node.pretty current
+ | None -> Self.not_yet_implemented "Traces_domain: switch at node(%a)" Node.pretty current
| Some(exp,n1,n2) ->
let exp = subst_in_exp var_map exp in
let block1 = Cil.mkBlock (stmts_of_cfg cfg n1 var_map locals return_exp []) in
@@ -1007,7 +1007,7 @@ let project_of_cfg vreturn s =
in
let locals = ref [] in
let graph = match s.current with | Base (_,g) -> g | _ ->
- Value_parameters.fatal "Traces.project_of_cfg used with open loops" in
+ Self.fatal "Traces.project_of_cfg used with open loops" in
let stmts = stmts_of_cfg graph s.start var_map locals return_equal [] in
let sbody = Cil.mkBlock (stmts@[return_stmt]) in
sbody.Cil_types.blocals <- blocals;
@@ -1095,7 +1095,7 @@ module D = struct
include Domain_builder.Complete (Traces)
- let log_category = Value_parameters.register_category "d-traces"
+ let log_category = Self.register_category "d-traces"
let assign ki lv e _v _valuation state =
let trans = Assign (ki, lv.Eval.lval, lv.Eval.ltyp, e) in
@@ -1172,7 +1172,7 @@ module D = struct
let enter_loop stmt state =
let state = Traces.add_trans state (Msg "enter_loop") in
- let state = if not (Value_parameters.TracesUnrollLoop.get ())
+ let state = if not (Parameters.TracesUnrollLoop.get ())
then Traces.add_loop stmt state
else { state with current = UnrollLoop(stmt,state.current) } in
state
@@ -1183,7 +1183,7 @@ module D = struct
| UnrollLoop(_,_) -> state
| OpenLoop(stmt,s,last,_,g,l) ->
let last = Graph.join last g in
- let last = if Value_parameters.TracesUnifyLoop.get () then
+ let last = if Parameters.TracesUnifyLoop.get () then
let s',old_last = Stmt.Hashtbl.find state.all_loop_start stmt in
let last = Graph.join last old_last in
assert (Node.equal s s');
@@ -1203,7 +1203,7 @@ module D = struct
| OpenLoop(stmt,s,last,old_current_node,g,current) ->
assert (Stmt.equal stmt stmt');
let state = { state with current } in
- let last = if Value_parameters.TracesUnifyLoop.get () then
+ let last = if Parameters.TracesUnifyLoop.get () then
let s',old_last = Stmt.Hashtbl.find state.all_loop_start stmt in
let last = Graph.join last old_last in
assert (Node.equal s s');
@@ -1233,7 +1233,7 @@ module D = struct
let output_dot filename state =
let out = open_out filename in
- Value_parameters.feedback ~dkey:log_category "@[Output dot produced to %s.@]" filename;
+ Self.feedback ~dkey:log_category "@[Output dot produced to %s.@]" filename;
(** *)
GraphDot.output_graph out (complete_graph (snd (Traces.get_current state)));
close_out out
@@ -1245,18 +1245,18 @@ module D = struct
| _ -> assert false in
let header fmt = Format.fprintf fmt "Trace domains:" in
let body = Bottom.pretty Traces.pretty in
- Value_parameters.printf ~dkey:log_category ~header " @[%a@]" body state;
- if Value_parameters.TracesProject.get () ||
- not (Value_parameters.TracesDot.is_default ()) then
+ Self.printf ~dkey:log_category ~header " @[%a@]" body state;
+ if Parameters.TracesProject.get () ||
+ not (Parameters.TracesDot.is_default ()) then
match state with
| `Bottom ->
- Value_parameters.failure "The trace is Bottom can't generate code"
+ Self.failure "The trace is Bottom can't generate code"
| `Value state when state ==Traces.top ->
- Value_parameters.failure "The trace is TOP can't generate code"
+ Self.failure "The trace is TOP can't generate code"
| `Value state ->
- if not (Value_parameters.TracesDot.is_default ())
- then output_dot (Value_parameters.TracesDot.get ():>string) state;
- if Value_parameters.TracesProject.get ()
+ if not (Parameters.TracesDot.is_default ())
+ then output_dot (Parameters.TracesDot.get ():>string) state;
+ if Parameters.TracesProject.get ()
then project_of_cfg return_exp state
end
diff --git a/src/plugins/value/domains/unit_domain.ml b/src/plugins/value/domains/unit_domain.ml
index c3cd5e92da66ddd98fac632153e762e7cfdf52a9..67832adc9449864f073bc6efe263e9ae4af2500e 100644
--- a/src/plugins/value/domains/unit_domain.ml
+++ b/src/plugins/value/domains/unit_domain.ml
@@ -20,7 +20,7 @@
(* *)
(**************************************************************************)
-let log_key = Value_parameters.register_category "unit-domain"
+let log_key = Self.register_category "unit-domain"
module Static = struct
module D = struct
diff --git a/src/plugins/value/engine/abstractions.ml b/src/plugins/value/engine/abstractions.ml
index daa7f30ed177b799041c8f00eb03aca7927a6fa5..0aa29d3ba549e9afddcdfff1b73c593d24f53bb4 100644
--- a/src/plugins/value/engine/abstractions.ml
+++ b/src/plugins/value/engine/abstractions.ml
@@ -76,7 +76,7 @@ module Config = struct
let register_domain_option ~name ~experimental ~descr =
let descr = if experimental then "Experimental. " ^ descr else descr in
- Value_parameters.register_domain ~name ~descr
+ Parameters.register_domain ~name ~descr
let register ~name ~descr ?(experimental=false) ?(priority=0) abstraction =
register_domain_option ~name ~experimental ~descr;
@@ -97,9 +97,9 @@ module Config = struct
(main, Domain_mode.Mode.all) :: mode
in
let add config (name, make) =
- let enabled = Value_parameters.Domains.mem name in
+ let enabled = Parameters.Domains.mem name in
try
- let mode = Value_parameters.DomainsFunction.find name in
+ let mode = Parameters.DomainsFunction.find name in
let mode = if enabled then add_main_mode mode else mode in
add (make (), Some mode) config
with Not_found ->
@@ -240,7 +240,7 @@ module Internal_Value = struct
end)
let void_value () =
- Value_parameters.fatal
+ Self.fatal
"Cannot register a value module from a Void structure."
let add_value_structure value internal =
@@ -352,7 +352,7 @@ let add_domain (type v) dname mode (abstraction: v abstraction) (module Acc: Acc
module Store = struct
include Store
let register_global_state storage state =
- let no_results = Value_parameters.NoResultsDomains.mem dname in
+ let no_results = Parameters.NoResultsDomains.mem dname in
register_global_state (storage && not no_results) state
end
end in
@@ -386,8 +386,8 @@ let add_domain (type v) dname mode (abstraction: v abstraction) (module Acc: Acc
let warn_experimental flag =
if flag.experimental then
- Value_parameters.(warning ~wkey:wkey_experimental
- "The %s domain is experimental." flag.name)
+ Self.(warning ~wkey:wkey_experimental
+ "The %s domain is experimental." flag.name)
let build_domain config abstract =
let build (Flag flag, mode) acc =
diff --git a/src/plugins/value/engine/analysis.ml b/src/plugins/value/engine/analysis.ml
index 7fde8c2e3ddfee761223d62b4148c34b596a9994..b93d7eed5d5a2f8264acd8021e095804f9012593 100644
--- a/src/plugins/value/engine/analysis.ml
+++ b/src/plugins/value/engine/analysis.ml
@@ -23,15 +23,23 @@
open Cil_types
open Eval
+type computation_state = Self.computation_state =
+ | NotComputed | Computing | Computed | Aborted
+let current_computation_state = Self.current_computation_state
+let register_computation_hook = Self.register_computation_hook
+let is_computed = Self.is_computed
+
module type Results = sig
type state
type value
type location
+ val get_global_state: unit -> state or_bottom
val get_stmt_state : after:bool -> stmt -> state or_bottom
- val get_kinstr_state: after:bool -> kinstr -> state or_bottom
val get_stmt_state_by_callstack:
after:bool -> stmt -> state Value_types.Callstack.Hashtbl.t or_top_or_bottom
+ val get_initial_state:
+ kernel_function -> state or_bottom
val get_initial_state_by_callstack:
kernel_function -> state Value_types.Callstack.Hashtbl.t or_top_or_bottom
@@ -70,17 +78,18 @@ module Make (Abstract: Abstractions.S) = struct
let get_stmt_state ~after stmt =
let fundec = Kernel_function.(get_definition (find_englobing_kf stmt)) in
- if Mark_noresults.should_memorize_function fundec && Db.Value.is_computed ()
+ if Mark_noresults.should_memorize_function fundec && is_computed ()
then Abstract.Dom.Store.get_stmt_state ~after stmt
else `Value Abstract.Dom.top
- let get_kinstr_state ~after = function
- | Kglobal -> Abstract.Dom.Store.get_global_state ()
- | Kstmt stmt -> get_stmt_state ~after stmt
+ let get_global_state = Abstract.Dom.Store.get_global_state
let get_stmt_state_by_callstack =
Abstract.Dom.Store.get_stmt_state_by_callstack
+ let get_initial_state =
+ Abstract.Dom.Store.get_initial_state
+
let get_initial_state_by_callstack =
Abstract.Dom.Store.get_initial_state_by_callstack
@@ -113,36 +122,6 @@ module Default =
else (module Make (Abstractions.Default)))
: Analyzer)
-
-(* Current state of the analysis *)
-type computation_state = NotComputed | Computing | Computed
-
-module ComputationState =
-struct
- let to_string = function
- | NotComputed -> "NotComputed"
- | Computing -> "Computing"
- | Computed -> "Computed"
-
- module Prototype =
- struct
- include Datatype.Serializable_undefined
- type t = computation_state
- let name = "Eva.Analysis.ComputationState"
- let pretty fmt s = Format.pp_print_string fmt (to_string s)
- let reprs = [ NotComputed ; Computing ; Computed ]
- let dependencies = [ Db.Value.self ]
- let default () = NotComputed
- end
-
- module Datatype' = Datatype.Make (Prototype)
- module Hook = Hook.Build (Prototype)
- include (State_builder.Ref (Datatype') (Prototype))
-
- let set s = set s; Hook.apply s
- let () = add_hook_on_update (fun r -> Hook.apply !r)
-end
-
(* Reference to the current configuration (built by Abstractions.configure from
the parameters of Eva regarding the abstractions used in the analysis) and
the current Analyzer module. *)
@@ -165,18 +144,6 @@ let set_current_analyzer config (analyzer: (module Analyzer)) =
Analyzer_Hook.apply (module (val analyzer): S);
ref_analyzer := (config, analyzer)
-(* Get the current computation state. *)
-let current_computation_state () =
- ComputationState.get ()
-
-(* Register a hook on current computation state *)
-let register_computation_hook ?on f =
- let f' = match on with
- | None -> f
- | Some s -> fun s' -> if s = s' then f s
- in
- ComputationState.Hook.extend f'
-
let cvalue_initial_state () =
let module A = (val snd !ref_analyzer) in
let _, lib_entry = Globals.entry_point () in
@@ -206,18 +173,31 @@ let reset_analyzer () =
(* Builds the analyzer if needed, and run the analysis. *)
let force_compute () =
Ast.compute ();
- Value_parameters.configure_precision ();
+ Parameters.configure_precision ();
if not (Kernel.AuditCheck.is_empty ()) then
Eva_audit.check_configuration (Kernel.AuditCheck.get ());
let kf, lib_entry = Globals.entry_point () in
reset_analyzer ();
- ComputationState.set Computing; (* The new analyzer can be accesed through hooks *)
+ (* The new analyzer can be accesed through hooks *)
+ Self.set_computation_state Computing;
let module Analyzer = (val snd !ref_analyzer) in
- Analyzer.compute_from_entry_point ~lib_entry kf ;
- ComputationState.set Computed
+ Analyzer.compute_from_entry_point ~lib_entry kf
+
+let compute () =
+ (* Nothing to recompute when Eva has already been computed. This boolean
+ is automatically cleared when an option of Eva changes, because they
+ are registered as dependencies on [Self.state] in {!Parameters}.*)
+ if not (is_computed ()) then force_compute ()
+
+let compute =
+ let name = "Eva.Analysis.compute" in
+ let f = Journal.register name Datatype.(func unit unit) compute in
+ fst (State_builder.apply_once name [ Self.state ] f)
(* Resets the Analyzer when the current project is changed. *)
let () =
Project.register_after_set_current_hook
~user_only:true (fun _ -> reset_analyzer ());
Project.register_after_global_load_hook reset_analyzer
+
+let self = Self.state
diff --git a/src/plugins/value/engine/analysis.mli b/src/plugins/value/engine/analysis.mli
index 2a6e647e5fc99a01f8172413e7cfa25721fb7b86..98d61c3fc42aff8890a05eabcb32b8c82fa18e5d 100644
--- a/src/plugins/value/engine/analysis.mli
+++ b/src/plugins/value/engine/analysis.mli
@@ -28,10 +28,12 @@ module type Results = sig
type value
type location
+ val get_global_state: unit -> state or_bottom
val get_stmt_state : after:bool -> stmt -> state or_bottom
- val get_kinstr_state: after:bool -> kinstr -> state or_bottom
val get_stmt_state_by_callstack:
after:bool -> stmt -> state Value_types.Callstack.Hashtbl.t or_top_or_bottom
+ val get_initial_state:
+ kernel_function -> state or_bottom
val get_initial_state_by_callstack:
kernel_function -> state Value_types.Callstack.Hashtbl.t or_top_or_bottom
@@ -70,7 +72,7 @@ val register_hook: ((module S) -> unit) -> unit
is changed. This happens when a new analysis is run with different
abstractions than before, or when the current project is changed. *)
-type computation_state = NotComputed | Computing | Computed
+type computation_state = NotComputed | Computing | Computed | Aborted
(** Computation state of the analysis. *)
val current_computation_state : unit -> computation_state
@@ -86,5 +88,22 @@ val register_computation_hook: ?on:computation_state ->
val force_compute : unit -> unit
(** Perform a full analysis, starting from the [main] function. *)
+[@@@ api_start]
+val compute : unit -> unit
+(** Computes the Eva analysis, if not already computed, using the entry point
+ of the current project. You may set it with {!Globals.set_entry_point}.
+ @raise Globals.No_such_entry_point if the entry point is incorrect
+ @raise Db.Value.Incorrect_number_of_arguments if some arguments are
+ specified for the entry point using {!Db.Value.fun_set_args}, and
+ an incorrect number of them is given.
+ @plugin development guide *)
+
+val is_computed : unit -> bool
+(** Return [true] iff the Eva analysis has been done. *)
+
+val self : State.t
+(** Internal state of Eva analysis from projects viewpoint. *)
+[@@@ api_end]
+
val cvalue_initial_state: unit -> Cvalue.Model.t
(** Return the initial state of the cvalue domain only. *)
diff --git a/src/plugins/value/engine/compute_functions.ml b/src/plugins/value/engine/compute_functions.ml
index 89f505305e48128fbed9ca567db7db6b36124c7b..b0dd26b84ba0822d7fc896839b6a00a5dca3d8dd 100644
--- a/src/plugins/value/engine/compute_functions.ml
+++ b/src/plugins/value/engine/compute_functions.ml
@@ -23,7 +23,7 @@
open Cil_types
open Eval
-let dkey = Value_parameters.register_category "callbacks"
+let dkey = Self.register_category "callbacks"
let floats_ok () =
let u = min_float /. 2. in
@@ -41,22 +41,22 @@ let options_ok () =
advanced parsing. Just make a query, as this will force the kernel to
parse them. *)
let check f = try ignore (f ()) with Not_found -> () in
- check Value_parameters.SplitReturnFunction.get;
- check Value_parameters.BuiltinsOverrides.get;
- check Value_parameters.SlevelFunction.get;
- check Value_parameters.EqualityCallFunction.get;
+ check Parameters.SplitReturnFunction.get;
+ check Parameters.BuiltinsOverrides.get;
+ check Parameters.SlevelFunction.get;
+ check Parameters.EqualityCallFunction.get;
let check_assigns kf =
if need_assigns kf then
- Value_parameters.error "@[no assigns@ specified@ for function '%a',@ for \
- which@ a builtin@ or the specification@ will be used.@ \
- Potential unsoundness.@]" Kernel_function.pretty kf
+ Self.error "@[no assigns@ specified@ for function '%a',@ for \
+ which@ a builtin@ or the specification@ will be used.@ \
+ Potential unsoundness.@]" Kernel_function.pretty kf
in
- Value_parameters.BuiltinsOverrides.iter (fun (kf, _) -> check_assigns kf);
- Value_parameters.UsePrototype.iter (fun kf -> check_assigns kf)
+ Parameters.BuiltinsOverrides.iter (fun (kf, _) -> check_assigns kf);
+ Parameters.UsePrototype.iter (fun kf -> check_assigns kf)
let plugins_ok () =
if not (Plugin.is_present "inout") then
- Value_parameters.warning
+ Self.warning
"The inout plugin is missing: some features are disabled, \
and the analysis may have degraded precision and performance."
@@ -66,15 +66,15 @@ let generate_specs () =
let aux kf =
if need_assigns kf then begin
let spec = Annotations.funspec ~populate:false kf in
- Value_parameters.warning "Generating potentially incorrect assigns \
- for function '%a' for which option %s is set"
- Kernel_function.pretty kf Value_parameters.UsePrototype.option_name;
+ Self.warning "Generating potentially incorrect assigns \
+ for function '%a' for which option %s is set"
+ Kernel_function.pretty kf Parameters.UsePrototype.option_name;
(* The function populate_spec may emit a warning. Position a loc. *)
Cil.CurrentLoc.set (Kernel_function.get_location kf);
ignore (!Annotations.populate_spec_ref kf spec)
end
in
- Value_parameters.UsePrototype.iter aux
+ Parameters.UsePrototype.iter aux
let pre_analysis () =
floats_ok ();
@@ -84,17 +84,17 @@ let pre_analysis () =
generate_specs ();
Widen.precompute_widen_hints ();
Builtins.prepare_builtins ();
- Value_perf.reset ();
+ Eva_perf.reset ();
(* We may be resuming Value from a previously crashed analysis. Clear
degeneration states *)
- Value_util.DegenerationPoints.clear ();
+ Eva_utils.DegenerationPoints.clear ();
Cvalue.V.clear_garbled_mix ();
- Value_util.clear_call_stack ()
+ Eva_utils.clear_call_stack ()
let post_analysis_cleanup ~aborted =
- Value_util.clear_call_stack ();
+ Eva_utils.clear_call_stack ();
(* Precompute consolidated states if required *)
- if Value_parameters.JoinResults.get () then
+ if Parameters.JoinResults.get () then
Db.Value.Table_By_Callstack.iter
(fun s _ -> ignore (Db.Value.get_stmt_state s));
if not aborted then
@@ -105,7 +105,7 @@ let post_analysis () =
(* Garbled mix must be dumped here -- at least before the call to
mark_green_and_red -- because fresh ones are created when re-evaluating
all the alarms, and we get an unpleasant "ghost effect". *)
- Value_util.dump_garbled_mix ();
+ Eva_utils.dump_garbled_mix ();
(* Mark unreachable and RTE statuses. Only do this there, not when the
analysis was aborted (hence, not in post_cleanup), because the
propagation is incomplete. Also do not mark unreachable statutes if
@@ -118,14 +118,14 @@ let post_analysis () =
Eva_dynamic.RteGen.mark_generated_rte ();
post_analysis_cleanup ~aborted:false;
(* Remove redundant alarms *)
- if Value_parameters.RmAssert.get () then Eva_dynamic.Scope.rm_asserts ()
+ if Parameters.RmAssert.get () then Eva_dynamic.Scope.rm_asserts ()
(* Registers signal handlers for SIGUSR1 and SIGINT to cleanly abort the Eva
analysis. Returns a function that restores previous signal behaviors after
the analysis. *)
let register_signal_handler () =
let warn () =
- Value_parameters.warning ~once:true "Stopping analysis at user request@."
+ Self.warning ~once:true "Stopping analysis at user request@."
in
let stop _ = warn (); Iterator.signal_abort () in
let interrupt _ = warn (); raise Sys.Break in
@@ -173,24 +173,24 @@ module Make (Abstract: Abstractions.Eva) = struct
the callstack and additional information are printed. *)
let compute_using_spec_or_body call_kinstr call recursion state =
let kf = call.kf in
- Value_results.mark_kf_as_called kf;
+ Eva_results.mark_kf_as_called kf;
let global = match call_kinstr with Kglobal -> true | _ -> false in
- let pp = not global && Value_parameters.ValShowProgress.get () in
- let call_stack = Value_util.call_stack () in
+ let pp = not global && Parameters.ValShowProgress.get () in
+ let call_stack = Eva_utils.call_stack () in
if pp then
- Value_parameters.feedback
+ Self.feedback
"@[computing for function %a.@\nCalled from %a.@]"
Value_types.Callstack.pretty_short call_stack
Cil_datatype.Location.pretty (Cil_datatype.Kinstr.loc call_kinstr);
let use_spec =
match recursion with
- | Some { depth } when depth >= Value_parameters.RecursiveUnroll.get () ->
+ | Some { depth } when depth >= Parameters.RecursiveUnroll.get () ->
`Spec (Recursion.get_spec call_kinstr kf)
| _ ->
match kf.fundec with
| Declaration (_,_,_,_) -> `Spec (Annotations.funspec kf)
| Definition (def, _) ->
- if Kernel_function.Set.mem kf (Value_parameters.UsePrototype.get ())
+ if Kernel_function.Set.mem kf (Parameters.UsePrototype.get ())
then `Spec (Annotations.funspec kf)
else `Def def
in
@@ -199,9 +199,9 @@ module Make (Abstract: Abstractions.Eva) = struct
| `Spec spec ->
Db.Value.Call_Type_Value_Callbacks.apply
(`Spec spec, cvalue_state, call_stack);
- if Value_parameters.InterpreterMode.get ()
- then Value_parameters.abort "Library function call. Stopping.";
- Value_parameters.feedback ~once:true
+ if Parameters.InterpreterMode.get ()
+ then Self.abort "Library function call. Stopping.";
+ Self.feedback ~once:true
"@[using specification for function %a@]" Kernel_function.pretty kf;
let vi = Kernel_function.get_vi kf in
if Cil.is_in_libc vi.vattr then
@@ -215,7 +215,7 @@ module Make (Abstract: Abstractions.Eva) = struct
result
in
if pp then
- Value_parameters.feedback
+ Self.feedback
"Done for function %a" Kernel_function.pretty kf;
Transfer.{ states = resulting_states; cacheable; builtin=false }
@@ -228,7 +228,7 @@ module Make (Abstract: Abstractions.Eva) = struct
let default () =
compute_using_spec_or_body (Kstmt stmt) call recursion init_state
in
- if Value_parameters.MemExecAll.get () then
+ if Parameters.MemExecAll.get () then
let args =
List.map (fun {avalue} -> Eval.value_assigned avalue) call.arguments
in
@@ -244,26 +244,26 @@ module Make (Abstract: Abstractions.Eva) = struct
in
call_result
| Some (states, i) ->
- let stack = Value_util.call_stack () in
+ let stack = Eva_utils.call_stack () in
let cvalue = Abstract.Dom.get_cvalue_or_top init_state in
Db.Value.Call_Type_Value_Callbacks.apply (`Memexec, cvalue, stack);
(* Evaluate the preconditions of kf, to update the statuses
at this call. *)
let spec = Annotations.funspec call.kf in
- if not (Value_util.skip_specifications call.kf) &&
+ if not (Eva_utils.skip_specifications call.kf) &&
Eval_annots.has_requires spec
then begin
let ab = Logic.create init_state call.kf in
ignore (Logic.check_fct_preconditions
(Kstmt stmt) call.kf ab init_state);
end;
- if Value_parameters.ValShowProgress.get () then begin
- Value_parameters.feedback ~current:true
+ if Parameters.ValShowProgress.get () then begin
+ Self.feedback ~current:true
"Reusing old results for call to %a" Kernel_function.pretty call.kf;
- Value_parameters.debug ~dkey
+ Self.debug ~dkey
"calling Record_Value_New callbacks on saved previous result";
end;
- let stack_with_call = Value_util.call_stack () in
+ let stack_with_call = Eva_utils.call_stack () in
Db.Value.Record_Value_Callbacks_New.apply
(stack_with_call, Value_types.Reuse i);
(* call can be cached since it was cached once *)
@@ -292,12 +292,12 @@ module Make (Abstract: Abstractions.Eva) = struct
match Builtins.find_builtin_override call.kf with
| None -> compute_and_cache_call stmt call recursion state
| Some (name, builtin, cacheable, spec) ->
- Value_results.mark_kf_as_called call.kf;
+ Eva_results.mark_kf_as_called call.kf;
let kinstr = Kstmt stmt in
let kf_name = Kernel_function.get_name call.kf in
- if Value_parameters.ValShowProgress.get ()
+ if Parameters.ValShowProgress.get ()
then
- Value_parameters.feedback ~current:true "Call to builtin %s%s"
+ Self.feedback ~current:true "Call to builtin %s%s"
name (if kf_name = name then "" else " for function " ^ kf_name);
(* Do not track garbled mixes created when interpreting the specification,
as the result of the cvalue builtin will overwrite them. *)
@@ -310,7 +310,7 @@ module Make (Abstract: Abstractions.Eva) = struct
let cvalue_state = Abstract.Dom.get_cvalue_or_top state in
match final_state with
| `Bottom ->
- let cs = Value_util.call_stack () in
+ let cs = Eva_utils.call_stack () in
Db.Value.Call_Type_Value_Callbacks.apply (`Spec spec, cvalue_state, cs);
let cacheable = Eval.Cacheable in
Transfer.{states; cacheable; builtin=true}
@@ -337,14 +337,14 @@ module Make (Abstract: Abstractions.Eva) = struct
let () = Transfer.compute_call_ref := compute_call
let store_initial_state kf init_state =
- Abstract.Dom.Store.register_initial_state (Value_util.call_stack ()) init_state;
+ Abstract.Dom.Store.register_initial_state (Eva_utils.call_stack ()) init_state;
let cvalue_state = Abstract.Dom.get_cvalue_or_top init_state in
Db.Value.Call_Value_Callbacks.apply (cvalue_state, [kf, Kglobal])
let compute kf init_state =
let restore_signals = register_signal_handler () in
let compute () =
- Value_util.push_call_stack kf Kglobal;
+ Eva_utils.push_call_stack kf Kglobal;
store_initial_state kf init_state;
let call =
{ kf; callstack = []; arguments = []; rest = []; return = None; }
@@ -354,8 +354,9 @@ module Make (Abstract: Abstractions.Eva) = struct
in
let final_states = List.map snd (final_result.Transfer.states) in
let final_state = PowersetDomain.(final_states |> of_list |> join) in
- Value_util.pop_call_stack ();
- Value_parameters.feedback "done for function %a" Kernel_function.pretty kf;
+ Eva_utils.pop_call_stack ();
+ Self.feedback "done for function %a" Kernel_function.pretty kf;
+ Self.(set_computation_state Computed);
Abstract.Dom.Store.mark_as_computed ();
post_analysis ();
Abstract.Dom.post_analysis final_state;
@@ -363,33 +364,35 @@ module Make (Abstract: Abstractions.Eva) = struct
restore_signals ()
in
let cleanup () =
+ Self.(set_computation_state Aborted);
Abstract.Dom.Store.mark_as_computed ();
post_analysis_cleanup ~aborted:true
in
- Value_util.protect compute ~cleanup
+ Eva_utils.protect compute ~cleanup
let compute_from_entry_point kf ~lib_entry =
pre_analysis ();
- Value_parameters.feedback "Analyzing a%scomplete application starting at %a"
+ Self.feedback "Analyzing a%scomplete application starting at %a"
(if lib_entry then "n in" else " ")
Kernel_function.pretty kf;
let initial_state =
- Value_util.protect
+ Eva_utils.protect
(fun () -> Init.initial_state_with_formals ~lib_entry kf)
~cleanup:(fun () -> post_analysis_cleanup ~aborted:true)
in
match initial_state with
| `Bottom ->
+ Self.(set_computation_state Aborted);
Abstract.Dom.Store.mark_as_computed ();
- Value_parameters.result "Eva not started because globals \
- initialization is not computable.";
+ Self.result "Eva not started because globals \
+ initialization is not computable.";
Eval_annots.mark_invalid_initializers ()
| `Value init_state ->
compute kf init_state
let compute_from_init_state kf init_state =
pre_analysis ();
- let b = Value_parameters.ResultsAll.get () in
+ let b = Parameters.ResultsAll.get () in
Abstract.Dom.Store.register_global_state b (`Value init_state);
compute kf init_state
end
diff --git a/src/plugins/value/engine/evaluation.ml b/src/plugins/value/engine/evaluation.ml
index c194ece602cccce7dd801b1e183b30b32cb8c70f..79ac19437a81d7f8124fa2fffd4ecae58fd5da71 100644
--- a/src/plugins/value/engine/evaluation.ml
+++ b/src/plugins/value/engine/evaluation.ml
@@ -119,8 +119,8 @@ let extern_report = { fuel = Infty; reduction = Neither; volatile = false }
let dummy_report = { fuel = Loop; reduction = Neither; volatile = false }
let no_fuel = -1
-let root_fuel () = Value_parameters.OracleDepth.get ()
-let backward_fuel () = Value_parameters.ReductionDepth.get ()
+let root_fuel () = Parameters.OracleDepth.get ()
+let backward_fuel () = Parameters.ReductionDepth.get ()
let already_precise_loc_report ~for_writing ~reduction loc_report =
(not for_writing || loc_report.for_writing)
@@ -137,7 +137,7 @@ let may_be_reduced_lval (host, offset) = match host with
| Mem _ -> true
let warn_pointer_comparison typ =
- match Value_parameters.WarnPointerComparison.get () with
+ match Parameters.WarnPointerComparison.get () with
| "none" -> false
| "all" -> true
| "pointer" -> Cil.isPointerType (Cil.unrollType typ)
@@ -145,7 +145,7 @@ let warn_pointer_comparison typ =
let propagate_all_pointer_comparison typ =
not (Cil.isPointerType typ)
- || Value_parameters.UndefinedPointerComparisonPropagateAll.get ()
+ || Parameters.UndefinedPointerComparisonPropagateAll.get ()
let comparison_kind = function
| Eq | Ne -> Some Abstract_value.Equality
@@ -455,7 +455,7 @@ module Make
else
let v = Value.rewrap_integer range value in
if range.Eval_typ.i_signed && not (Value.equal value v)
- then Value_parameters.warning ~wkey:Value_parameters.wkey_signed_overflow
+ then Self.warning ~wkey:Self.wkey_signed_overflow
~current:true ~once:true "2's complement assumed for overflow";
return v
@@ -506,7 +506,7 @@ module Make
match typ with
| TFloat (fkind, _) ->
res >>= fun (value, origin) ->
- let expr = Value_util.lval_to_exp lval in
+ let expr = Eva_utils.lval_to_exp lval in
remove_special_float expr fkind value >>=: fun new_value ->
new_value, origin
| TInt (IBool, _) ->
@@ -520,7 +520,7 @@ module Make
else res
| TPtr _ ->
res >>= fun (value, origin) ->
- let expr = Value_util.lval_to_exp lval in
+ let expr = Eva_utils.lval_to_exp lval in
assume_pointer expr value >>=: fun new_value ->
new_value, origin
| _ -> res
@@ -575,7 +575,7 @@ module Make
| Shiftlt ->
let warn_negative = Kernel.LeftShiftNegative.get () in
reduce_shift ~warn_negative typ arg1 arg2
- | MinusPP when Value_parameters.WarnPointerSubstraction.get () ->
+ | MinusPP when Parameters.WarnPointerSubstraction.get () ->
let kind = Abstract_value.Subtraction in
let truth = Value.assume_comparable kind v1 v2 in
let alarm () = Alarms.Differing_blocks (e1, e2) in
@@ -612,9 +612,9 @@ module Make
else
let zero_or_one = Value.(join zero one) in
if Cil.isPointerType typ then
- Value_parameters.result
+ Self.result
~current:true ~once:true
- ~dkey:Value_parameters.dkey_pointer_comparison
+ ~dkey:Self.dkey_pointer_comparison
"evaluating condition to {0; 1} instead of %a because of UPCPA"
(Bottom.pretty pretty_zero_or_one) result;
`Value zero_or_one
@@ -627,7 +627,7 @@ module Make
| Some kind ->
let compute v1 v2 = Value.forward_binop typ_e1 op v1 v2 in
(* Detect zero expressions created by the evaluator *)
- let e1 = if Value_util.is_value_zero e1 then None else Some e1 in
+ let e1 = if Eva_utils.is_value_zero e1 then None else Some e1 in
forward_comparison ~compute typ_e1 kind (e1, v1) arg2
| None ->
assume_valid_binop typ arg1 op arg2 >>=. fun (v1, v2) ->
@@ -695,7 +695,7 @@ module Make
in
if warn ()
then cast_integer overflow_kind expr ~src ~dst value
- else if dst.i_signed && Value_parameters.WarnSignedConvertedDowncast.get ()
+ else if dst.i_signed && Parameters.WarnSignedConvertedDowncast.get ()
then relaxed_signed_downcast expr ~src ~dst value
else return (Value.rewrap_integer dst value)
@@ -1007,7 +1007,7 @@ module Make
in
eval_offset context ~reduce_valid_index:reduction typ offset
>>= fun (offs, typ_offs, offset_volatile) ->
- if for_writing && Value_util.is_const_write_invalid typ_offs
+ if for_writing && Eva_utils.is_const_write_invalid typ_offs
then
`Bottom,
Alarmset.singleton ~status:Alarmset.False
@@ -1034,7 +1034,7 @@ module Make
| Index (index_expr, remaining) ->
let typ_pointed, array_size = match Cil.unrollType typ with
| TArray (t, size, _) -> t, size
- | t -> Value_parameters.fatal ~current:true
+ | t -> Self.fatal ~current:true
"Got type '%a'" Printer.pp_typ t
in
eval_offset context ~reduce_valid_index typ_pointed remaining >>=
@@ -1144,7 +1144,7 @@ module Make
-eva-subdivide-non-linear. *)
let subdivision =
match subdivnb with
- | None -> Value_parameters.LinearLevel.get ()
+ | None -> Parameters.LinearLevel.get ()
| Some n -> n
in
let subdivided = false in
@@ -1283,7 +1283,7 @@ module Make
match expr.enode with
| Lval _lv -> assert false
| UnOp (LNot, e, _) ->
- let cond = Value_util.normalize_as_cond e false in
+ let cond = Eva_utils.normalize_as_cond e false in
(* TODO: should we compute the meet with the result of the call to
Value.backward_unop? *)
backward_eval fuel state cond (Some value)
@@ -1535,7 +1535,7 @@ module Make
result, alarms
let copy_lvalue ?(valuation=Cache.empty) ?subdivnb state lval =
- let expr = Value_util.lval_to_exp lval
+ let expr = Eva_utils.lval_to_exp lval
and context = root_context ?subdivnb state in
try
let record, report = Cache.find' valuation expr in
@@ -1588,7 +1588,7 @@ module Make
let reduce ?valuation:(valuation=Cache.empty) state expr positive =
(* Generate [e == 0] *)
- let expr = Value_util.normalize_as_cond expr (not positive) in
+ let expr = Eva_utils.normalize_as_cond expr (not positive) in
cache := valuation;
(* Currently, no subdivisions are performed during the forward evaluation
in this function, which is used to evaluate the conditions of if(…)
@@ -1618,16 +1618,16 @@ module Make
(* Aborts the analysis when a function pointer is completely imprecise. *)
let top_function_pointer funcexp =
- if not (Value_parameters.Domains.mem "cvalue") then
- Value_parameters.abort ~current:true
+ if not (Parameters.Domains.mem "cvalue") then
+ Self.abort ~current:true
"Calls through function pointers are not supported without the cvalue \
domain.";
if Mark_noresults.no_memoization_enabled () then
- Value_parameters.abort ~current:true
+ Self.abort ~current:true
"Function pointer evaluates to anything. Try deactivating \
option(s) -eva-no-results and -eva-no-results-function."
else
- Value_parameters.fatal ~current:true
+ Self.fatal ~current:true
"Function pointer evaluates to anything. function %a"
Printer.pp_exp funcexp
diff --git a/src/plugins/value/engine/initialization.ml b/src/plugins/value/engine/initialization.ml
index fd50fbc2765a12ec632190cd693e342373e59021..34df9813bc398fda5ec1fdd1c7a784a1436b1402 100644
--- a/src/plugins/value/engine/initialization.ml
+++ b/src/plugins/value/engine/initialization.ml
@@ -49,7 +49,7 @@ let padding_initialization ~local : padding_initialization =
if Kernel.InitializedPaddingLocals.get ()
then `Initialized else `Uninitialized
else
- match Value_parameters.InitializationPaddingGlobals.get () with
+ match Parameters.InitializationPaddingGlobals.get () with
| "yes" -> `Initialized
| "maybe" -> `MaybeInitialized
| "no" -> `Uninitialized
@@ -62,8 +62,8 @@ let warn_unknown_size vi =
false
with Cil.SizeOfError (s, t)->
let pp fmt v = Format.fprintf fmt "variable '%a'" Printer.pp_varinfo v in
- Value_parameters.warning ~once:true ~current:true
- ~wkey:Value_parameters.wkey_unknown_size
+ Self.warning ~once:true ~current:true
+ ~wkey:Self.wkey_unknown_size
"@[during initialization@ of %a,@ size of@ type '%a'@ cannot be@ \
computed@ (%s)@]" pp vi Printer.pp_typ t s;
true
@@ -131,7 +131,7 @@ module Make
match Transfer.assign state kinstr lval expr with
| `Bottom ->
if kinstr = Kglobal then
- Value_parameters.warning ~once:true ~source:(fst expr.eloc)
+ Self.warning ~once:true ~source:(fst expr.eloc)
"evaluation of initializer '%a' failed@." Printer.pp_exp expr;
raise Initialization_failed
| `Value v -> v
@@ -260,9 +260,9 @@ module Make
| Declaration (_, _, None, _) -> state
| Declaration (_, _, Some l, _)
| Definition ({ sformals = l }, _) ->
- if l <> [] && Value_parameters.InterpreterMode.get ()
+ if l <> [] && Parameters.InterpreterMode.get ()
then
- Value_parameters.abort "Entry point %a has arguments"
+ Self.abort "Entry point %a has arguments"
Kernel_function.pretty kf
else
let var_kind = Abstract_domain.Formal kf in
@@ -273,8 +273,8 @@ module Make
bind them in [state] *)
let add_supplied_main_formals kf actuals state =
match Domain.get_cvalue with
- | None -> Value_parameters.abort "Function Db.Value.fun_set_args cannot be \
- used without the Cvalue domain"
+ | None -> Self.abort "Function Db.Value.fun_set_args cannot be \
+ used without the Cvalue domain"
| Some get_cvalue ->
let formals = Kernel_function.get_formals kf in
if (List.length formals) <> List.length actuals then
@@ -319,7 +319,7 @@ module Make
(* Compute the initial state with all global variable initialized. *)
let compute_global_state ~lib_entry () =
- Value_parameters.debug ~level:2 "Computing globals values";
+ Self.debug ~level:2 "Computing globals values";
let state = Domain.empty () in
let initialize = initialize_global_variable ~lib_entry in
try `Value (Globals.Vars.fold_in_file_order initialize state)
@@ -327,14 +327,14 @@ module Make
(* Dependencies for the Frama-C states containing the initial states
of Eva: all correctness parameters of Eva, plus the AST itself. We
- cannot use [Db.Value.self] directly, because we do not want to
+ cannot use [Self.state] directly, because we do not want to
depend on the tuning parameters. Previously, we use a more
fine-grained list, but this lead to bugs. See mantis #2277. *)
let correctness_deps =
Ast.self ::
List.map
(fun p -> State.get p.Typed_parameter.name)
- Value_parameters.parameters_correctness
+ Parameters.parameters_correctness
module InitialState =
State_builder.Option_ref
@@ -379,7 +379,7 @@ module Make
then cvalue_state
else Cvalue.Model.filter_base print_base cvalue_state
in
- Value_parameters.printf ~dkey:Value_parameters.dkey_initial_state
+ Self.printf ~dkey:Self.dkey_initial_state
~header:(fun fmt -> Format.pp_print_string fmt
"Values of globals at initialization")
"@[ %a@]" Cvalue.Model.pretty cvalue_state
@@ -388,17 +388,17 @@ module Make
let init_state =
if Db.Value.globals_use_supplied_state ()
then begin
- Value_parameters.feedback "Initial state supplied by user";
+ Self.feedback "Initial state supplied by user";
supplied_state ()
end
else begin
- Value_parameters.feedback "Computing initial state";
+ Self.feedback "Computing initial state";
let state = global_state ~lib_entry in
- Value_parameters.feedback "Initial state computed";
+ Self.feedback "Initial state computed";
state
end
in
- let b = Value_parameters.ResultsAll.get () in
+ let b = Parameters.ResultsAll.get () in
Domain.Store.register_global_state b init_state;
print_initial_cvalue_state init_state;
init_state >>-: add_main_formals kf
diff --git a/src/plugins/value/engine/iterator.ml b/src/plugins/value/engine/iterator.ml
index 773be0b00ab90f64fae7ca4f1b72b32c17e62b67..47959cb3306de349cd90190fd991ce756152ecd1 100644
--- a/src/plugins/value/engine/iterator.ml
+++ b/src/plugins/value/engine/iterator.ml
@@ -33,8 +33,8 @@ let check_signals, signal_abort =
end),
(fun () -> signal_emitted := true)
-let dkey = Value_parameters.dkey_iterator
-let dkey_callbacks = Value_parameters.dkey_callbacks
+let dkey = Self.dkey_iterator
+let dkey_callbacks = Self.dkey_callbacks
let blocks_share_locals b1 b2 =
match b1.blocals, b2.blocals with
@@ -74,17 +74,17 @@ module Make_Dataflow
type descending_strategy = NoIteration | FullIteration | ExitIteration
let descending_iteration : descending_strategy =
- match Value_parameters.DescendingIteration.get () with
+ match Parameters.DescendingIteration.get () with
| "no" -> NoIteration
| "exits" -> ExitIteration
| "full" -> FullIteration
| _ -> assert false
let hierachical_convergence : bool =
- Value_parameters.HierarchicalConvergence.get ()
+ Parameters.HierarchicalConvergence.get ()
let interpreter_mode =
- Value_parameters.InterpreterMode.get ()
+ Parameters.InterpreterMode.get ()
(* Ideally, the slevel parameter should not be used anymore in this file
but it is still required for logic interpretation *)
@@ -129,7 +129,7 @@ module Make_Dataflow
let state = AnalysisParam.initial_state
and call_kinstr = AnalysisParam.call_kinstr
and ab = active_behaviors in
- if Value_util.skip_specifications kf then
+ if Eva_utils.skip_specifications kf then
States.singleton state
else match Logic.check_fct_preconditions call_kinstr kf ab state with
| `Bottom -> States.empty
@@ -246,9 +246,9 @@ module Make_Dataflow
let asm_contracts = Annotations.code_annot stmt in
match Logic_utils.extract_contract asm_contracts with
| [] ->
- Value_util.warning_once_current
+ Eva_utils.warning_once_current
"assuming assembly code has no effects in function %t"
- Value_util.pretty_current_cfunction_name;
+ Eva_utils.pretty_current_cfunction_name;
id
(* There should be only one statement contract, if any. *)
| (_, spec) :: _ ->
@@ -324,7 +324,7 @@ module Make_Dataflow
(* Check postconditions *)
let check_postconditions = fun state ->
post_conditions := true;
- if Value_util.skip_specifications kf then
+ if Eva_utils.skip_specifications kf then
[state]
else match
Logic.check_fct_postconditions kf active_behaviors Normal
@@ -368,7 +368,7 @@ module Make_Dataflow
(* We do not interpret annotations that come from statement contracts
and everything previously emitted by Value (currently, alarms) *)
let filter e ca =
- not (Logic_utils.is_contract ca || Emitter.equal e Value_util.emitter)
+ not (Logic_utils.is_contract ca || Emitter.equal e Eva_utils.emitter)
in
List.map fst (Annotations.code_annot_emitter ~filter stmt)
in
@@ -448,7 +448,7 @@ module Make_Dataflow
let states = Partitioning.contents f in
let cvalue_states = gather_cvalues states in
Db.Value.Compute_Statement_Callbacks.apply
- (stmt, Value_util.call_stack (), cvalue_states)
+ (stmt, Eva_utils.call_stack (), cvalue_states)
let update_vertex ?(widening : bool = false) (v : vertex)
(sources : ('branch * flow) list) : bool =
@@ -527,7 +527,7 @@ module Make_Dataflow
| [b,f,succ] -> (* One successor - continue simulation *)
simulate succ (b,f)
| _ -> (* Several successors - failure *)
- Value_parameters.abort "Do not know which branch to take. Stopping."
+ Self.abort "Do not know which branch to take. Stopping."
let reset_component (vertex_list : vertex list) : unit =
let reset_edge (_,e,_) =
@@ -560,7 +560,7 @@ module Make_Dataflow
while
not (process_vertex ~widening:true v) || !iteration_count = 0
do
- Value_parameters.debug ~dkey "iteration %d" !iteration_count;
+ Self.debug ~dkey "iteration %d" !iteration_count;
iterate_list w;
incr iteration_count;
done;
@@ -568,11 +568,11 @@ module Make_Dataflow
let l = match descending_iteration with
| NoIteration -> []
| ExitIteration ->
- Value_parameters.debug ~dkey
+ Self.debug ~dkey
"propagating descending values through exit paths";
Wto.flatten (exit_strategy graph component)
| FullIteration ->
- Value_parameters.debug ~dkey
+ Self.debug ~dkey
"propagating descending values through the loop";
v :: Wto.flatten w
in
@@ -586,7 +586,7 @@ module Make_Dataflow
let f stmt (v,_) =
let l = get_succ_tanks v in
if not (List.for_all Partitioning.is_empty_tank l) then
- Value_util.DegenerationPoints.replace stmt false
+ Eva_utils.DegenerationPoints.replace stmt false
in
StmtTable.iter f automaton.stmt_table;
match !current_ki with
@@ -594,7 +594,7 @@ module Make_Dataflow
| Kstmt s ->
let englobing_kf = Kernel_function.find_englobing_kf s in
if Kernel_function.equal englobing_kf kf then (
- Value_util.DegenerationPoints.replace s true)
+ Eva_utils.DegenerationPoints.replace s true)
(* If the postconditions have not been evaluated, mark them as true. *)
let mark_postconds_as_true () =
@@ -698,7 +698,7 @@ module Make_Dataflow
in
let merged_pre_cvalues = lazy (lift_to_cvalues merged_pre_states)
and merged_post_cvalues = lazy (lift_to_cvalues merged_post_states) in
- let callstack = Value_util.call_stack () in
+ let callstack = Eva_utils.call_stack () in
if Mark_noresults.should_memorize_function fundec then begin
let register_pre = Domain.Store.register_state_before_stmt callstack
and register_post = Domain.Store.register_state_after_stmt callstack in
@@ -708,26 +708,26 @@ module Make_Dataflow
end;
if not (Db.Value.Record_Value_Superposition_Callbacks.is_empty ())
then begin
- if Value_parameters.ValShowProgress.get () then
- Value_parameters.debug ~dkey:dkey_callbacks
+ if Parameters.ValShowProgress.get () then
+ Self.debug ~dkey:dkey_callbacks
"now calling Record_Value_Superposition callbacks";
Db.Value.Record_Value_Superposition_Callbacks.apply
(callstack, unmerged_pre_cvalues);
end;
if not (Db.Value.Record_Value_Callbacks.is_empty ())
then begin
- if Value_parameters.ValShowProgress.get () then
- Value_parameters.debug ~dkey:dkey_callbacks
+ if Parameters.ValShowProgress.get () then
+ Self.debug ~dkey:dkey_callbacks
"now calling Record_Value callbacks";
Db.Value.Record_Value_Callbacks.apply
(callstack, merged_pre_cvalues)
end;
if not (Db.Value.Record_Value_Callbacks_New.is_empty ())
then begin
- if Value_parameters.ValShowProgress.get () then
- Value_parameters.debug ~dkey:dkey_callbacks
+ if Parameters.ValShowProgress.get () then
+ Self.debug ~dkey:dkey_callbacks
"now calling Record_Value_New callbacks";
- if Value_parameters.MemExecAll.get () then
+ if Parameters.MemExecAll.get () then
Db.Value.Record_Value_Callbacks_New.apply
(callstack,
Value_types.NormalStore ((merged_pre_cvalues, merged_post_cvalues),
@@ -739,8 +739,8 @@ module Make_Dataflow
end;
if not (Db.Value.Record_Value_After_Callbacks.is_empty ())
then begin
- if Value_parameters.ValShowProgress.get () then
- Value_parameters.debug ~dkey:dkey_callbacks
+ if Parameters.ValShowProgress.get () then
+ Self.debug ~dkey:dkey_callbacks
"now calling Record_After_Value callbacks";
Db.Value.Record_Value_After_Callbacks.apply
(callstack, merged_post_cvalues);
@@ -774,13 +774,13 @@ module Computer
in
let compute () =
let results = Dataflow.compute () in
- if Value_parameters.ValShowProgress.get () then
- Value_parameters.feedback "Recording results for %a"
+ if Parameters.ValShowProgress.get () then
+ Self.feedback "Recording results for %a"
Kernel_function.pretty kf;
Dataflow.merge_results ();
let f = Kernel_function.get_definition kf in
if Cil.hasAttribute "noreturn" f.svar.vattr && results <> [] then
- Value_util.warning_once_current
+ Eva_utils.warning_once_current
"function %a may terminate but has the noreturn attribute"
Kernel_function.pretty kf;
results, !Dataflow.cacheable
@@ -789,7 +789,7 @@ module Computer
Dataflow.mark_degeneration ();
Dataflow.merge_results ()
in
- Value_util.protect compute ~cleanup
+ Eva_utils.protect compute ~cleanup
end
diff --git a/src/plugins/value/engine/mem_exec.ml b/src/plugins/value/engine/mem_exec.ml
index 54c5d3f5e9fed0290d05a783a031fb9d0db34f70..35dc3f3e2af0a27abdcc234ced3e5731cda64369 100644
--- a/src/plugins/value/engine/mem_exec.ml
+++ b/src/plugins/value/engine/mem_exec.ml
@@ -82,7 +82,7 @@ module Make
(ArgsToStoredCalls)
(struct
let size = 17
- let dependencies = [Db.Value.self]
+ let dependencies = [Self.state]
let name = "Mem_exec.PreviousCalls(" ^ string_of_int !counter ^ ")"
end)
diff --git a/src/plugins/value/engine/recursion.ml b/src/plugins/value/engine/recursion.ml
index 71c6807a8fec3367044cdfc1717b4e4722b2629f..079654be5e5583f74db158557aca313474f09796 100644
--- a/src/plugins/value/engine/recursion.ml
+++ b/src/plugins/value/engine/recursion.ml
@@ -31,7 +31,7 @@ let mark_unknown_requires kinstr kf funspec =
| Kglobal -> assert false
| Kstmt stmt -> stmt
in
- let emitter = Value_util.emitter in
+ let emitter = Eva_utils.emitter in
let status = Property_status.Dont_know in
let emit_behavior behavior =
let emit_predicate predicate =
@@ -47,7 +47,7 @@ let mark_unknown_requires kinstr kf funspec =
let get_spec kinstr kf =
let funspec = Annotations.funspec ~populate:false kf in
if Cil.is_empty_funspec funspec then begin
- Value_parameters.error ~current:true
+ Self.error ~current:true
"@[Recursive call to %a@ without a specification.@ \
Generating probably incomplete assigns to interpret the call.@ \
Try to increase@ the %s parameter@ \
@@ -56,17 +56,17 @@ let get_spec kinstr kf =
FRAMAC_SHARE/analysis-scripts/make_wrapper.py
*)
Kernel_function.pretty kf
- Value_parameters.RecursiveUnroll.name
+ Parameters.RecursiveUnroll.name
Kernel_function.pretty kf
- Value_util.pp_callstack;
+ Eva_utils.pp_callstack;
Cil.CurrentLoc.set (Kernel_function.get_location kf);
ignore (!Annotations.populate_spec_ref kf funspec);
Annotations.funspec kf
end
else
- let depth = Value_parameters.RecursiveUnroll.get () in
+ let depth = Parameters.RecursiveUnroll.get () in
let () =
- Value_parameters.warning ~once:true ~current:true
+ Self.warning ~once:true ~current:true
"@[Using specification of function %a@ for recursive calls%s.@ \
Analysis of function %a@ is thus incomplete@ and its soundness@ \
relies on the written specification.@]"
@@ -88,7 +88,7 @@ let _spec_for_recursive_call kf =
let assigns = Infer_annotations.assigns_from_prototype kf in
let bhv = Cil.mk_behavior ~assigns:(Writes assigns) () in
let spec = { (Cil.empty_funspec ()) with spec_behavior = [bhv] } in
- Value_parameters.error ~once:true
+ Self.error ~once:true
"@[recursive@ call@ on@ an unspecified@ \
function.@ Using@ potentially@ invalid@ inferred assigns '%t'@]"
(fun fmt -> match assigns with
@@ -154,8 +154,8 @@ let make_stack (kf, depth) =
let get_stack kf depth = VarStack.memo make_stack (kf, depth)
let make_recursion call depth =
- let dkey = Value_parameters.dkey_recursion in
- Value_parameters.feedback ~dkey ~once:true ~current:true
+ let dkey = Self.dkey_recursion in
+ Self.feedback ~dkey ~once:true ~current:true
"@[detected recursive call@ of function %a.@]"
Kernel_function.pretty call.kf;
let substitution = get_stack call.kf depth in
diff --git a/src/plugins/value/engine/subdivided_evaluation.ml b/src/plugins/value/engine/subdivided_evaluation.ml
index 61a0a65264687d9a08090f372bfa90331d179aaa..6b96d072f172037eb5c3c6a49706efd25bb564fe 100644
--- a/src/plugins/value/engine/subdivided_evaluation.ml
+++ b/src/plugins/value/engine/subdivided_evaluation.ml
@@ -23,7 +23,7 @@
open Cil_types
open Eval
-let dkey = Value_parameters.register_category "nonlin"
+let dkey = Self.register_category "nonlin"
(* ----------------- Occurrences of lvalues in expressions ------------------ *)
@@ -179,7 +179,7 @@ let compute_non_linear expr =
let list = reverse_map map in
List.iter
(fun (e, lval) ->
- Value_parameters.result ~current:true ~once:true ~dkey
+ Self.result ~current:true ~once:true ~dkey
"non-linear '%a', lv '%a'" Printer.pp_exp e
(Pretty_utils.pp_list ~sep:", " Printer.pp_lval) lval)
list;
@@ -708,7 +708,7 @@ module Make
(* Builds the information for an lvalue. *)
let get_info context valuation lval =
- let lv_expr = Value_util.lval_to_exp lval in
+ let lv_expr = Eva_utils.lval_to_exp lval in
(* Reevaluates the lvalue in the initial state, as its value could have
been reduced in the evaluation of the complete expression, and we cannot
omit the alarms for the removed values. *)
@@ -773,7 +773,7 @@ module Make
(subdivnb * nb) / (Integer.to_int_exn (pow 2 (nb - 1)))
else subdivnb
in
- Value_parameters.result ~current:true ~once:true ~dkey
+ Self.result ~current:true ~once:true ~dkey
"subdividing on %a"
(Pretty_utils.pp_list ~sep:", " Printer.pp_lval) lvals;
let subdivide =
@@ -905,7 +905,7 @@ module Make
let v = get_cval value in
if positive
then Cvalue.V.contains_non_zero v
- else if Value_parameters.UndefinedPointerComparisonPropagateAll.get ()
+ else if Parameters.UndefinedPointerComparisonPropagateAll.get ()
then Cvalue.V.contains_zero v
else Cvalue.V.is_included Cvalue.V.singleton_zero v
in
@@ -943,7 +943,7 @@ module Make
inoperative. Otherwise, it calls reduce_by_cond_enumerate with the
value accessor for the cvalue component. *)
let reduce_by_enumeration context valuation expr positive =
- if activated && Value_parameters.EnumerateCond.get ()
+ if activated && Parameters.EnumerateCond.get ()
then
get_influential_exprs valuation expr >>- fun split_on ->
reduce_by_cond_enumerate context valuation expr positive split_on
diff --git a/src/plugins/value/engine/transfer_logic.ml b/src/plugins/value/engine/transfer_logic.ml
index 95f0220637e68f331ec05c47d4f26b7a1ddaf603..9c474bf23cb30f00d6b816f5dc941b04725e6ed0 100644
--- a/src/plugins/value/engine/transfer_logic.ml
+++ b/src/plugins/value/engine/transfer_logic.ml
@@ -69,16 +69,16 @@ let emit_status ppt status =
if status = Property_status.False_if_reachable then begin
Red_statuses.add_red_property (Property.get_kinstr ppt) ppt;
end;
- Property_status.emit ~distinct:true Value_util.emitter ~hyps:[] ppt status
+ Property_status.emit ~distinct:true Eva_utils.emitter ~hyps:[] ppt status
(* Display the message as result/warning depending on [status] *)
let msg_status status ?current ?once ?source fmt =
if status = Alarmset.True then
- if Value_parameters.ValShowProgress.get ()
- then Value_parameters.result ?current ?once ?source fmt
- else Value_parameters.result ?current ?once ?source ~level:2 fmt
+ if Parameters.ValShowProgress.get ()
+ then Self.result ?current ?once ?source fmt
+ else Self.result ?current ?once ?source ~level:2 fmt
else
- Value_util.alarm_report ?current ?once ?source fmt
+ Eva_utils.alarm_report ?current ?once ?source fmt
let behavior_inactive fmt =
Format.fprintf fmt " (Behavior may be inactive, no reduction performed.)"
@@ -123,7 +123,7 @@ let emit_message_and_status kind kf behavior ~active ~empty property named_pred
pp_predicate named_pred
Alarmset.Status.pretty status
(if active then (fun _ -> ()) else behavior_inactive)
- Value_util.pp_callstack;
+ Eva_utils.pp_callstack;
emit_status property (conv_status status);
| Postcondition postk ->
(* Do not emit a status for leaf functions or builtins. Otherwise, we would
@@ -236,9 +236,9 @@ let process_inactive_behavior kf call_ki behavior =
end
) behavior.b_requires;
if !emitted then
- Value_parameters.result ~once:true ~current:true ~level:2
+ Self.result ~once:true ~current:true ~level:2
"%a: assumes got status invalid; behavior not evaluated.%t"
- (pp_header kf) behavior Value_util.pp_callstack
+ (pp_header kf) behavior Eva_utils.pp_callstack
let process_inactive_behaviors call_ki kf behaviors =
List.iter (process_inactive_behavior kf call_ki) behaviors
@@ -258,9 +258,9 @@ let process_inactive_postconds kf inactive_bhvs =
end
) b.b_post_cond;
if !emitted then
- Value_parameters.result ~once:true ~current:true ~level:2
+ Self.result ~once:true ~current:true ~level:2
"%a: requires got status invalid; postconditions not evaluated.%t"
- (pp_header kf) b Value_util.pp_callstack;
+ (pp_header kf) b Eva_utils.pp_callstack;
) inactive_bhvs
(* -------------------------------- Functor --------------------------------- *)
@@ -421,14 +421,14 @@ module Make
| Postcondition (PostLeaf | PostUseSpec) -> true
| _ -> false)
&& pr.pred_content <> Pfalse then
- Value_parameters.warning ~once:true ~source
+ Self.warning ~once:true ~source
"@[%a:@ this postcondition@ evaluates to@ false@ in this@ context.\
@ If it is valid,@ either@ a precondition@ was not@ verified@ \
for this@ call%t,@ or some assigns/from@ clauses@ are \
incomplete@ (or incorrect).@]%t"
pp_header behavior
(if active then (fun _ -> ()) else pp_behavior_inactive)
- Value_util.pp_callstack
+ Eva_utils.pp_callstack
(* [per_behavior] indicates if we are processing each behavior separately.
If this is the case, then [Unknown] and [True] behaviors are treated
@@ -453,7 +453,7 @@ module Make
- [build_env] is used to build the environment evaluation, in particular
the pre- and post-states. *)
let eval_and_reduce kf behavior active kind ips states build_prop build_env =
- let limit = Value_util.get_slevel kf in
+ let limit = Eva_utils.get_slevel kf in
let emit = emit_message_and_status kind kf behavior ~active in
let aux_pred states pred =
let pr = Logic_const.pred_of_id_pred pred in
diff --git a/src/plugins/value/engine/transfer_specification.ml b/src/plugins/value/engine/transfer_specification.ml
index 6c953deb3d14074c32383002bb96566a30f65cdf..aab9b10deef6b7310de87c99046023a73e1b481c 100644
--- a/src/plugins/value/engine/transfer_specification.ml
+++ b/src/plugins/value/engine/transfer_specification.ml
@@ -40,7 +40,7 @@ let find_default_behavior spec =
List.find (fun b' -> b'.b_name = Cil.default_behavior_name) spec.spec_behavior
let warn_empty_assigns () =
- Value_util.warning_once_current
+ Eva_utils.warning_once_current
"Cannot handle empty assigns clause. Assuming assigns \\nothing: \
be aware this is probably incorrect."
@@ -51,7 +51,7 @@ let warn_empty_from list =
| [] -> ()
| (out, _) :: _ ->
let source = fst out.it_content.term_loc in
- Value_parameters.warning ~source ~once:true
+ Self.warning ~source ~once:true
"@[no \\from part@ for clause '%a'@]"
Printer.pp_assigns (Writes no_from)
@@ -109,9 +109,9 @@ let warn_on_missing_result_assigns kinstr kf spec =
let return_used = match kinstr with
| Kglobal -> true
| Kstmt {skind = Instr (Call (lv, _, _, _))} ->
- lv <> None || Value_util.postconditions_mention_result spec
+ lv <> None || Eva_utils.postconditions_mention_result spec
| Kstmt {skind = Instr (Local_init(_,ConsInit(_,_,Constructor),_)) } ->
- Value_util.postconditions_mention_result spec
+ Eva_utils.postconditions_mention_result spec
| Kstmt {skind=Instr(Local_init(_,ConsInit(_,_,Plain_func),_))} -> true
| _ -> assert false
in
@@ -124,14 +124,14 @@ let warn_on_missing_result_assigns kinstr kf spec =
if return_used && not (List.for_all assigns_result spec.spec_behavior)
then
let source = fst (Kernel_function.get_location kf) in
- Value_parameters.warning ~once:true ~source
+ Self.warning ~once:true ~source
"@[no 'assigns \\result@ \\from ...'@ clause@ specified for@ function %a@]"
Kernel_function.pretty kf
let reduce_to_valid_location kind term loc =
if Locations.(Location_Bits.(equal top loc.loc)) then
begin
- Value_parameters.error ~once:true ~current:true
+ Self.error ~once:true ~current:true
"@[Cannot handle@ %a,@ location is too imprecise@ (%a).@ \
Assuming it is not assigned,@ but be aware@ this is incorrect.@]"
pp_assign_clause (kind, term) Locations.pretty loc;
@@ -142,8 +142,8 @@ let reduce_to_valid_location kind term loc =
if Locations.is_bottom_loc valid then
begin
if kind = Assign && not (Locations.is_bottom_loc loc) then
- Value_parameters.warning ~current:true ~once:true
- ~wkey:Value_parameters.wkey_invalid_assigns
+ Self.warning ~current:true ~once:true
+ ~wkey:Self.wkey_invalid_assigns
"@[Completely invalid destination@ for %a.@ \
Ignoring.@]" pp_assign_clause (kind, term);
None
@@ -164,7 +164,7 @@ let precise_loc_of_assign env kind term =
in
if kind <> From then reduce_to_valid_location kind term loc else Some loc
with Eval_terms.LogicEvalError e ->
- Value_util.warning_once_current
+ Eva_utils.warning_once_current
"@[<hov 0>@[<hov 2>cannot interpret %a@]%a;@ effects will be ignored@]"
pp_assign_clause (kind, term) pp_eval_error e;
None
@@ -313,8 +313,8 @@ module Make
then
begin
ignore (Locations.Location_Bytes.track_garbled_mix cvalue);
- Value_parameters.warning ~current:true ~once:true
- ~wkey:Value_parameters.wkey_garbled_mix
+ Self.warning ~current:true ~once:true
+ ~wkey:Self.wkey_garbled_mix
"The specification of function %a has generated a garbled mix \
for %a."
Kernel_function.pretty kf pp_assign_clause (Assign, assign)
@@ -488,7 +488,7 @@ module Make
| _ ->
let vi = Kernel_function.get_vi kf in
if not (Cil.hasAttribute "FC_BUILTIN" vi.vattr) then
- Value_parameters.warning ~current:true ~once:true
+ Self.warning ~current:true ~once:true
"ignoring unsupported allocates clause"
) behaviors
diff --git a/src/plugins/value/engine/transfer_stmt.ml b/src/plugins/value/engine/transfer_stmt.ml
index 19c6c9973d540c62f1f070dc7f40fa2be9929b18..3fe6dfc5177afc92d221a8f87bf8d492743fb98e 100644
--- a/src/plugins/value/engine/transfer_stmt.ml
+++ b/src/plugins/value/engine/transfer_stmt.ml
@@ -51,7 +51,7 @@ end
module InOutCallback =
State_builder.Option_ref (Inout_type)
(struct
- let dependencies = [Db.Value.self]
+ let dependencies = [Self.state]
let name = "Transfer_stmt.InOutCallback"
end)
@@ -65,7 +65,7 @@ let current_kf_inout = InOutCallback.get_option
(* Should we warn about indeterminate copies in the function [kf] ? *)
let warn_indeterminate kf =
- let params = Value_parameters.WarnCopyIndeterminate.get () in
+ let params = Parameters.WarnCopyIndeterminate.get () in
Kernel_function.Set.mem kf params
(* An assignment from a right scalar lvalue is interpreted as a copy when
@@ -88,10 +88,10 @@ let is_determinate kf =
(warn_indeterminate kf || !Db.Value.use_spec_instead_of_definition kf)
&& not (Ast_info.is_frama_c_builtin name)
-let subdivide_stmt = Value_util.get_subdivision
+let subdivide_stmt = Eva_utils.get_subdivision
let subdivide_kinstr = function
- | Kglobal -> Value_parameters.LinearLevel.get ()
+ | Kglobal -> Parameters.LinearLevel.get ()
| Kstmt stmt -> subdivide_stmt stmt
(* Used to disambiguate files for Frama_C_dump_each_file directives. *)
@@ -99,7 +99,7 @@ module DumpFileCounters =
State_builder.Hashtbl (Datatype.String.Hashtbl) (Datatype.Int)
(struct
let size = 3
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Self.state ]
let name = "Transfer_stmt.DumpFileCounters"
end)
@@ -137,12 +137,12 @@ module Make (Abstract: Abstractions.Eva) = struct
let notify_unreachability fmt =
if Domain.log_category = Domain_product.product_category
then
- Value_parameters.feedback ~level:1 ~current:true ~once:true
+ Self.feedback ~level:1 ~current:true ~once:true
"The evaluation of %(%a%)@ led to bottom without alarms:@ at this point \
the product of states has no possible concretization.@."
fmt
else
- Value_parameters.warning ~current:true
+ Self.warning ~current:true
"The evaluation of %(%a%)@ led to bottom without alarms:@ at this point \
the abstract state has no possible concretization,@ which is probably \
a bug."
@@ -151,8 +151,8 @@ module Make (Abstract: Abstractions.Eva) = struct
let report_unreachability state (result, alarms) fmt =
if result = `Bottom && Alarmset.is_empty alarms
then begin
- Value_parameters.debug ~current:true ~once:true ~level:1
- ~dkey:Value_parameters.dkey_incompatible_states
+ Self.debug ~current:true ~once:true ~level:1
+ ~dkey:Self.dkey_incompatible_states
"State without concretization: %a" Domain.pretty state;
notify_unreachability fmt
end
@@ -243,7 +243,7 @@ module Make (Abstract: Abstractions.Eva) = struct
| `Bottom ->
Kernel.warning ~current:true ~once:true
"@[<v>@[all target addresses were invalid. This path is \
- assumed to be dead.@]%t@]" Value_util.pp_callstack;
+ assumed to be dead.@]%t@]" Eva_utils.pp_callstack;
`Bottom
| `Value (valuation, lloc, ltyp) ->
(* Tries to interpret the assignment as a copy for the returned value
@@ -312,9 +312,9 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Returns the result of a call, and a boolean that indicates whether a
builtin has been used to interpret the call. *)
let process_call stmt call recursion valuation state =
- Value_util.push_call_stack call.kf (Kstmt stmt);
+ Eva_utils.push_call_stack call.kf (Kstmt stmt);
let cleanup () =
- Value_util.pop_call_stack ();
+ Eva_utils.pop_call_stack ();
(* Changed by compute_call_ref, called from process_call *)
Cil.CurrentLoc.set (Cil_datatype.Stmt.loc stmt);
in
@@ -324,7 +324,7 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Process the call according to the domain decision. *)
match Domain.start_call stmt call recursion domain_valuation state with
| `Value state ->
- Domain.Store.register_initial_state (Value_util.call_stack ()) state;
+ Domain.Store.register_initial_state (Eva_utils.call_stack ()) state;
!compute_call_ref stmt call recursion state
| `Bottom ->
{ states = []; cacheable = Cacheable; builtin=false }
@@ -332,7 +332,7 @@ module Make (Abstract: Abstractions.Eva) = struct
cleanup ();
res
in
- Value_util.protect process
+ Eva_utils.protect process
~cleanup:(fun () -> InOutCallback.clear (); cleanup ())
(* ------------------- Retro propagation on formals ----------------------- *)
@@ -363,7 +363,7 @@ module Make (Abstract: Abstractions.Eva) = struct
| `Top -> Precise_locs.loc_top
| `Value record -> get record.loc
in
- let expr_zone = Value_util.zone_of_expr find_loc expr in
+ let expr_zone = Eva_utils.zone_of_expr find_loc expr in
let written_zone = inout.Inout_type.over_outputs_if_termination in
not (Locations.Zone.intersects expr_zone written_zone)
@@ -440,7 +440,7 @@ module Make (Abstract: Abstractions.Eva) = struct
| None, Some vi_ret -> `Value (Domain.leave_scope kf_callee [vi_ret] state)
| Some _, None -> assert false
| Some lval, Some vi_ret ->
- let exp_ret_caller = Value_util.lval_to_exp (Var vi_ret, NoOffset) in
+ let exp_ret_caller = Eva_utils.lval_to_exp (Var vi_ret, NoOffset) in
assign_ret state (Kstmt stmt) lval exp_ret_caller
>>-: fun state -> Domain.leave_scope kf_callee [vi_ret] state
@@ -509,7 +509,7 @@ module Make (Abstract: Abstractions.Eva) = struct
>>= fun (valuation, loc, typ) ->
if Int_Base.is_top (Location.size loc)
then
- Value_parameters.abort ~current:true
+ Self.abort ~current:true
"Function argument %a has unknown size. Aborting"
Printer.pp_exp expr;
if determinate && Cil.isArithmeticOrPointerType (Cil.typeOfLval lv)
@@ -534,7 +534,7 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Create an Eval.call *)
let create_call kf args =
let return = Library_functions.get_retres_vi kf in
- let callstack = Value_util.call_stack () in
+ let callstack = Eva_utils.call_stack () in
let arguments, rest =
let formals = Kernel_function.get_formals kf in
let rec format_arguments acc args formals = match args, formals with
@@ -591,7 +591,7 @@ module Make (Abstract: Abstractions.Eva) = struct
let print_state =
if Domain.log_category = Domain_product.product_category
then Domain.pretty
- else if Value_parameters.is_debug_key_enabled Domain.log_category
+ else if Self.is_debug_key_enabled Domain.log_category
then
fun fmt state ->
Format.fprintf fmt "# %s:@ @[<hv>%a@]@ " Domain.name Domain.pretty state
@@ -599,15 +599,15 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Frama_C_dump_each functions. *)
let dump_state name state =
- Value_parameters.result ~current:true
+ Self.result ~current:true
"%s:@\n@[<v>%a@]==END OF DUMP==%t"
- name print_state state Value_util.pp_callstack
+ name print_state state Eva_utils.pp_callstack
(* Idem as for [print_state]. *)
let show_expr =
if Domain.log_category = Domain_product.product_category
then Domain.show_expr
- else if Value_parameters.is_debug_key_enabled Domain.log_category
+ else if Self.is_debug_key_enabled Domain.log_category
then
fun valuation state fmt exp ->
Format.fprintf fmt "# %s: @[<hov>%a@]"
@@ -627,9 +627,9 @@ module Make (Abstract: Abstractions.Eva) = struct
Format.fprintf fmt "%a : @[<h>%t@]" Printer.pp_exp expr pp
in
let pp = Pretty_utils.pp_list ~pre:"@[<v>" ~sep:"@ " ~suf:"@]" pretty in
- Value_parameters.result ~current:true
+ Self.result ~current:true
"@[<v>%s:@ %a@]%t"
- name pp arguments Value_util.pp_callstack
+ name pp arguments Eva_utils.pp_callstack
(* For non scalar expressions, prints the offsetmap of the cvalue domain. *)
let show_offsm =
@@ -672,9 +672,9 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Frama_C_show_each functions. *)
let show_each ~subdivnb name arguments state =
- Value_parameters.result ~current:true
+ Self.result ~current:true
"@[<hv>%s:@ %a@]%t"
- name (pretty_arguments ~subdivnb state) arguments Value_util.pp_callstack
+ name (pretty_arguments ~subdivnb state) arguments Eva_utils.pp_callstack
(* Frama_C_dump_each_file functions. *)
let dump_state_file_exc ~subdivnb name arguments state =
@@ -691,8 +691,8 @@ module Make (Abstract: Abstractions.Eva) = struct
let ch = open_out file in
let fmt = Format.formatter_of_out_channel ch in
let l = fst (Cil.CurrentLoc.get ()) in
- Value_parameters.feedback ~current:true "Dumping state in file '%s'%t"
- file Value_util.pp_callstack;
+ Self.feedback ~current:true "Dumping state in file '%s'%t"
+ file Eva_utils.pp_callstack;
Format.fprintf fmt "DUMPING STATE at file %a line %d@."
Datatype.Filepath.pretty l.Filepath.pos_path
l.Filepath.pos_lnum;
@@ -705,7 +705,7 @@ module Make (Abstract: Abstractions.Eva) = struct
let dump_state_file ~subdivnb name arguments state =
try dump_state_file_exc ~subdivnb name arguments state
with e ->
- Value_parameters.warning ~current:true ~once:true
+ Self.warning ~current:true ~once:true
"Error during, or invalid call to Frama_C_dump_each_file (%s). Ignoring"
(Printexc.to_string e)
@@ -728,10 +728,10 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Legacy callbacks for the cvalue domain, usually called by
{Cvalue_transfer.start_call}. *)
let apply_cvalue_callback kf ki_call state =
- let stack_with_call = (kf, ki_call) :: Value_util.call_stack () in
+ let stack_with_call = (kf, ki_call) :: Eva_utils.call_stack () in
let cvalue_state = Domain.get_cvalue_or_top state in
Db.Value.Call_Value_Callbacks.apply (cvalue_state, stack_with_call);
- Db.Value.merge_initial_state (Value_util.call_stack ()) cvalue_state;
+ Db.Value.merge_initial_state (Eva_utils.call_stack ()) cvalue_state;
Db.Value.Call_Type_Value_Callbacks.apply
(`Builtin None, cvalue_state, stack_with_call)
@@ -749,7 +749,7 @@ module Make (Abstract: Abstractions.Eva) = struct
let cacheable = ref Cacheable in
let eval =
functions >>-: fun functions ->
- let current_kf = Value_util.current_kf () in
+ let current_kf = Eva_utils.current_kf () in
let process_one_function kf valuation =
(* The special Frama_C_ functions to print states are handled here. *)
if apply_special_directives ~subdivnb kf args state
@@ -763,7 +763,7 @@ module Make (Abstract: Abstractions.Eva) = struct
let states =
eval >>-: fun (call, recursion, valuation) ->
(* Register the call. *)
- Value_results.add_kf_caller call.kf ~caller:(current_kf, stmt);
+ Eva_results.add_kf_caller call.kf ~caller:(current_kf, stmt);
(* Do the call. *)
let c, states =
do_one_call valuation stmt lval_option call recursion state
diff --git a/src/plugins/value/eval.mli b/src/plugins/value/eval.mli
index 5714172358fc24dfbc4ba07a05c4fe2722fcb2b0..0c7808b6607d3199d63b59b321bb4a686797018f 100644
--- a/src/plugins/value/eval.mli
+++ b/src/plugins/value/eval.mli
@@ -270,15 +270,16 @@ type recursion = {
(** Same withdrawal as the previous field, for bases. *)
}
+[@@@ api_start]
(** Can the results of a function call be cached with memexec? *)
type cacheable =
- | Cacheable (** Functions whose result can be safely cached *)
+ | Cacheable (** Functions whose result can be safely cached. *)
| NoCache (** Functions whose result should not be cached, but for
which the caller can still be cached. Typically,
functions printing something during the analysis. *)
| NoCacheCallers (** Functions for which neither the call, neither the
- callers, can be cached *)
-
+ callers, can be cached. *)
+[@@@ api_end]
(*
Local Variables:
compile-command: "make -C ../../.."
diff --git a/src/plugins/value/gen-api.sh b/src/plugins/value/gen-api.sh
new file mode 100755
index 0000000000000000000000000000000000000000..d00c16fdd4a1175ff780c5479fbb266043c7ba49
--- /dev/null
+++ b/src/plugins/value/gen-api.sh
@@ -0,0 +1,28 @@
+#!/usr/bin/env bash
+set -eu
+
+printf '(** Eva public API.
+
+ The main modules are:
+ - Analysis: run the analysis.
+ - Results: access analysis results, especially the values of expressions
+ and memory locations of lvalues at each program point.
+
+ The following modules allow configuring the Eva analysis:
+ - Parameters: change the configuration of the analysis.
+ - Eva_annotations: add local annotations to guide the analysis.
+ - Builtins: register ocaml builtins to be used by the cvalue domain
+ instead of analysing the body of some C functions.
+
+ Other modules are for internal use only. *)\n'
+
+printf '\n(* This file is generated. Do not edit. *)\n'
+
+for i in "$@"
+do
+ file=$(basename $i)
+ module=${file%.*}
+ printf '\nmodule %s: sig\n' ${module^}
+ awk '/\[@@@ api_start\]/{flag=1;next} /\[@@@ api_end\]/{flag=0} flag{ print (NF ? " ":"") $0 }' $i
+ printf 'end\n'
+done
diff --git a/src/plugins/value/gui_files/gui_callstacks_manager.ml b/src/plugins/value/gui_files/gui_callstacks_manager.ml
index 9e78d8d54e60d5f8eeddb05bb9ec872bde95b280..c1473fc0604124127c1ec49e0822624511ba7a95 100644
--- a/src/plugins/value/gui_files/gui_callstacks_manager.ml
+++ b/src/plugins/value/gui_files/gui_callstacks_manager.ml
@@ -903,7 +903,7 @@ let make_widget (main_ui:main_ui) ~packing make_panel =
let tabs =
GPack.notebook ~scrollable:true ~packing:(vpaned#pack ~expand:true) ()
in
- vpaned#misc#set_sensitive (Db.Value.is_computed ());
+ vpaned#misc#set_sensitive (Analysis.is_computed ());
let pack_tab ?lbl w = ignore (tabs#insert_page ?tab_label:lbl w) in
let lbl_pane_default = GPack.hbox () in
let clear_button = new Widget.button ~icon:`CLEAR ~tooltip:"Clear" () in
@@ -1031,7 +1031,7 @@ let make_widget (main_ui:main_ui) ~packing make_panel =
HWidget.iter (fun w _ -> tabs#remove_page (tabs#page_num w)) hash_tabs;
HWidget.clear hash_tabs;
clear_default ();
- vpaned#misc#set_sensitive (Db.Value.is_computed ());
+ vpaned#misc#set_sensitive (Analysis.is_computed ());
in
let display_data_by_callstack loc selection content =
clear_button#set_enabled true;
diff --git a/src/plugins/value/gui_files/gui_eval.ml b/src/plugins/value/gui_files/gui_eval.ml
index 5888b1bbe9b9c204ecae7582dd2e0eed4c86c9c6..05335f728181d7d09eb7bf714a9070cefb4921f6 100644
--- a/src/plugins/value/gui_files/gui_eval.ml
+++ b/src/plugins/value/gui_files/gui_eval.ml
@@ -24,7 +24,7 @@ open Cil_types
open Gui_types
let results_kf_computed kf =
- Db.Value.is_computed () &&
+ Analysis.is_computed () &&
match kf with
| { fundec = Definition (fundec, _) } ->
Mark_noresults.should_memorize_function fundec
diff --git a/src/plugins/value/gui_files/register_gui.ml b/src/plugins/value/gui_files/register_gui.ml
index 3587497948dafbc7d40353138da1651a5b8202c2..ab3a7c10f477e391ad59ac9994716189d6862bd3 100644
--- a/src/plugins/value/gui_files/register_gui.ml
+++ b/src/plugins/value/gui_files/register_gui.ml
@@ -35,7 +35,7 @@ module UsedVarState =
(struct
let size = 17
let name = "Value.Gui.UsedVarState"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Self.state ]
(* [!Db.Inputs.self_external; !Db.Outputs.self_external] would be better
dependencies, but this introduces a very problematic recursion between
Value and Inout *)
@@ -67,7 +67,7 @@ let sync_filetree (filetree:Filetree.t) =
try
let vi = Kernel_function.get_vi kf in
let strikethrough =
- Db.Value.is_computed () && not (!Db.Value.is_called kf)
+ Analysis.is_computed () && not (Results.is_called kf)
in
filetree#set_global_attribute ~strikethrough vi
with Not_found -> ());
@@ -75,7 +75,7 @@ let sync_filetree (filetree:Filetree.t) =
(fun vi _ ->
if vi.vsource = true then
filetree#set_global_attribute
- ~strikethrough:(Db.Value.is_computed () && not (used_var vi))
+ ~strikethrough:(Analysis.is_computed () && not (used_var vi))
vi
);
if not (filetree#flat_mode) then
@@ -84,7 +84,7 @@ let sync_filetree (filetree:Filetree.t) =
(* the display name removes the path *)
let globals_state = filetree#get_file_globals file in
filetree#set_file_attribute
- ~strikethrough:(Db.Value.is_computed () &&
+ ~strikethrough:(Analysis.is_computed () &&
List.for_all snd globals_state)
file
)
@@ -96,11 +96,11 @@ let sync_filetree (filetree:Filetree.t) =
()
let hide_unused_function_or_var g =
- !hide_unused () && Db.Value.is_computed () &&
+ !hide_unused () && Analysis.is_computed () &&
(match g with
| GFun ({svar = vi}, _) | GFunDecl (_, vi, _) ->
let kf = Globals.Functions.get vi in
- not (!Db.Value.is_called kf)
+ not (Results.is_called kf)
| GVarDecl (vi, _) | GVar (vi, _, _) ->
not (used_var vi)
| _ -> false
@@ -114,21 +114,21 @@ let value_panel pack (main_ui:main_ui) =
in
let box_1_1 = GPack.hbox ~packing:(w#attach ~left:1 ~top:1) () in
let precision_refresh =
- let tooltip = Value_parameters.Precision.parameter.Typed_parameter.help in
+ let tooltip = Parameters.Precision.parameter.Typed_parameter.help in
Gtk_helper.on_int ~lower:(-1) ~upper:11 ~tooltip
box_1_1 "precision (meta-option)"
- Value_parameters.Precision.get
- Value_parameters.Precision.set
+ Parameters.Precision.get
+ Parameters.Precision.set
in
let box_1_2 = GPack.hbox ~packing:(w#attach ~left:1 ~top:2) () in
let slevel_refresh =
let tooltip =
- Value_parameters.SemanticUnrollingLevel.parameter.Typed_parameter.help
+ Parameters.SemanticUnrollingLevel.parameter.Typed_parameter.help
in
Gtk_helper.on_int ~lower:0 ~upper:1000000 ~tooltip
box_1_2 "slevel"
- Value_parameters.SemanticUnrollingLevel.get
- Value_parameters.SemanticUnrollingLevel.set
+ Parameters.SemanticUnrollingLevel.get
+ Parameters.SemanticUnrollingLevel.set
in
let box_1_3 = GPack.hbox ~packing:(w#attach ~left:1 ~top:3) () in
let validator s =
@@ -144,7 +144,7 @@ let value_panel pack (main_ui:main_ui) =
ignore (run_button#connect#pressed
(fun () ->
main_ui#protect ~cancelable:true
- (fun () -> refresh (); !Db.Value.compute (); main_ui#reset ());
+ (fun () -> refresh (); Analysis.compute (); main_ui#reset ());
));
pack box;
"Eva", box#coerce, Some refresh
@@ -156,13 +156,13 @@ let active_highlighter buffer localizable ~start ~stop =
let buffer = buffer#buffer in
(* highlight dead code areas, non-terminating calls, and degeneration
points if Value has run.*)
- if Db.Value.is_computed () then
+ if Analysis.is_computed () then
match localizable with
| PStmt (kf, stmt) -> begin
let degenerate =
try
Some (
- if Value_util.DegenerationPoints.find stmt
+ if Eva_utils.DegenerationPoints.find stmt
then (make_tag buffer ~name:"degeneration" [`BACKGROUND "orange"])
else (make_tag buffer ~name:"unpropagated" [`BACKGROUND "yellow"])
)
@@ -222,7 +222,7 @@ let menu_go_to_fun_definition (main_ui:main_ui) (popup_factory:menu) funs =
List.iter aux funs
let gui_compute_values (main_ui:main_ui) =
- if not (Db.Value.is_computed ())
+ if not (Analysis.is_computed ())
then main_ui#launcher ()
let cleaned_outputs kf s =
@@ -233,8 +233,8 @@ let cleaned_outputs kf s =
let pretty_stmt_info (main_ui:main_ui) kf stmt =
(* Is it an accessible statement ? *)
- if Db.Value.is_reachable_stmt stmt then begin
- if Value_results.is_non_terminating_instr stmt then
+ if Results.is_reachable stmt then begin
+ if Eva_results.is_non_terminating_instr stmt then
match stmt.skind with
| Instr (Call (_, _, _, _)
| Local_init (_, ConsInit _, _)) ->
@@ -412,7 +412,7 @@ module Select (Eval: Eval) = struct
(if unfocus <> [] then (kf, unfocus) :: acc_unfocus else acc_unfocus)
in
let focused, unfocused =
- List.fold_left aux_focus ([], []) (!Db.Value.callers kf)
+ List.fold_left aux_focus ([], []) (Results.callsites kf)
in
List.iter (aux menu) focused;
if unfocused <> [] then
@@ -520,8 +520,13 @@ module Select (Eval: Eval) = struct
| Mem _, NoOffset when Cil.isFunctionType ty -> begin
(* Function pointers *)
(* get the list of functions in the values *)
- let e = Value_util.lval_to_exp lv in
- match Eval.Analysis.get_kinstr_state ~after:false ki with
+ let e = Eva_utils.lval_to_exp lv in
+ let state =
+ match ki with
+ | Kglobal -> Eval.Analysis.get_global_state ()
+ | Kstmt stmt -> Eval.Analysis.get_stmt_state ~after:false stmt
+ in
+ match state with
| `Bottom -> ()
| `Value state ->
let funs, _ = Eval.Analysis.eval_function_exp state e in
@@ -555,7 +560,7 @@ let responses_ref = ref (module No_Response: Responses)
let to_do_on_select (menu:menu) (main_ui:main_ui) ~button selected =
let module Responses = (val !responses_ref) in
- if Db.Value.is_computed () then
+ if Analysis.is_computed () then
if button = 1 then
Responses.left_click_values_computed main_ui selected
else if button = 3 then
diff --git a/src/plugins/value/legacy/eval_annots.ml b/src/plugins/value/legacy/eval_annots.ml
index 68aed0aadab7bc2b5171980bd0962f7b4f3e8c94..910bb4dfce767536d0ef9979ceed4c5dfab04443 100644
--- a/src/plugins/value/legacy/eval_annots.ml
+++ b/src/plugins/value/legacy/eval_annots.ml
@@ -46,10 +46,10 @@ let code_annotation_loc ca stmt =
let mark_unreachable () =
let mark ppt =
if not (Property_status.automatically_computed ppt) then begin
- Value_parameters.debug "Marking property %a as dead"
+ Self.debug "Marking property %a as dead"
Description.pp_property ppt;
let emit =
- Property_status.emit ~distinct:false Value_util.emitter ~hyps:[]
+ Property_status.emit ~distinct:false Eva_utils.emitter ~hyps:[]
in
let reach_p = Property.ip_reachable_ppt ppt in
emit ppt Property_status.True;
@@ -73,7 +73,7 @@ let mark_unreachable () =
let mark_status kf =
(* Do not mark preconditions as dead if they are not analyzed in
non-dead code. Otherwise, the consolidation does strange things. *)
- if not (Value_util.skip_specifications kf) ||
+ if not (Eva_utils.skip_specifications kf) ||
Builtins.is_builtin_overridden kf
then begin
(* Setup all precondition statuses for [kf]: maybe it has
@@ -187,10 +187,10 @@ let mark_green_and_red () =
| `True -> Property_status.True, "valid"
| `False -> Property_status.False_if_reachable, "invalid"
in
- Property_status.emit ~distinct Value_util.emitter ~hyps:[] ip status;
+ Property_status.emit ~distinct Eva_utils.emitter ~hyps:[] ip status;
let source = fst loc in
let text_ca = code_annotation_text ca in
- Value_parameters.result ~once:true ~source "%s%a got final status %s."
+ Self.result ~once:true ~source "%s%a got final status %s."
text_ca Description.pp_named p text_status;
in
begin
@@ -230,7 +230,7 @@ let mark_invalid_initializers () =
let status = Property_status.False_and_reachable in
let distinct = false (* see comment in mark_green_and_red above *) in
Red_statuses.add_red_property Kglobal ip;
- Property_status.emit ~distinct Value_util.emitter ~hyps:[] ip status;
+ Property_status.emit ~distinct Eva_utils.emitter ~hyps:[] ip status;
end
| _ -> ()
in
diff --git a/src/plugins/value/legacy/eval_op.ml b/src/plugins/value/legacy/eval_op.ml
index 966726399171fb0f62b0454284db9e9fd23211eb..17c7822a2d94e30d1659b7e5533dc23919fb59aa 100644
--- a/src/plugins/value/legacy/eval_op.ml
+++ b/src/plugins/value/legacy/eval_op.ml
@@ -49,7 +49,7 @@ let v_uninit_of_offsetmap ~typ offsm =
V_Offsetmap.find ~validity ~conflate_bottom:false ~offsets ~size offsm
let backward_comp_int_left positive comp l r =
- if (Value_parameters.UndefinedPointerComparisonPropagateAll.get())
+ if (Parameters.UndefinedPointerComparisonPropagateAll.get())
&& not (Cvalue_forward.are_comparable comp l r)
then l
else
@@ -167,7 +167,7 @@ let apply_on_all_locs f loc state =
| Int_Base.Top -> state
| Int_Base.Value _ as size ->
let loc = Locations.valid_part Locations.Read loc in
- let plevel = Value_parameters.ArrayPrecisionLevel.get () in
+ let plevel = Parameters.ArrayPrecisionLevel.get () in
let ilevel = Int_set.get_small_cardinal () in
let limit = max plevel ilevel in
let apply_f base ival state =
diff --git a/src/plugins/value/legacy/eval_terms.ml b/src/plugins/value/legacy/eval_terms.ml
index c36e84a45b30286e18f983451fdff6d6a4171a81..ec1f608362e8d54a05ca368e77c39472b9644eb1 100644
--- a/src/plugins/value/legacy/eval_terms.ml
+++ b/src/plugins/value/legacy/eval_terms.ml
@@ -108,14 +108,14 @@ let track_alarms b = function
let display_evaluation_error ~loc = function
| CAlarm -> ()
| pa ->
- Value_parameters.result ~source:(fst loc) ~once:true
+ Self.result ~source:(fst loc) ~once:true
"cannot evaluate ACSL term, %a" pretty_logic_evaluation_error pa
(* Warning mode use when performing _reductions_ in the logic ( ** not **
evaluation). "Logic alarms" are ignored, and the reduction proceeds as if
they had not occurred. *)
let alarm_reduce_mode () =
- if Value_parameters.ReduceOnLogicAlarms.get () then Ignore else Fail
+ if Parameters.ReduceOnLogicAlarms.get () then Ignore else Fail
let find_indeterminate ~alarm_mode state loc =
let is_invalid = not Locations.(is_valid Read loc) in
@@ -853,7 +853,7 @@ let eval_logic_memchr_off builtin env s c n =
- otherwise, allocation always succeeds. *)
let eval_is_allocable size =
let size_ok = Builtins_malloc.alloc_size_ok size in
- match size_ok, Value_parameters.AllocReturnsNull.get () with
+ match size_ok, Parameters.AllocReturnsNull.get () with
| Alarmset.False, _ -> False
| Alarmset.Unknown, _ | _, true -> Unknown
| Alarmset.True, false -> True
@@ -985,7 +985,7 @@ let forward_binop_by_type typ =
let forward_binop typ v1 op v2 =
match op with
| Eq | Ne | Le | Lt | Ge | Gt ->
- let comp = Value_util.conv_comp op in
+ let comp = Eva_utils.conv_comp op in
if Cil.isPointerType typ || Cvalue_forward.are_comparable comp v1 v2
then forward_binop_by_type typ v1 op v2
else Cvalue.V.zero_or_one
@@ -1118,7 +1118,7 @@ let rec eval_term ~alarm_mode env t =
| Cvalue.V.Not_based_on_null -> None, None
| LogicEvalError e ->
if e <> CAlarm then
- Value_parameters.result ~source:(fst t.term_loc) ~once:true
+ Self.result ~source:(fst t.term_loc) ~once:true
"@[<hov 0>Cannot evaluate@ range bound %a@ (%a). Approximating@]"
Printer.pp_term term pretty_logic_evaluation_error e;
None, None
@@ -1330,7 +1330,7 @@ let rec eval_term ~alarm_mode env t =
and eval_binop ~alarm_mode env op t1 t2 =
if not (isLogicNonCompositeType t1.term_type) then
- if Value_parameters.debug_atleast 1 then
+ if Self.debug_atleast 1 then
unsupported (Format.asprintf
"operation (%a) %a (%a) on non-supported type %a"
Printer.pp_term t1
@@ -1378,7 +1378,7 @@ and eval_tif : 'a. (alarm_mode:_ -> _ -> _ -> 'a eval_result) -> ('a -> 'a -> 'a
let vtrue = eval ~alarm_mode env ttrue in
let vfalse = eval ~alarm_mode env tfalse in
if not (same_etype vtrue.etype vfalse.etype) then
- Value_parameters.failure ~current:true
+ Self.failure ~current:true
"Incoherent types in conditional: %a vs. %a. \
Please report"
Printer.pp_typ vtrue.etype Printer.pp_typ vfalse.etype;
@@ -1983,7 +1983,7 @@ and reduce_by_left_relation ~alarm_mode env positive tl rel tr =
let exact_location = eval_term_as_exact_locs ~alarm_mode env tl in
let rtl = eval_term ~alarm_mode env tr in
let cond_v = rtl.eover in
- let comp = Value_util.conv_relation rel in
+ let comp = Eva_utils.conv_relation rel in
match exact_location with
| Logic_var logic_var ->
let cvalue = LogicVarEnv.find logic_var env.logic_vars in
@@ -2395,7 +2395,7 @@ and eval_predicate env pred =
in
let typ_pointed = Logic_typing.ctype_of_pointed tsets.term_type in
(* Check if we are trying to write in a const l-value *)
- if kind = Write && Value_util.is_const_write_invalid typ_pointed
+ if kind = Write && Eva_utils.is_const_write_invalid typ_pointed
then False
else
let eover, eunder, indeterminate, empty =
@@ -2629,9 +2629,9 @@ and eval_predicate env pred =
| "\\warning", _ -> begin
match args with
| [{ term_node = TConst(LStr(str))}] ->
- Value_parameters.warning "reached \\warning(\"%s\")" str; Unknown
+ Self.warning "reached \\warning(\"%s\")" str; Unknown
| _ ->
- Value_parameters.abort
+ Self.abort
"Wrong argument: \\warning expects a constant string"
end
| "\\subset", [argl;argr] ->
@@ -2745,6 +2745,16 @@ and predicate_deps env pred =
try Some (do_eval env pred)
with LogicEvalError _ -> None
+let annot_predicate_deps ~pre ~here predicate =
+ let env = env_annot ~pre ~here () in
+ let logic_deps = predicate_deps env predicate in
+ let join logic_deps =
+ Cil_datatype.Logic_label.Map.fold
+ (fun _ -> Locations.Zone.join)
+ logic_deps
+ Locations.Zone.bottom
+ in
+ Option.map join logic_deps
(* -------------------------------------------------------------------------- *)
(* --- Export --- *)
diff --git a/src/plugins/value/legacy/eval_terms.mli b/src/plugins/value/legacy/eval_terms.mli
index e63e6a531800d52ccbbbfc1ca29564cb2e27ef70..cff8567815ab453e72462ac147747305a2604fb3 100644
--- a/src/plugins/value/legacy/eval_terms.mli
+++ b/src/plugins/value/legacy/eval_terms.mli
@@ -52,14 +52,15 @@ exception LogicEvalError of logic_evaluation_error
type labels_states = Cvalue.Model.t Cil_datatype.Logic_label.Map.t
(** Evaluation environment. Currently available are function Pre and Post, or
- the environment to evaluate an annotation *)
+ the environment to evaluate an annotation. *)
type eval_env
val make_env: Model.t Abstract_domain.logic_environment -> Model.t -> eval_env
val env_pre_f : pre:Model.t -> unit -> eval_env
val env_annot :
- ?c_labels:labels_states -> pre:Model.t -> here:Model.t -> unit -> eval_env
+ ?c_labels:labels_states -> pre:Cvalue.Model.t -> here:Cvalue.Model.t ->
+ unit -> eval_env
val env_post_f :
?c_labels:labels_states -> pre:Model.t -> post:Model.t ->
result:varinfo option -> unit -> eval_env
@@ -71,7 +72,7 @@ val env_only_here: Model.t -> eval_env
val env_current_state: eval_env -> Model.t
(** Dependencies needed to evaluate a term or a predicate *)
-type logic_deps = Zone.t Cil_datatype.Logic_label.Map.t
+type logic_deps = Locations.Zone.t Cil_datatype.Logic_label.Map.t
(** Three modes to handle the alarms when evaluating a logical term. *)
type alarm_mode =
@@ -110,7 +111,22 @@ val eval_tlval_as_zone :
val eval_predicate :
eval_env -> predicate -> predicate_status
-val predicate_deps: eval_env -> predicate -> logic_deps option
+(** [predicate_deps env p] computes the logic dependencies needed to evaluate
+ [p] in the given evaluation environment [env].
+ Returns None on either an evaluation error or on unsupported construct. *)
+val predicate_deps: eval_env -> Cil_types.predicate -> logic_deps option
val reduce_by_predicate :
eval_env -> bool -> predicate -> eval_env
+
+
+
+[@@@ api_start]
+(** [annot_predicate_deps ~pre ~here p] computes the logic dependencies needed
+ to evaluate the predicate [p] in a code annotation in cvalue state [here],
+ in a function whose pre-state is [pre].
+ Returns None on either an evaluation error or on unsupported construct. *)
+val annot_predicate_deps:
+ pre:Cvalue.Model.t -> here:Cvalue.Model.t ->
+ Cil_types.predicate -> Locations.Zone.t option
+[@@@ api_end]
diff --git a/src/plugins/value/legacy/function_args.ml b/src/plugins/value/legacy/function_args.ml
index 316201b1fd52de26cabeddb68f86f98dab3bde25..ce7e0ffd46503fcc7c2a51009692a612832ae6ff 100644
--- a/src/plugins/value/legacy/function_args.ml
+++ b/src/plugins/value/legacy/function_args.ml
@@ -54,7 +54,7 @@ let compute_actual state e =
let o =
try offsetmap_of_lv state lv
with Abstract_interp.Error_Top ->
- Value_parameters.abort ~current:true
+ Self.abort ~current:true
"Function argument %a has unknown size. Aborting" Printer.pp_exp e;
in begin
match o with
diff --git a/src/plugins/value/value_parameters.ml b/src/plugins/value/parameters.ml
similarity index 95%
rename from src/plugins/value/value_parameters.ml
rename to src/plugins/value/parameters.ml
index 11f8cce3e58081ea89ad878f2ad8534a50e6507e..c03116c950d4c2eaba727f456f89bc2facc512be 100644
--- a/src/plugins/value/value_parameters.ml
+++ b/src/plugins/value/parameters.ml
@@ -20,6 +20,8 @@
(* *)
(**************************************************************************)
+open Self
+
(* Dependencies to kernel options *)
let kernel_parameters_correctness = [
Kernel.MainFunction.parameter;
@@ -43,9 +45,8 @@ let kernel_parameters_correctness = [
let parameters_correctness = ref Typed_parameter.Set.empty
let parameters_tuning = ref Typed_parameter.Set.empty
let add_dep p =
- State_dependency_graph.add_codependencies
- ~onto:Db.Value.self
- [State.get p.Typed_parameter.name]
+ let state = State.get p.Typed_parameter.name in
+ State_builder.Proxy.extend [state] Self.proxy
let add_correctness_dep p =
if Typed_parameter.Set.mem p !parameters_correctness then
Kernel.abort "adding correctness parameter %a twice"
@@ -61,57 +62,6 @@ let add_precision_dep p =
let () = List.iter add_correctness_dep kernel_parameters_correctness
-include Plugin.Register
- (struct
- let name = "Eva"
- let shortname = "eva"
- let help =
- "automatically computes variation domains for the variables of the program"
- end)
-
-let () = Help.add_aliases ~visible:false [ "-value-h"; "-val-h" ]
-let () = add_plugin_output_aliases ~visible:false ~deprecated:true [ "value" ]
-
-(* Debug categories. *)
-let dkey_initial_state = register_category "initial-state"
-let dkey_final_states = register_category "final-states"
-let dkey_summary = register_category "summary"
-let dkey_pointer_comparison = register_category "pointer-comparison"
-let dkey_cvalue_domain = register_category "d-cvalue"
-let dkey_incompatible_states = register_category "incompatible-states"
-let dkey_iterator = register_category "iterator"
-let dkey_callbacks = register_category "callbacks"
-let dkey_widening = register_category "widening"
-let dkey_recursion = register_category "recursion"
-
-let () =
- let activate dkey = add_debug_keys dkey in
- List.iter activate
- [dkey_initial_state; dkey_final_states; dkey_summary; dkey_cvalue_domain;
- dkey_recursion; ]
-
-(* Warning categories. *)
-let wkey_alarm = register_warn_category "alarm"
-let wkey_locals_escaping = register_warn_category "locals-escaping"
-let wkey_garbled_mix = register_warn_category "garbled-mix"
-let () = set_warn_status wkey_garbled_mix Log.Winactive
-let wkey_builtins_missing_spec = register_warn_category "builtins:missing-spec"
-let wkey_builtins_override = register_warn_category "builtins:override"
-let wkey_libc_unsupported_spec = register_warn_category "libc:unsupported-spec"
-let wkey_loop_unroll_auto = register_warn_category "loop-unroll:auto"
-let () = set_warn_status wkey_loop_unroll_auto Log.Wfeedback
-let wkey_loop_unroll_partial = register_warn_category "loop-unroll:partial"
-let () = set_warn_status wkey_loop_unroll_partial Log.Wfeedback
-let wkey_missing_loop_unroll = register_warn_category "loop-unroll:missing"
-let () = set_warn_status wkey_missing_loop_unroll Log.Winactive
-let wkey_missing_loop_unroll_for = register_warn_category "loop-unroll:missing:for"
-let () = set_warn_status wkey_missing_loop_unroll_for Log.Winactive
-let wkey_signed_overflow = register_warn_category "signed-overflow"
-let wkey_invalid_assigns = register_warn_category "invalid-assigns"
-let () = set_warn_status wkey_invalid_assigns Log.Wfeedback
-let wkey_experimental = register_warn_category "experimental"
-let wkey_unknown_size = register_warn_category "unknown-size"
-
module ForceValues =
WithOutput
(struct
@@ -848,7 +798,7 @@ module SplitReturn =
module SplitGlobalStrategy = State_builder.Ref (Split_strategy)
(struct
let default () = Split_strategy.NoSplit
- let name = "Value_parameters.SplitGlobalStrategy"
+ let name = "Parameters.SplitGlobalStrategy"
let dependencies = [SplitReturn.self]
end)
let () =
@@ -1440,11 +1390,3 @@ let parameters_correctness =
Typed_parameter.Set.elements !parameters_correctness
let parameters_tuning =
Typed_parameter.Set.elements !parameters_tuning
-
-
-
-(*
-Local Variables:
-compile-command: "make -C ../../.."
-End:
-*)
diff --git a/src/plugins/value/value_parameters.mli b/src/plugins/value/parameters.mli
similarity index 67%
rename from src/plugins/value/value_parameters.mli
rename to src/plugins/value/parameters.mli
index a05cde2a46d6bbdf015865524e5dda608eb4d91d..795cc6ab00344c8cadda67ace9ea91b6d98ac22c 100644
--- a/src/plugins/value/value_parameters.mli
+++ b/src/plugins/value/parameters.mli
@@ -20,8 +20,6 @@
(* *)
(**************************************************************************)
-include Plugin.General_services
-
module ForceValues: Parameter_sig.With_output
module EnumerateCond: Parameter_sig.Bool
@@ -150,99 +148,24 @@ val configure_precision: unit -> unit
val parameters_correctness: Typed_parameter.t list
val parameters_tuning: Typed_parameter.t list
-(** Debug categories responsible for printing initial and final states of Value.
- Enabled by default, but can be disabled via the command-line:
- -value-msg-key="-initial_state,-final_state" *)
-val dkey_initial_state : category
-val dkey_final_states : category
-val dkey_summary : category
-
-(** Warning category used when emitting an alarm in "warning" mode. *)
-val wkey_alarm: warn_category
-
-(** Warning category used for the warning "locals escaping scope". *)
-val wkey_locals_escaping: warn_category
-
-(** Warning category used to print garbled mix *)
-val wkey_garbled_mix: warn_category
-
-(** Warning category used for "cannot use builtin due to missing spec" *)
-val wkey_builtins_missing_spec: warn_category
-
-(** Warning category used for "definition overridden by builtin" *)
-val wkey_builtins_override: warn_category
-
-(** Warning category used for calls to libc functions whose specification
- is currently unsupported. *)
-val wkey_libc_unsupported_spec : warn_category
-
-(** Warning category used for "Automatic loop unrolling" *)
-val wkey_loop_unroll_auto : warn_category
-
-(** Warning category used for "loop not completely unrolled" *)
-val wkey_loop_unroll_partial : warn_category
-
-(** Warning category used to identify loops without unroll annotations *)
-val wkey_missing_loop_unroll : warn_category
-
-(** Warning category used to identify for loops without unroll annotations *)
-val wkey_missing_loop_unroll_for : warn_category
-
-(** Warning category for signed overflows *)
-val wkey_signed_overflow : warn_category
-
-(** Warning category for 'completely invalid' assigns clause *)
-val wkey_invalid_assigns : warn_category
-
-(** Warning category for experimental domains or features. *)
-val wkey_experimental : warn_category
-
-(** Warning category for 'size of type T cannot be computed'. *)
-val wkey_unknown_size : warn_category
-
-(** Debug category used to print information about invalid pointer comparisons*)
-val dkey_pointer_comparison: category
-
-(** Debug category used to print the cvalue domain on Frama_C_[dump|show]_each
- functions. *)
-val dkey_cvalue_domain: category
-
-(* Print non-bottom product of states with no concretization, revealed by
- an evaluation leading to bottom without alarms. *)
-val dkey_incompatible_states: category
-
-(** Debug category used to print information about the iteration *)
-val dkey_iterator : category
-
-(** Debug category used when using Eva callbacks when recording the results of
- a function analysis. *)
-val dkey_callbacks : category
-
-(** Debug category used to print the usage of widenings. *)
-val dkey_widening : category
-
-(** Debug category used to print messages about recursive calls. *)
-val dkey_recursion : category
-
(** Registers available cvalue builtins for the -eva-builtin option. *)
val register_builtin: string -> unit
(** Registers available domain names for the -eva-domains option. *)
val register_domain: name:string -> descr:string -> unit
-(** Returns the list (name, descr) of currently enabled domains. *)
+[@@@ api_start]
+(** Configuration of the analysis. *)
+
+(** Returns the list (name, descr) of currently enabled abstract domains. *)
val enabled_domains: unit -> (string * string) list
-(** [use_builtin kf b] adds a builtin override for function `kf` to
- builtin `b`. *)
+(** [use_builtin kf name] instructs the analysis to use the builtin [name]
+ to interpret calls to function [kf].
+ Raises [Not_found] if there is no builtin of name [name]. *)
val use_builtin: Cil_types.kernel_function -> string -> unit
-(** [use_global_value_partitioning vi] enable value partitioning on the global
- variable `vi`. *)
+(** [use_global_value_partitioning vi] instructs the analysis to use
+ value partitioning on the global variable [vi]. *)
val use_global_value_partitioning: Cil_types.varinfo -> unit
-
-(*
-Local Variables:
-compile-command: "make -C ../../.."
-End:
-*)
+[@@@ api_end]
diff --git a/src/plugins/value/partitioning/partition.ml b/src/plugins/value/partitioning/partition.ml
index cf2fac0814ab6c8ed278aff661939b3ca4d0c0fd..db974e60a0c4aa9b96b3690a2f8b1ff15d5472bd 100644
--- a/src/plugins/value/partitioning/partition.ml
+++ b/src/plugins/value/partitioning/partition.ml
@@ -372,7 +372,7 @@ struct
let fail ~exp message =
let source = fst exp.Cil_types.eloc in
let warn_and_raise message =
- Value_parameters.warning ~source ~once:true "%s" message;
+ Self.warning ~source ~once:true "%s" message;
raise Operation_failed
in
Pretty_utils.ksfprintf warn_and_raise message
@@ -476,7 +476,7 @@ struct
let x = Abstract.Dom.evaluate_predicate env state' predicate in
if x == Unknown
then
- Value_parameters.warning ~source ~once:true
+ Self.warning ~source ~once:true
"failing to learn perfectly from split predicate";
if Abstract.Dom.equal state' state then raise Operation_failed;
let value = if positive then Integer.one else Integer.zero in
@@ -502,7 +502,7 @@ struct
if Cvalue.V.cardinal_zero_or_one (get value)
then Some (stamp, 0)
else begin
- Value_parameters.result ~once:true ~current:true
+ Self.result ~once:true ~current:true
"cannot properly split on \\result == %a"
Abstract_interp.Int.pretty i;
None
@@ -569,8 +569,8 @@ struct
| None -> min_unroll
| Some i ->
let source = fst (Cil_datatype.Stmt.loc stmt) in
- Value_parameters.warning ~once:true ~current:true ~source
- ~wkey:Value_parameters.wkey_loop_unroll_auto
+ Self.warning ~once:true ~current:true ~source
+ ~wkey:Self.wkey_loop_unroll_auto
"Automatic loop unrolling.";
i
with
@@ -590,8 +590,8 @@ struct
| (h, limit) :: tl ->
if h >= limit then begin
if limit > 0 then
- Value_parameters.warning ~once:true ~current:true
- ~wkey:Value_parameters.wkey_loop_unroll_partial
+ Self.warning ~once:true ~current:true
+ ~wkey:Self.wkey_loop_unroll_partial
"loop not completely unrolled";
k
end
diff --git a/src/plugins/value/partitioning/partitioning_parameters.ml b/src/plugins/value/partitioning/partitioning_parameters.ml
index 77aecd2890d236914afb00f77473f73f280a2f4e..1bb96c5efea6dbabf5f8a3ac9790d28d222df492 100644
--- a/src/plugins/value/partitioning/partitioning_parameters.ml
+++ b/src/plugins/value/partitioning/partitioning_parameters.ml
@@ -20,7 +20,7 @@
(* *)
(**************************************************************************)
-open Value_parameters
+open Parameters
open Eva_annotations
open Cil_types
@@ -69,10 +69,10 @@ struct
| loop_kind :: _ ->
let wkey =
if loop_kind = "for"
- then Value_parameters.wkey_missing_loop_unroll_for
- else Value_parameters.wkey_missing_loop_unroll
+ then Self.wkey_missing_loop_unroll_for
+ else Self.wkey_missing_loop_unroll
in
- Value_parameters.warning
+ Self.warning
~wkey ~source:(fst (Cil_datatype.Stmt.loc stmt)) ~once:true
"%s loop without unroll annotation" loop_kind
@@ -142,8 +142,8 @@ struct
let call_return_policy =
Partition.{
- callee_splits = Value_parameters.InterproceduralSplits.get ();
- callee_history = Value_parameters.InterproceduralHistory.get ();
+ callee_splits = Parameters.InterproceduralSplits.get ();
+ callee_history = Parameters.InterproceduralHistory.get ();
caller_history = true;
history_size = history_size;
}
diff --git a/src/plugins/value/partitioning/per_stmt_slevel.ml b/src/plugins/value/partitioning/per_stmt_slevel.ml
index 8ee8d668fcd7656eb067d52483726c4cdf643214..8f851352d8140efd44ce9282449c60bec8fb3af9 100644
--- a/src/plugins/value/partitioning/per_stmt_slevel.ml
+++ b/src/plugins/value/partitioning/per_stmt_slevel.ml
@@ -70,7 +70,7 @@ let kf_contains_slevel_directive kf =
(Kernel_function.get_definition kf).sallstmts
let compute kf =
- let default_slevel = Value_util.get_slevel kf in
+ let default_slevel = Eva_utils.get_slevel kf in
if not (kf_contains_slevel_directive kf) then
Global default_slevel (* No slevel directive *), NoMerge
else
@@ -132,7 +132,7 @@ let compute kf =
then NoMerge
else Merge (fun s -> Cil_datatype.Stmt.Hashtbl.mem h_merge s))
with Stack.Empty ->
- Value_parameters.abort
+ Self.abort
"Incorrectly nested slevel directives in function %a"
Kernel_function.pretty kf
@@ -142,7 +142,7 @@ module ForKf = Kernel_function.Make_Table
(struct
let size = 17
let dependencies =
- [Ast.self; Value_parameters.SemanticUnrollingLevel.self;]
+ [Ast.self; Parameters.SemanticUnrollingLevel.self;]
let name = "Value.Local_slevel.ForKf"
end)
diff --git a/src/plugins/value/partitioning/split_return.ml b/src/plugins/value/partitioning/split_return.ml
index c705fb09d4c455f65a48b83a8388a0f1c2828136..fe4ee995d773c8e3bf51c28d2d70101680c6c161 100644
--- a/src/plugins/value/partitioning/split_return.ml
+++ b/src/plugins/value/partitioning/split_return.ml
@@ -258,8 +258,8 @@ let find_auto_strategy kf =
module KfStrategy = Kernel_function.Make_Table(Split_strategy)
(struct
let size = 17
- let dependencies = [Value_parameters.SplitReturnFunction.self;
- Value_parameters.SplitGlobalStrategy.self;
+ let dependencies = [Parameters.SplitReturnFunction.self;
+ Parameters.SplitGlobalStrategy.self;
AutoStrategy.self]
let name = "Value.Split_return.Kfstrategy"
end)
@@ -269,11 +269,11 @@ let kf_strategy =
KfStrategy.memo
(fun kf ->
try (* User strategies take precedence *)
- match Value_parameters.SplitReturnFunction.find kf with
+ match Parameters.SplitReturnFunction.find kf with
| Split_strategy.SplitAuto -> find_auto_strategy kf
| s -> s
with Not_found ->
- match Value_parameters.SplitGlobalStrategy.get () with
+ match Parameters.SplitGlobalStrategy.get () with
| Split_strategy.SplitAuto -> find_auto_strategy kf
| s -> s
)
@@ -297,16 +297,16 @@ let pretty_strategies fmt =
| Some SplitAuto -> pp_one "auto" (pp_kf kf) (kf_strategy kf)
| Some s -> pp_one "user" (pp_kf kf) s
in
- Value_parameters.SplitReturnFunction.iter pp_user;
- if not (Value_parameters.SplitReturnFunction.is_empty ()) &&
- match Value_parameters.SplitGlobalStrategy.get () with
+ Parameters.SplitReturnFunction.iter pp_user;
+ if not (Parameters.SplitReturnFunction.is_empty ()) &&
+ match Parameters.SplitGlobalStrategy.get () with
| Split_strategy.NoSplit | Split_strategy.SplitAuto -> false
| _ -> true
then Format.fprintf fmt "@[other functions:@]@ ";
- begin match Value_parameters.SplitGlobalStrategy.get () with
+ begin match Parameters.SplitGlobalStrategy.get () with
| SplitAuto ->
let pp_auto kf s =
- if not (Value_parameters.SplitReturnFunction.mem kf) then
+ if not (Parameters.SplitReturnFunction.mem kf) then
let s = SplitEqList (Datatype.Integer.Set.elements s) in
pp_one "auto" (pp_kf kf) s
in
@@ -317,10 +317,10 @@ let pretty_strategies fmt =
Format.fprintf fmt "@]"
let pretty_strategies () =
- if not (Value_parameters.SplitReturnFunction.is_empty ()) ||
- (Value_parameters.SplitGlobalStrategy.get () != Split_strategy.NoSplit)
+ if not (Parameters.SplitReturnFunction.is_empty ()) ||
+ (Parameters.SplitGlobalStrategy.get () != Split_strategy.NoSplit)
then
- Value_parameters.result "Splitting return states on:@.%t" pretty_strategies
+ Self.result "Splitting return states on:@.%t" pretty_strategies
(*
diff --git a/src/plugins/value/partitioning/trace_partitioning.ml b/src/plugins/value/partitioning/trace_partitioning.ml
index 61f2b7a458ffc32bdefebcfae7d7048304662d08..c4a30b874ecaa99bd7dc1ee5ccbd1cb01b271c71 100644
--- a/src/plugins/value/partitioning/trace_partitioning.ml
+++ b/src/plugins/value/partitioning/trace_partitioning.ml
@@ -28,10 +28,10 @@ module Make
(Abstract: Abstractions.Eva)
(Kf : sig val kf: kernel_function end) =
struct
- module Parameters = Partitioning_parameters.Make (Kf)
+ module Partition_parameters = Partitioning_parameters.Make (Kf)
open Kf
- open Parameters
+ open Partition_parameters
module Domain = Abstract.Dom
@@ -217,13 +217,13 @@ struct
let transfer = Flow.transfer
let output_slevel : int -> unit =
- let slevel_display_step = Value_parameters.ShowSlevel.get () in
+ let slevel_display_step = Parameters.ShowSlevel.get () in
let max_displayed = ref 0 in
fun x ->
if x >= !max_displayed + slevel_display_step
then
let rounded = x / slevel_display_step * slevel_display_step in
- Value_parameters.feedback ~once:true ~current:true
+ Self.feedback ~once:true ~current:true
"Trace partitioning superposing up to %d states"
rounded;
max_displayed := rounded
@@ -231,7 +231,7 @@ struct
let partitioning_feedback dest flow stmt =
output_slevel dest.incoming_states;
(* Debug information. *)
- Value_parameters.debug ~dkey:Value_parameters.dkey_iterator ~current:true
+ Self.debug ~dkey:Self.dkey_iterator ~current:true
"reached statement %d with %d incoming states, %d to propagate"
stmt.sid dest.incoming_states (flow_size flow)
@@ -279,7 +279,7 @@ struct
else begin
(* Propagate the join of the two states *)
if is_loop_head then
- Value_parameters.feedback ~level:1 ~once:true ~current:true
+ Self.feedback ~level:1 ~once:true ~current:true
"starting to merge loop iterations";
Some (Domain.join previous_state current_state)
end
@@ -321,8 +321,8 @@ struct
Some curr
(* Apply widening *)
else begin
- Value_parameters.feedback ~level:1 ~once:true ~current:true
- ~dkey:Value_parameters.dkey_widening
+ Self.feedback ~level:1 ~once:true ~current:true
+ ~dkey:Self.dkey_widening
"applying a widening at this point";
(* We join the previous widening state with the previous iteration
state so as to allow the intermediate(s) iteration(s) (between
diff --git a/src/plugins/value/register.ml b/src/plugins/value/register.ml
index 2e585515cff0920c414234bc28d18bad920f517f..bd3132bef630720991538599754ad62c8d59eb9a 100644
--- a/src/plugins/value/register.ml
+++ b/src/plugins/value/register.ml
@@ -23,21 +23,13 @@
open Cil_types
open Locations
-let compute () =
- (* Nothing to recompute when Value has already been computed. This boolean
- is automatically cleared when an option of Value changes, because they
- are registered as dependencies on [Db.Value.self] in {!Value_parameters}.*)
- if not (Db.Value.is_computed ()) then Analysis.force_compute ()
-
-let _self =
- Db.register_compute "Value.compute" [ Db.Value.self ] Db.Value.compute compute
-
-let () = Value_parameters.ForceValues.set_output_dependencies [Db.Value.self]
+let () = Db.Value.compute := Analysis.compute
+let () = Parameters.ForceValues.set_output_dependencies [Self.state]
let main () =
(* Value computations *)
- if Value_parameters.ForceValues.get () then !Db.Value.compute ();
- if Db.Value.is_computed () then Red_statuses.report ()
+ if Parameters.ForceValues.get () then Analysis.compute ();
+ if Analysis.is_computed () then Red_statuses.report ()
let () = Db.Main.extend main
@@ -65,7 +57,7 @@ let assigns_inputs_to_zone state assigns =
acc
l
with Eval_terms.LogicEvalError e ->
- Value_parameters.warning ~current:true ~once:true
+ Self.warning ~current:true ~once:true
"Failed to interpret inputs in assigns clause '%a'%a"
Printer.pp_from asgn eval_error_reason e;
Zone.top
@@ -84,7 +76,7 @@ let assigns_outputs_aux ~eval ~bot ~top ~join state ~result assigns =
let z = eval env out in
join z acc
with Eval_terms.LogicEvalError e ->
- Value_parameters.warning ~current:true ~once:true
+ Self.warning ~current:true ~once:true
"Failed to interpret assigns clause '%a'%a"
Printer.pp_term out eval_error_reason e;
join top acc
@@ -138,7 +130,7 @@ let use_spec_instead_of_definition kf =
not (Kernel_function.is_definition kf) ||
Ast_info.is_frama_c_builtin (Kernel_function.get_name kf) ||
Builtins.is_builtin_overridden kf ||
- Kernel_function.Set.mem kf (Value_parameters.UsePrototype.get ())
+ Kernel_function.Set.mem kf (Parameters.UsePrototype.get ())
let eval_predicate ~pre ~here p =
let open Eval_terms in
@@ -262,7 +254,7 @@ module Eval = struct
bot_value (eval >>-: snd)
let eval_lval ?with_alarms deps state lval =
- let expr = Value_util.lval_to_exp lval in
+ let expr = Eva_utils.lval_to_exp lval in
let res, valuation = eval_expr_with_valuation ?with_alarms deps state expr in
let typ = match valuation with
| None -> Cil.typeOfLval lval
@@ -418,7 +410,7 @@ module Export (Eval : Eval) = struct
let lval_to_zone_with_deps_state state ~for_writing ~deps lv =
let deps, r = lval_to_precise_loc_with_deps_state state ~deps lv in
let r = (* No write effect if [lv] is const *)
- if for_writing && (Value_util.is_const_write_invalid (Cil.typeOfLval lv))
+ if for_writing && (Eva_utils.is_const_write_invalid (Cil.typeOfLval lv))
then Precise_locs.loc_bottom
else r
in
diff --git a/src/plugins/value/register.mli b/src/plugins/value/register.mli
index c27dd17263fd3f5deb3581b5ebdd0f6c3b2674f5..0f54ee776453869a4b44e2675c264a5535429fb9 100644
--- a/src/plugins/value/register.mli
+++ b/src/plugins/value/register.mli
@@ -20,6 +20,9 @@
(* *)
(**************************************************************************)
-(** Functions of the Value plugin registered in {!Db}.
+(** Functions of the Value plugin registered in {!Db}. Only three functions
+ are exported. *)
- Nothing is exported. *)
+val eval_deps : Cvalue_domain.State.t -> Cil_types.exp -> Locations.Zone.t
+val eval_deps_lval : Cvalue_domain.State.t -> Cil_types.lval -> Locations.Zone.t
+val eval_deps_addr : Cvalue_domain.State.t -> Cil_types.lval -> Locations.Zone.t
diff --git a/src/plugins/value/self.ml b/src/plugins/value/self.ml
new file mode 100644
index 0000000000000000000000000000000000000000..f0596f76bbcd557dbff1f07eca5e8f5a38cf4b8a
--- /dev/null
+++ b/src/plugins/value/self.ml
@@ -0,0 +1,134 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2021 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+include Plugin.Register
+ (struct
+ let name = "Eva"
+ let shortname = "eva"
+ let help =
+ "automatically computes variation domains for the variables of the program"
+ end)
+
+let () = Help.add_aliases ~visible:false [ "-value-h"; "-val-h" ]
+let () = add_plugin_output_aliases ~visible:false ~deprecated:true [ "value" ]
+
+(* Do not add dependencies to Kernel parameters here, but at the top of
+ Parameters. *)
+let kernel_dependencies =
+ [ Ast.self;
+ Alarms.self;
+ Annotations.code_annot_state; ]
+
+let dependencies = Db.Value.self :: kernel_dependencies
+
+let proxy = State_builder.Proxy.(create "eva" Forward dependencies)
+let state = State_builder.Proxy.get proxy
+
+let () = State_builder.Proxy.extend [state] Db.Value.proxy
+
+
+(* Current state of the analysis *)
+type computation_state = NotComputed | Computing | Computed | Aborted
+
+module ComputationState =
+struct
+ let to_string = function
+ | NotComputed -> "NotComputed"
+ | Computing -> "Computing"
+ | Computed -> "Computed"
+ | Aborted -> "Aborted"
+
+ module Prototype =
+ struct
+ include Datatype.Serializable_undefined
+ type t = computation_state
+ let name = "Eva.Analysis.ComputationState"
+ let pretty fmt s = Format.pp_print_string fmt (to_string s)
+ let reprs = [ NotComputed ; Computing ; Computed ; Aborted ]
+ let dependencies = [ state ]
+ let default () = NotComputed
+ end
+
+ module Datatype' = Datatype.Make (Prototype)
+ module Hook = Hook.Build (Prototype)
+ include (State_builder.Ref (Datatype') (Prototype))
+
+ let set s = set s; Hook.apply s
+ let () = add_hook_on_update (fun r -> Hook.apply !r)
+end
+
+let is_computed () =
+ match ComputationState.get () with
+ | Computed | Aborted -> true
+ | NotComputed | Computing -> false
+
+let current_computation_state = ComputationState.get
+let set_computation_state = ComputationState.set
+
+(* Register a hook on current computation state *)
+let register_computation_hook ?on f =
+ let f' = match on with
+ | None -> f
+ | Some s -> fun s' -> if s = s' then f s
+ in
+ ComputationState.Hook.extend f'
+
+
+(* Debug categories. *)
+let dkey_initial_state = register_category "initial-state"
+let dkey_final_states = register_category "final-states"
+let dkey_summary = register_category "summary"
+let dkey_pointer_comparison = register_category "pointer-comparison"
+let dkey_cvalue_domain = register_category "d-cvalue"
+let dkey_incompatible_states = register_category "incompatible-states"
+let dkey_iterator = register_category "iterator"
+let dkey_callbacks = register_category "callbacks"
+let dkey_widening = register_category "widening"
+let dkey_recursion = register_category "recursion"
+
+let () =
+ let activate dkey = add_debug_keys dkey in
+ List.iter activate
+ [dkey_initial_state; dkey_final_states; dkey_summary; dkey_cvalue_domain;
+ dkey_recursion; ]
+
+(* Warning categories. *)
+let wkey_alarm = register_warn_category "alarm"
+let wkey_locals_escaping = register_warn_category "locals-escaping"
+let wkey_garbled_mix = register_warn_category "garbled-mix"
+let () = set_warn_status wkey_garbled_mix Log.Winactive
+let wkey_builtins_missing_spec = register_warn_category "builtins:missing-spec"
+let wkey_builtins_override = register_warn_category "builtins:override"
+let wkey_libc_unsupported_spec = register_warn_category "libc:unsupported-spec"
+let wkey_loop_unroll_auto = register_warn_category "loop-unroll:auto"
+let () = set_warn_status wkey_loop_unroll_auto Log.Wfeedback
+let wkey_loop_unroll_partial = register_warn_category "loop-unroll:partial"
+let () = set_warn_status wkey_loop_unroll_partial Log.Wfeedback
+let wkey_missing_loop_unroll = register_warn_category "loop-unroll:missing"
+let () = set_warn_status wkey_missing_loop_unroll Log.Winactive
+let wkey_missing_loop_unroll_for = register_warn_category "loop-unroll:missing:for"
+let () = set_warn_status wkey_missing_loop_unroll_for Log.Winactive
+let wkey_signed_overflow = register_warn_category "signed-overflow"
+let wkey_invalid_assigns = register_warn_category "invalid-assigns"
+let () = set_warn_status wkey_invalid_assigns Log.Wfeedback
+let wkey_experimental = register_warn_category "experimental"
+let wkey_unknown_size = register_warn_category "unknown-size"
diff --git a/src/plugins/value/self.mli b/src/plugins/value/self.mli
new file mode 100644
index 0000000000000000000000000000000000000000..a710b296982494a2ebefc8ff8f20739db657d612
--- /dev/null
+++ b/src/plugins/value/self.mli
@@ -0,0 +1,79 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2021 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+include Plugin.General_services
+
+val proxy: State_builder.Proxy.t
+val state: State.t
+
+(** Return [true] iff the value analysis has been done. *)
+val is_computed: unit -> bool
+
+(** Computation state of the analysis. *)
+type computation_state = NotComputed | Computing | Computed | Aborted
+
+(** Get the current computation state of the analysis, updated by
+ [force_compute] and states updates. *)
+val current_computation_state : unit -> computation_state
+
+(** Set the current computation state. *)
+val set_computation_state: computation_state -> unit
+
+(** Registers a hook that will be called each time the analysis starts or
+ finishes. If [on] is given, the hook will only be called when the
+ analysis switches to this specific state. *)
+val register_computation_hook: ?on:computation_state ->
+ (computation_state -> unit) -> unit
+
+(** Debug categories responsible for printing initial and final states of Value.
+ Enabled by default, but can be disabled via the command-line:
+ -value-msg-key="-initial_state,-final_state" *)
+val dkey_initial_state : category
+val dkey_final_states : category
+val dkey_summary : category
+
+(** {2 Debug categories.} *)
+
+val dkey_pointer_comparison: category
+val dkey_cvalue_domain: category
+val dkey_incompatible_states: category
+val dkey_iterator : category
+val dkey_callbacks : category
+val dkey_widening : category
+val dkey_recursion : category
+
+(** {2 Warning categories.} *)
+
+val wkey_alarm: warn_category
+val wkey_locals_escaping: warn_category
+val wkey_garbled_mix: warn_category
+val wkey_builtins_missing_spec: warn_category
+val wkey_builtins_override: warn_category
+val wkey_libc_unsupported_spec : warn_category
+val wkey_loop_unroll_auto : warn_category
+val wkey_loop_unroll_partial : warn_category
+val wkey_missing_loop_unroll : warn_category
+val wkey_missing_loop_unroll_for : warn_category
+val wkey_signed_overflow : warn_category
+val wkey_invalid_assigns : warn_category
+val wkey_experimental : warn_category
+val wkey_unknown_size : warn_category
diff --git a/src/plugins/value/utils/backward_formals.ml b/src/plugins/value/utils/backward_formals.ml
index e01d275dd7f2c3555e384886330b9afcd7476e0f..48e98b856b1a2afbf5084b88512e4915c7cf5495 100644
--- a/src/plugins/value/utils/backward_formals.ml
+++ b/src/plugins/value/utils/backward_formals.ml
@@ -79,7 +79,7 @@ module WrittenFormals =
(struct
let size = 17
let dependencies = [Ast.self]
- let name = "Value_util.WrittenFormals"
+ let name = "Eva_utils.WrittenFormals"
end)
let written_formals = WrittenFormals.memo written_formals
diff --git a/src/plugins/value/utils/eva_annotations.ml b/src/plugins/value/utils/eva_annotations.ml
index c493b1149b5ddee3685b55fed93b5f4a85c70e30..5cebf4346f30a9ab6aa24cbbe136cae21fddb70c 100644
--- a/src/plugins/value/utils/eva_annotations.ml
+++ b/src/plugins/value/utils/eva_annotations.ml
@@ -341,10 +341,10 @@ module Allocation = struct
let get stmt =
match get stmt with
- | [] -> Option.get (of_string (Value_parameters.AllocBuiltin.get ()))
+ | [] -> Option.get (of_string (Parameters.AllocBuiltin.get ()))
| [x] -> x
| x :: _ ->
- Value_parameters.warning ~current:true ~once:true
+ Self.warning ~current:true ~once:true
"Several eva_allocate annotations at the same statement; selecting %s\
and ignoring the others." (to_string x);
x
diff --git a/src/plugins/value/utils/eva_annotations.mli b/src/plugins/value/utils/eva_annotations.mli
index df768e5a1fbb96dc022afa594ca4a5ab9d4fc1a7..5b206536c557f1b287c1c7ea9a76d2759642d370 100644
--- a/src/plugins/value/utils/eva_annotations.mli
+++ b/src/plugins/value/utils/eva_annotations.mli
@@ -20,23 +20,28 @@
(* *)
(**************************************************************************)
-(** Registers Eva annotations:
+(* Note: widen hints annotations are still registered in !{widen_hints_ext.ml}. *)
+
+[@@@ api_start]
+(** Register special annotations to locally guide the Eva analysis:
+
- slevel annotations: "slevel default", "slevel merge" and "slevel i"
- loop unroll annotations: "loop unroll term"
- value partitioning annotations: "split term" and "merge term"
- subdivision annotations: "subdivide i"
+*)
- Widen hints annotations are still registered in !{widen_hints_ext.ml}. *)
-
+(** Annotations tweaking the behavior of the -eva-slevel parameter. *)
type slevel_annotation =
- | SlevelMerge
- | SlevelDefault
- | SlevelLocal of int
- | SlevelFull
+ | SlevelMerge (** Join all states separated by slevel. *)
+ | SlevelDefault (** Use the limit defined by -eva-slevel. *)
+ | SlevelLocal of int (** Use the given limit instead of -eva-slevel. *)
+ | SlevelFull (** Remove the limit of number of separated states. *)
+(** Loop unroll annotations. *)
type unroll_annotation =
- | UnrollAmount of Cil_types.term
- | UnrollFull
+ | UnrollAmount of Cil_types.term (** Unroll the n first iterations. *)
+ | UnrollFull (** Unroll amount defined by -eva-default-loop-unroll. *)
type split_kind = Static | Dynamic
@@ -44,9 +49,12 @@ type split_term =
| Expression of Cil_types.exp
| Predicate of Cil_types.predicate
+(** Split/merge annotations for value partitioning. *)
type flow_annotation =
| FlowSplit of split_term * split_kind
+ (** Split states according to a term. *)
| FlowMerge of split_term
+ (** Merge states separated by a previous split. *)
type allocation_kind = By_stack | Fresh | Fresh_weak | Imprecise
@@ -64,3 +72,4 @@ val add_flow_annot : emitter:Emitter.t ->
Cil_types.stmt -> flow_annotation -> unit
val add_subdivision_annot : emitter:Emitter.t ->
Cil_types.stmt -> int -> unit
+[@@@ api_end]
diff --git a/src/plugins/value/utils/eva_audit.ml b/src/plugins/value/utils/eva_audit.ml
index d47d4c37275a36fa11f8229b9ec2fb4a3708af40..d5dc4c7a1c7b98b964667bb3cf90472fcdeda6c1 100644
--- a/src/plugins/value/utils/eva_audit.ml
+++ b/src/plugins/value/utils/eva_audit.ml
@@ -26,7 +26,7 @@ let get_correctness_parameters () =
let value = Typed_parameter.get_value param in
(name, value)
in
- List.map get (Value_parameters.parameters_correctness)
+ List.map get (Parameters.parameters_correctness)
let parameters_of_json json =
try
@@ -45,8 +45,8 @@ let parameters_of_json json =
let print_correctness_parameters path =
let parameters = get_correctness_parameters () in
if Filepath.Normalized.is_special_stdout path then begin
- Value_parameters.feedback "Correctness parameters of the analysis:";
- let print (name, value) = Value_parameters.printf " %s: %s" name value in
+ Self.feedback "Correctness parameters of the analysis:";
+ let print (name, value) = Self.printf " %s: %s" name value in
List.iter print parameters
end else begin
let json = List.map (fun (name, value) -> name, `String value) parameters in
@@ -106,10 +106,10 @@ let print_warning_status path name (module Plugin: Log.Messages) =
let pp_categories =
Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string
in
- Value_parameters.feedback "Audit: %s warning categories:" name;
- Value_parameters.printf " Enabled: @[%a@]"
+ Self.feedback "Audit: %s warning categories:" name;
+ Self.printf " Enabled: @[%a@]"
pp_categories (List.map fst enabled);
- Value_parameters.printf " Disabled: @[%a@]"
+ Self.printf " Disabled: @[%a@]"
pp_categories (List.map fst disabled)
end
else begin
@@ -139,7 +139,7 @@ let check_configuration path =
let json = Json.from_file path in
check_correctness_parameters json;
check_warning_status json "Kernel" (module Kernel);
- check_warning_status json "Eva" (module Value_parameters)
+ check_warning_status json "Eva" (module Self)
with Yojson.Json_error msg ->
Kernel.abort "error reading JSON file %a: %s"
Filepath.Normalized.pretty path msg
@@ -148,9 +148,9 @@ let print_configuration path =
try
print_correctness_parameters path;
print_warning_status path "Kernel" (module Kernel);
- print_warning_status path "Eva" (module Value_parameters);
+ print_warning_status path "Eva" (module Self);
if not (Filepath.Normalized.is_special_stdout path) then
- Value_parameters.feedback "Audit: eva configuration written to: %a"
+ Self.feedback "Audit: eva configuration written to: %a"
Filepath.Normalized.pretty path;
with Json.CannotMerge _ ->
Kernel.failure "%s: error when writing json file %a."
diff --git a/src/plugins/value/utils/eva_dynamic.ml b/src/plugins/value/utils/eva_dynamic.ml
index b62a8ec73cb2f5f61f8db4a83e434ccfcbc2f15b..5be50585b9e36feed52b361391cf370aaf14a74c 100644
--- a/src/plugins/value/utils/eva_dynamic.ml
+++ b/src/plugins/value/utils/eva_dynamic.ml
@@ -43,7 +43,7 @@ module Scope = struct
let rm_asserts () =
let fallback () =
- Value_parameters.warning
+ Self.warning
"The scope plugin is missing: cannot remove redundant alarms."
in
let typ = Datatype.(func unit unit) in
diff --git a/src/plugins/value/utils/value_perf.ml b/src/plugins/value/utils/eva_perf.ml
similarity index 98%
rename from src/plugins/value/utils/value_perf.ml
rename to src/plugins/value/utils/eva_perf.ml
index 5d1d845e294d1fcac34816b8f2821c8cf04ba20f..66f45a43f9c48b809c33365a6ed2bbc0e1b22f4f 100644
--- a/src/plugins/value/utils/value_perf.ml
+++ b/src/plugins/value/utils/eva_perf.ml
@@ -271,7 +271,7 @@ and display_subtree fmt indentation subtree parent_duration curtime =
;;
let display fmt =
- if Value_parameters.ValShowPerf.get()
+ if Parameters.ValShowPerf.get()
then begin
Format.fprintf fmt "####### Value execution feedback #########\n";
let current_time = (Sys.time()) in
@@ -299,7 +299,7 @@ let caller_callee_callinfo = function
;;
let start_doing_perf callstack =
- if Value_parameters.ValShowPerf.get()
+ if Parameters.ValShowPerf.get()
then begin
let time = Sys.time() in
assert (callstack != []);
@@ -322,7 +322,7 @@ let start_doing_perf callstack =
;;
let stop_doing_perf callstack =
- if Value_parameters.ValShowPerf.get()
+ if Parameters.ValShowPerf.get()
then begin
let time = Sys.time() in
let kf = fst (List.hd callstack) in
@@ -389,15 +389,15 @@ let start_doing_flamegraph callstack =
| [] -> assert false
| [_] ->
(* Analysis of main *)
- if not (Value_parameters.ValPerfFlamegraphs.is_empty ()) then begin
- let file = Value_parameters.ValPerfFlamegraphs.get () in
+ if not (Parameters.ValPerfFlamegraphs.is_empty ()) then begin
+ let file = Parameters.ValPerfFlamegraphs.get () in
try
(* Flamegraphs must be computed. Set up the stack and the output file *)
let oc = open_out (file:>string) in
oc_flamegraph := Some oc;
stack_flamegraph := [ (Sys.time (), 0.) ]
with e ->
- Value_parameters.error "cannot open flamegraph file: %s"
+ Self.error "cannot open flamegraph file: %s"
(Printexc.to_string e);
oc_flamegraph := None (* to be on the safe side *)
end
diff --git a/src/plugins/value/utils/value_perf.mli b/src/plugins/value/utils/eva_perf.mli
similarity index 100%
rename from src/plugins/value/utils/value_perf.mli
rename to src/plugins/value/utils/eva_perf.mli
diff --git a/src/plugins/value/utils/value_results.ml b/src/plugins/value/utils/eva_results.ml
similarity index 95%
rename from src/plugins/value/utils/value_results.ml
rename to src/plugins/value/utils/eva_results.ml
index d8dfd0c0fd3dda6aa95f9695d5df5a2829b5de77..2762f635332dddd73d8003e2524baa4ac3af890a 100644
--- a/src/plugins/value/utils/value_results.ml
+++ b/src/plugins/value/utils/eva_results.ml
@@ -28,8 +28,8 @@ module Is_Called =
Kernel_function.Make_Table
(Datatype.Bool)
(struct
- let name = "Value.Value_results.is_called"
- let dependencies = [ Db.Value.self ]
+ let name = "Value.Eva_results.is_called"
+ let dependencies = [ Self.state ]
let size = 17
end)
@@ -49,8 +49,8 @@ module Callers =
Kernel_function.Make_Table
(Kernel_function.Map.Make(Stmt.Set))
(struct
- let name = "Value.Value_results.Callers"
- let dependencies = [ Db.Value.self ]
+ let name = "Value.Eva_results.Callers"
+ let dependencies = [ Self.state ]
let size = 17
end)
@@ -116,7 +116,7 @@ type stmt_by_callstack = Cvalue.Model.t Value_types.Callstack.Hashtbl.t
module AlarmsStmt =
Datatype.Pair_with_collections (Alarms) (Stmt)
- (struct let module_name = "Value.Value_results.AlarmStmt" end)
+ (struct let module_name = "Value.Eva_results.AlarmStmt" end)
type results = {
main: Kernel_function.t option (** None means multiple functions *);
@@ -134,7 +134,7 @@ type results = {
}
let get_results () =
- let vue = Emitter.get Value_util.emitter in
+ let vue = Emitter.get Eva_utils.emitter in
let main = Some (fst (Globals.entry_point ())) in
let module CS = Value_types.Callstack in
let copy_states iter =
@@ -202,9 +202,9 @@ let get_results () =
initial_state; initial_args; alarms; statuses; main }
let set_results results =
- let selection = State_selection.with_dependencies Db.Value.self in
+ let selection = State_selection.with_dependencies Self.state in
Project.clear ~selection ();
- (* Those two functions may clear Db.Value.self. Start by them *)
+ (* Those two functions may clear Self.state. Start by them *)
(* Initial state *)
Db.Value.globals_set_initial_state results.initial_state;
(* Initial args *)
@@ -245,12 +245,12 @@ let set_results results =
(* Alarms *)
let aux_alarms (alarm, stmt) st =
let ki = Cil_types.Kstmt stmt in
- ignore (Alarms.register Value_util.emitter ki ~status:st alarm)
+ ignore (Alarms.register Eva_utils.emitter ki ~status:st alarm)
in
AlarmsStmt.Hashtbl.iter aux_alarms results.alarms;
(* Statuses *)
let aux_statuses ip st =
- Property_status.emit Value_util.emitter ~hyps:[] ip st
+ Property_status.emit Eva_utils.emitter ~hyps:[] ip st
in
Property.Hashtbl.iter aux_statuses results.statuses;
Db.Value.mark_as_computed ();
diff --git a/src/plugins/value/utils/value_results.mli b/src/plugins/value/utils/eva_results.mli
similarity index 92%
rename from src/plugins/value/utils/value_results.mli
rename to src/plugins/value/utils/eva_results.mli
index 9592d1e753f5eda07466e46e263863f903648115..bcfcd175ca6a8f2eb6fcd2612ffd26fbf34f1e50 100644
--- a/src/plugins/value/utils/value_results.mli
+++ b/src/plugins/value/utils/eva_results.mli
@@ -20,22 +20,23 @@
(* *)
(**************************************************************************)
-(** This file will ultimately contain all the results computed by Value
- (which must be moved out of Db.Value), both per stack and globally. *)
-
-
open Cil_types
val is_called: kernel_function -> bool
val mark_kf_as_called: kernel_function -> unit
val add_kf_caller: caller:kernel_function * stmt -> kernel_function -> unit
+val callers: kernel_function -> (kernel_function*stmt list) list
+(** @return the list of callers with their call sites. Each function is
+ present only once in the list. *)
+
val is_non_terminating_instr: stmt -> bool
(** Returns [true] iff there exists executions of the statement that does
not always fail/loop (for function calls). Must be called *only* on
statements that are instructions. *)
(** {2 Results} *)
+[@@@ api_start]
type results
val get_results: unit -> results
@@ -46,6 +47,7 @@ val change_callstacks:
(** Change the callstacks for the results for which this is meaningful.
For technical reasons, the top of the callstack must currently
be preserved. *)
+[@@@ api_end]
(*
Local Variables:
diff --git a/src/plugins/value/utils/value_util.ml b/src/plugins/value/utils/eva_utils.ml
similarity index 90%
rename from src/plugins/value/utils/value_util.ml
rename to src/plugins/value/utils/eva_utils.ml
index cd0d402e1f9da9f64142f1ba106955cbc0b73b3c..6220ca09e8006d925766a9c3063e6225cfad899a 100644
--- a/src/plugins/value/utils/value_util.ml
+++ b/src/plugins/value/utils/eva_utils.ml
@@ -31,13 +31,13 @@ let clear_call_stack () =
call_stack := []
let pop_call_stack () =
- Value_perf.stop_doing !call_stack;
+ Eva_perf.stop_doing !call_stack;
call_stack := List.tl !call_stack
;;
let push_call_stack kf ki =
call_stack := (kf,ki) :: !call_stack;
- Value_perf.start_doing !call_stack
+ Eva_perf.start_doing !call_stack
;;
@@ -47,7 +47,7 @@ let current_kf () =
let call_stack () = !call_stack
let pp_callstack fmt =
- if Value_parameters.PrintCallstacks.get () then
+ if Parameters.PrintCallstacks.get () then
Format.fprintf fmt "@ stack: %a"
Value_types.Callstack.pretty (call_stack())
;;
@@ -58,27 +58,27 @@ let emitter =
Emitter.create
"Eva"
[ Emitter.Property_status; Emitter.Alarm ]
- ~correctness:Value_parameters.parameters_correctness
- ~tuning:Value_parameters.parameters_tuning
+ ~correctness:Parameters.parameters_correctness
+ ~tuning:Parameters.parameters_tuning
let () = Db.Value.emitter := emitter
let get_slevel kf =
- try Value_parameters.SlevelFunction.find kf
- with Not_found -> Value_parameters.SemanticUnrollingLevel.get ()
+ try Parameters.SlevelFunction.find kf
+ with Not_found -> Parameters.SemanticUnrollingLevel.get ()
let get_subdivision_option stmt =
try
let kf = Kernel_function.find_englobing_kf stmt in
- Value_parameters.LinearLevelFunction.find kf
- with Not_found -> Value_parameters.LinearLevel.get ()
+ Parameters.LinearLevelFunction.find kf
+ with Not_found -> Parameters.LinearLevel.get ()
let get_subdivision stmt =
match Eva_annotations.get_subdivision_annot stmt with
| [] -> get_subdivision_option stmt
| [x] -> x
| x :: _ ->
- Value_parameters.warning ~current:true ~once:true
+ Self.warning ~current:true ~once:true
"Several subdivision annotations at the same statement; selecting %i\
and ignoring the others." x;
x
@@ -91,20 +91,20 @@ let pretty_current_cfunction_name fmt =
Kernel_function.pretty fmt (current_kf())
let warning_once_current fmt =
- Value_parameters.warning ~current:true ~once:true fmt
+ Self.warning ~current:true ~once:true fmt
(* Emit alarms in "non-warning" mode *)
let alarm_report ?current ?source ?emitwith ?echo ?once ?append =
- Value_parameters.warning ~wkey:Value_parameters.wkey_alarm
+ Self.warning ~wkey:Self.wkey_alarm
?current ?source ?emitwith ?echo ?once ?append
module DegenerationPoints =
Cil_state_builder.Stmt_hashtbl
(Datatype.Bool)
(struct
- let name = "Value_util.Degeneration"
+ let name = "Eva_utils.Degeneration"
let size = 17
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Self.state ]
end)
let protect_only_once = ref true
@@ -112,7 +112,7 @@ let protect_only_once = ref true
let protect f ~cleanup =
let catch () = !protect_only_once && not (Kernel.SaveState.is_empty ()) in
let cleanup () =
- Value_parameters.feedback ~once:true "Clean up and save partial results.";
+ Self.feedback ~once:true "Clean up and save partial results.";
try cleanup ()
with e ->
protect_only_once := false;
@@ -201,7 +201,7 @@ let zero e =
let ik = Cil.(theMachine.upointKind) in
let zero = Cil.new_exp ~loc (Const (CInt64 (Integer.zero, ik, None))) in
Cil.mkCast ~force:true ~newt:typ zero
- | typ -> Value_parameters.fatal ~current:true "non-scalar type %a"
+ | typ -> Self.fatal ~current:true "non-scalar type %a"
Printer.pp_typ typ
let eq_with_zero positive e =
@@ -238,13 +238,13 @@ let rec normalize_as_cond expr positive =
module PairExpBool =
Datatype.Pair_with_collections(Cil_datatype.Exp)(Datatype.Bool)
- (struct let module_name = "Value.Value_util.PairExpBool" end)
+ (struct let module_name = "Value.Eva_utils.PairExpBool" end)
module MemoNormalizeAsCond =
State_builder.Hashtbl
(PairExpBool.Hashtbl)
(Cil_datatype.Exp)
(struct
- let name = "Value_util.MemoNormalizeAsCond"
+ let name = "Eva_utils.MemoNormalizeAsCond"
let size = 64
let dependencies = [ Ast.self ]
end)
@@ -255,7 +255,7 @@ module MemoLvalToExp =
Cil_state_builder.Lval_hashtbl
(Cil_datatype.Exp)
(struct
- let name = "Value_util.MemoLvalToExp"
+ let name = "Eva_utils.MemoLvalToExp"
let size = 64
let dependencies = [ Ast.self ]
end)
@@ -268,7 +268,7 @@ let dump_garbled_mix () =
let l = Cvalue.V.get_garbled_mix () in
if l <> [] then
let pp_one fmt v = Format.fprintf fmt "@[<hov 2>%a@]" Cvalue.V.pretty v in
- Value_parameters.warning ~wkey:Value_parameters.wkey_garbled_mix
+ Self.warning ~wkey:Self.wkey_garbled_mix
"Garbled mix generated during analysis:@.\
@[<v>%a@]"
(Pretty_utils.pp_list ~pre:"" ~suf:"" ~sep:"@ " pp_one) l
@@ -347,7 +347,7 @@ and height_offset = function
let skip_specifications kf =
- Value_parameters.SkipLibcSpecs.get () &&
+ Parameters.SkipLibcSpecs.get () &&
Kernel_function.is_definition kf &&
Cil.is_in_libc (Kernel_function.get_vi kf).vattr
diff --git a/src/plugins/value/utils/value_util.mli b/src/plugins/value/utils/eva_utils.mli
similarity index 97%
rename from src/plugins/value/utils/value_util.mli
rename to src/plugins/value/utils/eva_utils.mli
index c99393d8885d66b5e1e11023582e3b7b797f05c7..b784b933c600a19a959c61838a07c48e38b503fb 100644
--- a/src/plugins/value/utils/value_util.mli
+++ b/src/plugins/value/utils/eva_utils.mli
@@ -40,7 +40,7 @@ val pp_callstack : Format.formatter -> unit
(* TODO: Document the rest of this file. *)
val emitter : Emitter.t
-val get_slevel : Kernel_function.t -> Value_parameters.SlevelFunction.value
+val get_slevel : Kernel_function.t -> Parameters.SlevelFunction.value
val get_subdivision: stmt -> int
val pretty_actuals :
Format.formatter -> (Cil_types.exp * Cvalue.V.t) list -> unit
@@ -48,7 +48,7 @@ val pretty_current_cfunction_name : Format.formatter -> unit
val warning_once_current : ('a, Format.formatter, unit) format -> 'a
(** Emit an alarm, either as warning or as a result, according to
- status associated to {!Value_parameters.wkey_alarm} *)
+ status associated to {!Self.wkey_alarm} *)
val alarm_report: 'a Log.pretty_printer
(** [protect f ~cleanup] runs [f]. On a user interruption or a Frama-C error,
diff --git a/src/plugins/value/utils/library_functions.ml b/src/plugins/value/utils/library_functions.ml
index 9d729c7e8eb674c3a03612de4ee59f89a84e3f77..5aa2f284c1193e2ed95822df94a8d563e512bfb4 100644
--- a/src/plugins/value/utils/library_functions.ml
+++ b/src/plugins/value/utils/library_functions.ml
@@ -33,7 +33,7 @@ module Retres =
let () = Ast.add_monotonic_state Retres.self
let () =
- State_dependency_graph.add_dependencies ~from:Retres.self [ Db.Value.self ]
+ State_dependency_graph.add_dependencies ~from:Retres.self [ Self.state ]
let get_retres_vi = Retres.memo
(fun kf ->
@@ -47,7 +47,7 @@ let get_retres_vi = Retres.memo
let name = Format.asprintf "\\result<%a>" Kernel_function.pretty kf in
Some (Cil.makeVarinfo false false name typ)
with Cil.SizeOfError _ ->
- Value_parameters.abort ~current:true
+ Self.abort ~current:true
"function %a returns a value of unknown size. Aborting"
Kernel_function.pretty kf
)
@@ -62,9 +62,9 @@ let returned_value kf =
| TFloat (FDouble, _)
| TFloat (FLongDouble, _) -> Cvalue.V.top_float
| TBuiltin_va_list _ ->
- Value_parameters.error ~current:true ~once:true
+ Self.error ~current:true ~once:true
"functions returning variadic arguments must be stubbed%t"
- Value_util.pp_callstack;
+ Eva_utils.pp_callstack;
Cvalue.V.top_int
| TVoid _ -> Cvalue.V.top (* this value will never be used *)
| TFun _ | TNamed _ | TArray _ -> assert false
@@ -100,8 +100,8 @@ let unsupported_specs_tbl =
let warn_unsupported_spec name =
try
let header = Hashtbl.find unsupported_specs_tbl name in
- Value_parameters.warning ~once:true ~current:true
- ~wkey:Value_parameters.wkey_libc_unsupported_spec
+ Self.warning ~once:true ~current:true
+ ~wkey:Self.wkey_libc_unsupported_spec
"@[The specification of function '%s' is currently not supported by Eva.@ \
Consider adding '%a'@ to the analyzed source files.@]"
name Filepath.Normalized.pretty
diff --git a/src/plugins/value/utils/mark_noresults.ml b/src/plugins/value/utils/mark_noresults.ml
index 0c31fbf0eda5e2154995879b8f7f7e7d501c1741..913698fdaaf7d2ca309bc1b250134809630ba05a 100644
--- a/src/plugins/value/utils/mark_noresults.ml
+++ b/src/plugins/value/utils/mark_noresults.ml
@@ -21,19 +21,19 @@
(**************************************************************************)
let should_memorize_function f =
- Value_parameters.ResultsAll.get () &&
+ Parameters.ResultsAll.get () &&
not (Cil_datatype.Fundec.Set.mem
- f (Value_parameters.NoResultsFunctions.get ()))
+ f (Parameters.NoResultsFunctions.get ()))
let () = Db.Value.no_results :=
(fun fd -> not (should_memorize_function fd)
- || not (Value_parameters.Domains.mem "cvalue"))
+ || not (Parameters.Domains.mem "cvalue"))
(* Signal that some results are not stored. The gui, or some calls to
Db.Value, may fail ungracefully *)
let no_memoization_enabled () =
- not (Value_parameters.ResultsAll.get ()) ||
- not (Value_parameters.NoResultsFunctions.is_empty ())
+ not (Parameters.ResultsAll.get ()) ||
+ not (Parameters.NoResultsFunctions.is_empty ())
diff --git a/src/plugins/value/utils/red_statuses.ml b/src/plugins/value/utils/red_statuses.ml
index 42440721ae25d8f7b25c9e1809bc32bb6c808c6a..c7e0ca34d290064375bae71bac59c7b2fed8f759 100644
--- a/src/plugins/value/utils/red_statuses.ml
+++ b/src/plugins/value/utils/red_statuses.ml
@@ -64,7 +64,7 @@ module RedStatusesTable =
(struct
let name = "Value.Red_statuses.RedStatusesTable"
let size = 16
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Self.state ]
end)
let add_red_ap kinstr ap =
@@ -76,7 +76,7 @@ let add_red_ap kinstr ap =
try AlarmOrProp.Map.find ap current_map
with Not_found -> Callstacks.empty
in
- let new_callstacks = Callstacks.add (Value_util.call_stack ()) callstacks in
+ let new_callstacks = Callstacks.add (Eva_utils.call_stack ()) callstacks in
let new_map = AlarmOrProp.Map.add ap new_callstacks current_map in
RedStatusesTable.replace kinstr new_map
@@ -194,7 +194,7 @@ let print_information fmt { loc; kf; alarm; kind; text; status; contexts } =
dir file lnum kf alarm kind contexts status text
let output file =
- Value_parameters.feedback "Listing red statuses in file %a"
+ Self.feedback "Listing red statuses in file %a"
Filepath.Normalized.pretty file;
let channel = open_out (file:>string) in
let fmt = Format.formatter_of_out_channel channel in
@@ -209,4 +209,4 @@ let output file =
Format.fprintf fmt "@]%!"
let report () =
- Value_parameters.ReportRedStatuses.(if not (is_empty ()) then output (get ()))
+ Parameters.ReportRedStatuses.(if not (is_empty ()) then output (get ()))
diff --git a/src/plugins/value/utils/results.ml b/src/plugins/value/utils/results.ml
new file mode 100644
index 0000000000000000000000000000000000000000..d56e13a6055338542279efde04891a0d14c90d08
--- /dev/null
+++ b/src/plugins/value/utils/results.ml
@@ -0,0 +1,682 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2021 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+open Bottom.Type
+
+type 'a or_top_bottom = 'a Bottom.Top.or_top_bottom
+
+let (>>>-:) t f = match t with
+ | `Top -> `Top
+ | `Bottom -> `Bottom
+ | `Value t -> `Value (f t)
+
+module Callstack = Value_types.Callstack
+
+type callstack = Callstack.t
+type 'a by_callstack = (callstack * 'a) list
+
+type control_point =
+ | Initial
+ | Start of Cil_types.kernel_function
+ | Before of Cil_types.stmt
+ | After of Cil_types.stmt
+
+type request = {
+ control_point : control_point;
+ selector : callstack list option;
+ filter: (callstack -> bool) list;
+}
+
+type error = Bottom | Top | DisabledDomain
+type 'a result = ('a,error) Result.t
+
+let string_of_error = function
+ | Bottom -> "The computed state is bottom"
+ | Top -> "The computed state is Top"
+ | DisabledDomain -> "The required domain is disabled"
+
+let pretty_error fmt error =
+ Format.pp_print_string fmt (string_of_error error)
+let pretty_result f fmt r =
+ Result.fold ~ok:(f fmt) ~error:(pretty_error fmt) r
+
+
+(* Building requests *)
+
+let make control_point = {
+ control_point;
+ selector = None;
+ filter = [];
+}
+
+let before stmt = make (Before stmt)
+let after stmt = make (After stmt)
+let at_start_of kf = make (Start kf)
+let at_end_of kf = make (After (Kernel_function.find_return kf))
+let at_start = make Initial
+let at_end () = at_end_of (fst (Globals.entry_point ()))
+
+let before_kinstr = function
+ | Cil_types.Kglobal -> at_start
+ | Kstmt stmt -> before stmt
+
+let in_callstacks l req = { req with selector = Some l }
+let in_callstack cs req = { req with selector = Some [cs] }
+let filter_callstack f req = { req with filter = f :: req.filter }
+
+
+(* Manipulating request results *)
+
+type restricted_to_callstack
+type unrestricted_response
+
+module Response =
+struct
+
+ type ('a, 'callstack) t =
+ | Consolidated : 'a -> ('a, unrestricted_response) t
+ | ByCallstack : 'a by_callstack -> ('a, 'callstack) t
+ | Top : ('a, 'callstack) t
+ | Bottom : ('a, 'callstack) t
+
+ let coercion : ('a, restricted_to_callstack) t -> ('a, 'c) t = function
+ | ByCallstack c -> ByCallstack c
+ | Top -> Top
+ | Bottom -> Bottom
+
+ let is_bottom = function
+ | ByCallstack [] | Bottom -> true
+ | _ -> false
+
+ (* Constructors *)
+
+ let consolidated =
+ function
+ | `Bottom -> Bottom
+ | `Value state -> Consolidated state
+
+ let singleton cs =
+ function
+ | `Bottom -> Bottom
+ | `Value state -> ByCallstack [cs,state]
+
+ let by_callstack : request ->
+ [< `Bottom | `Top | `Value of 'a Value_types.Callstack.Hashtbl.t ] ->
+ ('a, restricted_to_callstack) t =
+ fun req table ->
+ match table with
+ | `Top -> Top
+ | `Bottom -> Bottom
+ | `Value table ->
+ (* Filter *)
+ let add cs state acc =
+ if List.for_all (fun filter -> filter cs) req.filter
+ then (cs, state) :: acc
+ else acc
+ in
+ (* Selection *)
+ let l =
+ match req.selector with
+ | None -> Callstack.Hashtbl.fold add table []
+ | Some selector ->
+ let add acc cs =
+ match Callstack.Hashtbl.find_opt table cs with
+ | Some state -> add cs state acc
+ | None -> acc
+ in
+ List.fold_left add [] selector
+ in
+ ByCallstack l
+
+ (* Accessors *)
+
+ let callstacks : ('a, restricted_to_callstack) t -> callstack list = function
+ | Top | Bottom -> [] (* What else to do when Top is given ? *)
+ | ByCallstack l -> List.map fst l
+
+ (* Fold *)
+
+ let fold (f : callstack -> 'a -> 'b -> 'b) (acc : 'b) :
+ ('a, restricted_to_callstack) t -> 'b =
+ function
+ | Top | Bottom -> acc (* What else to do when Top is given ? *)
+ | ByCallstack l -> List.fold_left (fun acc (cs,x) -> f cs x acc) acc l
+
+ (* Map *)
+
+ let map : type c. ('a -> 'b) -> ('a, c) t -> ('b, c) t = fun f -> function
+ | Consolidated v -> Consolidated (f v)
+ | ByCallstack l -> ByCallstack (List.map (fun (cs,x) -> cs,f x) l)
+ | Top -> Top
+ | Bottom -> Bottom
+
+ (* Reduction *)
+
+ let map_reduce : type c. ([`Top | `Bottom] -> 'b) -> ('a -> 'b) ->
+ ('b -> 'b -> 'b) -> ('a, c) t -> 'b =
+ fun default map reduce -> function
+ | Consolidated v -> map v
+ | ByCallstack ((_,h) :: t) ->
+ List.fold_left (fun acc (_,x) -> reduce acc (map x)) (map h) t
+ | ByCallstack [] | Bottom -> default `Bottom
+ | Top -> default `Top
+
+ let default = function
+ | `Bottom -> `Bottom
+ | `Top -> `Top
+
+ let map_join : type c.
+ ('a -> 'b) -> ('b -> 'b -> 'b) -> ('a, c) t -> 'b or_top_bottom =
+ fun map join ->
+ let map' x = `Value (map x) in
+ map_reduce default map' (Bottom.Top.join join)
+
+ let map_join' : type c. ('a -> 'b or_top_bottom) -> ('b -> 'b -> 'b) ->
+ ('a, c) t -> 'b or_top_bottom =
+ fun map join ->
+ map_reduce default map (Bottom.Top.join join)
+end
+
+
+(* Extracting states and values *)
+
+type value
+type address
+
+module Make () =
+struct
+ module A = (val Analysis.current_analyzer ())
+
+ module EvalTypes =
+ struct
+ type valuation = A.Eval.Valuation.t
+ type exp = (valuation * A.Val.t) Eval.evaluated
+ type lval = (valuation * A.Val.t Eval.flagged_value) Eval.evaluated
+ type loc = (valuation * A.Loc.location * Cil_types.typ) Eval.evaluated
+ end
+
+ type ('a,'c) evaluation =
+ | LValue: (EvalTypes.lval, 'c) Response.t -> (value,'c) evaluation
+ | Value: (EvalTypes.exp, 'c) Response.t -> (value,'c) evaluation
+ | Address: (EvalTypes.loc, 'c) Response.t * Locations.access ->
+ (address,'c) evaluation
+
+ let get_by_callstack (req : request) :
+ (_, restricted_to_callstack) Response.t =
+ let open Response in
+ match req.control_point with
+ | Before stmt ->
+ A.get_stmt_state_by_callstack ~after:false stmt |> by_callstack req
+ | After stmt ->
+ A.get_stmt_state_by_callstack ~after:true stmt |> by_callstack req
+ | Initial ->
+ A.get_global_state () |> singleton []
+ | Start kf ->
+ A.get_initial_state_by_callstack kf |> by_callstack req
+
+ let get (req : request) : (_, unrestricted_response) Response.t =
+ if req.filter <> [] || Option.is_some req.selector then
+ Response.coercion @@ get_by_callstack req
+ else
+ let open Response in
+ let state =
+ match req.control_point with
+ | Before stmt -> A.get_stmt_state ~after:false stmt
+ | After stmt -> A.get_stmt_state ~after:true stmt
+ | Start kf -> A.get_initial_state kf
+ | Initial -> A.get_global_state ()
+ in
+ consolidated state
+
+ let convert : 'a or_top_bottom -> 'a result = function
+ | `Top -> Result.error Top
+ | `Bottom -> Result.error Bottom
+ | `Value v -> Result.ok v
+
+ let callstacks req =
+ get_by_callstack req |> Response.callstacks
+
+ let by_callstack req =
+ let f cs _res acc =
+ (cs, in_callstack cs req) :: acc
+ in
+ get_by_callstack req |> Response.fold f []
+
+ let is_reachable req =
+ match get req with
+ | Bottom -> false
+ | _ -> true
+
+ let equality_class exp req =
+ let open Equality in
+ match A.Dom.get Equality_domain.key with
+ | None ->
+ Result.error DisabledDomain
+ | Some extract ->
+ let hce = Hcexprs.HCE.of_exp exp in
+ let extract' state =
+ let equalities = Equality_domain.project (extract state) in
+ try NonTrivial (Set.find hce equalities)
+ with Not_found -> Trivial
+ and reduce e1 e2 =
+ match e1, e2 with
+ | Trivial, _ | _, Trivial -> Trivial
+ | NonTrivial e1, NonTrivial e2 -> Equality.inter e1 e2
+ in
+ let r = match Response.map_join extract' reduce (get req) with
+ | (`Top | `Bottom) as r -> r
+ | `Value Trivial -> `Top
+ | `Value (NonTrivial e) ->
+ let l = Equality.elements e in
+ `Value (List.map Hcexprs.HCE.to_exp l)
+ in
+ convert r
+
+ let get_cvalue_model req =
+ match A.Dom.get_cvalue with
+ | None ->
+ Result.error DisabledDomain
+ | Some extract ->
+ convert (Response.map_join extract Cvalue.Model.join (get req))
+
+ (* Evaluation *)
+
+ let eval_lval lval req =
+ let eval state = A.Eval.copy_lvalue state lval in
+ LValue (Response.map eval (get req))
+
+ let eval_exp exp req =
+ let eval state = A.Eval.evaluate state exp in
+ Value (Response.map eval (get req))
+
+ let eval_address ~for_writing lval req =
+ let eval state = A.Eval.lvaluate ~for_writing state lval in
+ let access = if for_writing then Locations.Write else Read in
+ Address (Response.map eval (get req), access)
+
+ let eval_callee exp req =
+ let join = (@)
+ and extract state =
+ let r,_alarms = A.Eval.eval_function_exp exp state in
+ r >>>-: List.map fst
+ in
+ get req |> Response.map_join' extract join |> convert |>
+ Result.map (List.sort_uniq Kernel_function.compare)
+
+
+ (* Conversion *)
+
+ let extract_value :
+ type c. (value, c) evaluation -> (A.Val.t or_bottom, c) Response.t =
+ function
+ | LValue r ->
+ let extract (x, _alarms) = x >>- (fun (_valuation,fv) -> fv.Eval.v) in
+ Response.map extract r
+ | Value r ->
+ let extract (x, _alarms) = x >>-: (fun (_valuation,v) -> v) in
+ Response.map extract r
+
+ let as_cvalue res =
+ match A.Val.get Main_values.CVal.key with
+ | None ->
+ Result.error DisabledDomain
+ | Some get ->
+ let join = Main_values.CVal.join in
+ let extract value =
+ value >>>-: get
+ in
+ extract_value res |> Response.map_join' extract join |> convert
+
+ let extract_loc :
+ type c. (address, c) evaluation ->
+ (A.Loc.location or_bottom, c) Response.t * Locations.access =
+ function
+ | Address (r, access) ->
+ let extract (x, _alarms) = x >>-: (fun (_valuation,loc,_typ) -> loc) in
+ Response.map extract r, access
+
+ let as_location res =
+ match A.Loc.get Main_locations.PLoc.key with
+ | None ->
+ Result.error DisabledDomain
+ | Some get ->
+ let join loc1 loc2 =
+ let open Locations in
+ let size = loc1.size
+ and loc = Location_Bits.join loc1.loc loc2.loc in
+ assert (Int_Base.equal loc2.size size);
+ make_loc loc size
+ and extract loc =
+ loc >>>-: get >>>-: Precise_locs.imprecise_location
+ in
+ extract_loc res |> fst |> Response.map_join' extract join |> convert
+
+ let as_zone res =
+ match A.Loc.get Main_locations.PLoc.key with
+ | None ->
+ Result.error DisabledDomain
+ | Some get ->
+ let response_loc, access = extract_loc res in
+ let join = Locations.Zone.join
+ and extract loc =
+ loc >>>-: get >>>-: Precise_locs.enumerate_valid_bits access
+ in
+ response_loc |> Response.map_join' extract join |> convert
+
+ let is_initialized : type c. (value,c) evaluation -> bool =
+ function
+ | LValue r ->
+ let join = (&&)
+ and extract (x, _alarms) =
+ x >>>-: (fun (_valuation,fv) -> fv.Eval.initialized)
+ in
+ begin match Response.map_join' extract join r with
+ | `Bottom | `Top -> false
+ | `Value v -> v
+ end
+ | Value _ -> true (* computed values are always initialized *)
+
+ let alarms : type a c. (a,c) evaluation -> Alarms.t list =
+ fun res ->
+ let extract (_,v) = `Value v in
+ let r = match res with
+ | LValue r ->
+ Response.map_join' extract Alarmset.union r
+ | Value r ->
+ Response.map_join' extract Alarmset.union r
+ | Address (r, _lval) ->
+ Response.map_join' extract Alarmset.union r
+ in
+ match r with
+ | `Bottom | `Top -> []
+ | `Value alarmset ->
+ let add alarm status acc =
+ if status <> Alarmset.True then alarm :: acc else acc
+ in
+ Alarmset.fold add [] alarmset
+
+ let is_bottom : type a c. (a,c) evaluation -> bool = function
+ | LValue r -> Response.is_bottom r
+ | Value r -> Response.is_bottom r
+ | Address (r, _lval) -> Response.is_bottom r
+
+ (* Dependencies *)
+
+ let compute_deps eval_deps arg req =
+ let error = function
+ | Bottom -> Locations.Zone.bottom
+ | Top | DisabledDomain -> Locations.Zone.top
+ in
+ let compute cvalue =
+ eval_deps (cvalue, Locals_scoping.bottom ()) arg
+ in
+ req |> get_cvalue_model |> Result.fold ~error ~ok:compute
+
+ let lval_deps = compute_deps Register.eval_deps_lval
+ let expr_deps = compute_deps Register.eval_deps
+ let address_deps = compute_deps Register.eval_deps_addr
+end
+
+
+(* Working with callstacks *)
+
+let callstacks req =
+ let module E = Make () in
+ E.callstacks req
+
+let by_callstack req =
+ let module E = Make () in
+ E.by_callstack req
+
+
+(* State requests *)
+
+let equality_class exp req =
+ let module E = Make () in
+ E.equality_class exp req
+
+let get_cvalue_model_result req =
+ let module E = Make () in
+ E.get_cvalue_model req
+
+let get_cvalue_model req =
+ match get_cvalue_model_result req with
+ | Ok state -> state
+ | Error Bottom -> Cvalue.Model.bottom
+ | Error (Top | DisabledDomain) -> Cvalue.Model.top
+
+
+(* Depedencies *)
+
+let expr_deps exp req =
+ let module E = Make () in
+ E.expr_deps exp req
+
+let lval_deps lval req =
+ let module E = Make () in
+ E.lval_deps lval req
+
+let address_deps lval req =
+ let module E = Make () in
+ E.address_deps lval req
+
+
+(* Evaluation *)
+
+module type Lvaluation =
+sig
+ include module type of (Make ())
+ val v : (address, unrestricted_response) evaluation
+end
+
+module type Evaluation =
+sig
+ include module type of (Make ())
+ val v : (value, unrestricted_response) evaluation
+end
+
+type 'a evaluation =
+ | Value: (module Evaluation) -> value evaluation
+ | Address: (module Lvaluation) -> address evaluation
+
+let build_eval_lval_and_exp () =
+ let module M = Make () in
+ let build v =
+ (module struct
+ include M
+ let v = v
+ end : Evaluation)
+ in
+ let eval_lval lval req = build @@ M.eval_lval lval req in
+ let eval_exp exp req = build @@ M.eval_exp exp req in
+ eval_lval, eval_exp
+
+let eval_lval lval req = Value ((fst @@ build_eval_lval_and_exp ()) lval req)
+
+let eval_var vi req = eval_lval (Cil.var vi) req
+
+let eval_exp exp req = Value ((snd @@ build_eval_lval_and_exp ()) exp req)
+
+let eval_address ?(for_writing=false) lval req =
+ let module M = Make () in
+ let v = M.eval_address ~for_writing lval req in
+ Address
+ (module struct
+ include M
+ let v = v
+ end : Lvaluation)
+
+let eval_callee exp req =
+ (* Check the validity of exp *)
+ begin match exp with
+ | Cil_types.({ enode = Lval (_, NoOffset) }) -> ()
+ | _ ->
+ invalid_arg "The callee must be an lvalue with no offset"
+ end;
+ let module M = Make () in
+ M.eval_callee exp req
+
+let callee stmt =
+ let callee_exp =
+ match stmt.Cil_types.skind with
+ | Instr (Call (_lval, callee_exp, _args, _loc)) ->
+ callee_exp
+ | Instr (Local_init (_vi, ConsInit (f, _, _), _loc)) ->
+ Cil.evar f
+ | _ ->
+ invalid_arg "Can only evaluate the callee on a statement which is a Call"
+ in
+ before stmt |> eval_callee callee_exp |> Result.value ~default:[]
+
+(* Value conversion *)
+
+let as_cvalue_result (Value evaluation) =
+ let module E = (val evaluation : Evaluation) in
+ E.as_cvalue E.v
+
+let as_cvalue evaluation =
+ match as_cvalue_result evaluation with
+ | Ok v -> v
+ | Error Bottom -> Cvalue.V.bottom
+ | Error (Top | DisabledDomain) -> Cvalue.V.top
+
+let as_ival evaluation =
+ try
+ Result.map Cvalue.V.project_ival (as_cvalue_result evaluation)
+ with Cvalue.V.Not_based_on_null ->
+ Result.error Top
+
+let as_fval evaluation =
+ let f ival =
+ if Ival.is_float ival
+ then Result.ok (Ival.project_float ival)
+ else Result.error Top
+ in
+ Result.bind (as_ival evaluation) f
+
+let as_float evaluation =
+ try
+ as_fval evaluation |>
+ Result.map Fval.project_float |>
+ Result.map Fval.F.to_float
+ with Fval.Not_Singleton_Float ->
+ Result.error Top
+
+let as_integer evaluation =
+ try
+ Result.map Ival.project_int (as_ival evaluation)
+ with Ival.Not_Singleton_Int ->
+ Result.error Top
+
+let as_int evaluation =
+ try
+ Result.map Integer.to_int_exn (as_integer evaluation)
+ with Z.Overflow ->
+ Result.error Top
+
+let as_location (Address lvaluation) =
+ let module E = (val lvaluation : Lvaluation) in
+ E.as_location E.v
+
+let as_zone_result (Address lvaluation) =
+ let module E = (val lvaluation : Lvaluation) in
+ E.as_zone E.v
+
+let as_zone address =
+ match as_zone_result address with
+ | Ok zone -> zone
+ | Error Bottom -> Locations.Zone.bottom
+ | Error (Top | DisabledDomain) -> Locations.Zone.top
+
+(* Evaluation properties *)
+
+let is_initialized (Value evaluation) =
+ let module E = (val evaluation : Evaluation) in
+ E.is_initialized E.v
+
+let alarms : type a. a evaluation -> Alarms.t list =
+ function
+ | Value evaluation ->
+ let module E = (val evaluation : Evaluation) in
+ E.alarms E.v
+ | Address lvaluation ->
+ let module L = (val lvaluation : Lvaluation) in
+ L.alarms L.v
+
+(* Reachability *)
+
+let is_empty rq =
+ let module E = Make () in
+ E.callstacks rq = []
+
+let is_bottom : type a. a evaluation -> bool =
+ function
+ | Value evaluation ->
+ let module E = (val evaluation : Evaluation) in
+ E.is_bottom E.v
+ | Address lvaluation ->
+ let module L = (val lvaluation : Lvaluation) in
+ L.is_bottom L.v
+
+let is_called kf =
+ let module M = Make () in
+ M.is_reachable (at_start_of kf)
+
+let is_reachable stmt =
+ let module M = Make () in
+ M.is_reachable (before stmt)
+
+let is_reachable_kinstr kinstr =
+ let module M = Make () in
+ M.is_reachable (before_kinstr kinstr)
+
+
+(* Callers / callsites *)
+
+let callers kf =
+ let f = function
+ | [] | [_] -> None
+ | _ :: (caller,_) :: _-> Some caller
+ in
+ at_start_of kf |> callstacks |>
+ List.filter_map f |> List.sort_uniq Kernel_function.compare
+
+let uniq_sites = List.sort_uniq Cil_datatype.Stmt.compare
+
+let callsites kf =
+ let module Map = Kernel_function.Map in
+ let f acc = function
+ | [] | (_,Cil_types.Kglobal) :: _ -> acc
+ | [(_,Kstmt _)] -> assert false (* End of callstacks should have no callsite *)
+ | (_kf,Kstmt stmt) :: (caller,_) :: _ -> (* kf = _kf *)
+ Map.update caller
+ (fun old -> Some (stmt :: Option.value ~default:[] old)) acc
+ in
+ at_start_of kf |> callstacks |>
+ List.fold_left f Map.empty |> Map.to_seq |> List.of_seq |>
+ List.map (fun (kf,sites) -> kf, uniq_sites sites)
+
+
+(* Result conversion *)
+
+let default default_value result =
+ Result.value ~default:default_value result
diff --git a/src/plugins/value/utils/results.mli b/src/plugins/value/utils/results.mli
new file mode 100644
index 0000000000000000000000000000000000000000..1e4376651fedebb386cc34006a581f2527d231fc
--- /dev/null
+++ b/src/plugins/value/utils/results.mli
@@ -0,0 +1,288 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2021 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+[@@@ api_start]
+(** Eva's result API is a work-in-progress interface to allow accessing the
+ analysis results once its completed. It is experimental and is very likely
+ to change in the future. It aims at replacing [Db.Value] but does not
+ completely covers all its usages yet. As for now, this interface has some
+ advantages over Db's :
+
+ - evaluations uses every available domains and not only Cvalue;
+ - the caller may distinguish failure cases when a request is unsucessful;
+ - working with callstacks is easy;
+ - some common shortcuts are provided (e.g. for extracting ival directly);
+ - overall, individual functions are simpler.
+
+ The idea behind this API is that requests must be decomposed in several
+ steps. For instance, to evaluate an expression :
+
+ 1. first, you have to state where you want to evaluate it,
+ 2. optionally, you may specify in which callstack,
+ 3. you choose the expression to evaluate,
+ 4. you require a destination type to evaluate into.
+
+ Usage sketch :
+
+ Eva.Results.(
+ before stmt |> in_callstack cs |>
+ eval_var vi |> as_int |> default 0)
+
+ or equivalently, if you prefer
+
+ Eva.Results.(
+ default O (as_int (eval_var vi (in_callstack cs (before stmt))))
+*)
+
+
+type callstack = (Cil_types.kernel_function * Cil_types.kinstr) list
+
+type request
+
+type value
+type address
+type 'a evaluation
+
+type error = Bottom | Top | DisabledDomain
+type 'a result = ('a,error) Result.t
+
+
+(** Results handling *)
+
+(** Translates an error to a human readable string. *)
+val string_of_error : error -> string
+
+(** Pretty printer for errors. *)
+val pretty_error : Format.formatter -> error -> unit
+
+(** Pretty printer for API's results. *)
+val pretty_result : (Format.formatter -> 'a -> unit) ->
+ Format.formatter -> 'a result -> unit
+
+(** [default d r] extracts the value of [r] if [r] is Ok,
+ or use the default value [d] otherwise.
+ Equivalent to [Result.value ~default:d r] *)
+val default : 'a -> 'a result -> 'a
+
+
+(** Control point selection *)
+
+(** At the start of the analysis, but after the initialization of globals. *)
+val at_start : request
+
+(** At the end of the analysis, after the main function has returned. *)
+val at_end : unit -> request
+
+(** At the start of the given function. *)
+val at_start_of : Cil_types.kernel_function -> request
+
+(** At the end of the given function.
+ @raises Kernel_function.No_statement if the function has no body. *)
+val at_end_of : Cil_types.kernel_function -> request
+
+(** Just before a statement is executed. *)
+val before : Cil_types.stmt -> request
+
+(** Just after a statement is executed. *)
+val after : Cil_types.stmt -> request
+
+(** Just before a statement or at the start of the analysis. *)
+val before_kinstr : Cil_types.kinstr -> request
+
+
+(** Callstack selection *)
+
+(** Only consider the given callstack.
+ Replaces previous calls to [in_callstack] or [in_callstacks]. *)
+val in_callstack : callstack -> request -> request
+
+(** Only consider the callstacks from the given list.
+ Replaces previous calls to [in_callstack] or [in_callstacks]. *)
+val in_callstacks : callstack list -> request -> request
+
+(** Only consider callstacks satisfying the given predicate. Several filters
+ can be added. If callstacks are also selected with [in_callstack] or
+ [in_callstacks], only the selected callstacks will be filtered. *)
+val filter_callstack : (callstack -> bool) -> request -> request
+
+
+(** Working with callstacks *)
+
+(** Returns the list of reachable callstacks from the given request.
+ An empty list is returned if the request control point has not been
+ reached by the analysis, or if no information has been saved at this point
+ (for instance with the -eva-no-results option).
+ Use [is_empty request] to distinguish these two cases. *)
+val callstacks : request -> callstack list
+
+(** Returns a list of subrequests for each reachable callstack from
+ the given request. *)
+val by_callstack : request -> (callstack * request) list
+
+
+(** State requests *)
+
+(** Returns the list of expressions which have been inferred to be equal to
+ the given expression by the Equality domain. *)
+val equality_class : Cil_types.exp -> request -> Cil_types.exp list result
+
+(** Returns the Cvalue state. Error cases are converted into the bottom or top
+ cvalue state accordingly. *)
+val get_cvalue_model : request -> Cvalue.Model.t
+
+(** Returns the Cvalue model. *)
+val get_cvalue_model_result : request -> Cvalue.Model.t result
+
+
+(** Dependencies *)
+
+(** Computes (an overapproximation of) the memory zones that must be read to
+ evaluate the given expression, including all adresses computations. *)
+val expr_deps : Cil_types.exp -> request -> Locations.Zone.t
+
+(** Computes (an overapproximation of) the memory zones that must be read to
+ evaluate the given lvalue, including the lvalue zone itself. *)
+val lval_deps : Cil_types.lval -> request -> Locations.Zone.t
+
+(** Computes (an overapproximation of) the memory zones that must be read to
+ evaluate the given lvalue, excluding the lvalue zone itself. *)
+val address_deps : Cil_types.lval -> request -> Locations.Zone.t
+
+
+(** Evaluation *)
+
+(** Returns (an overapproximation of) the possible values of the variable. *)
+val eval_var : Cil_types.varinfo -> request -> value evaluation
+
+(** Returns (an overapproximation of) the possible values of the lvalue. *)
+val eval_lval : Cil_types.lval -> request -> value evaluation
+
+(** Returns (an overapproximation of) the possible values of the expression. *)
+val eval_exp : Cil_types.exp -> request -> value evaluation
+
+
+(** Returns (an overapproximation of) the possible addresses of the lvalue. *)
+val eval_address : ?for_writing:bool ->
+ Cil_types.lval -> request -> address evaluation
+
+
+(** Returns the kernel functions into which the given expression may evaluate.
+ If the callee expression doesn't always evaluate to a function, those
+ spurious values are ignored. If it always evaluate to a non-function value
+ then the returned list is empty.
+ Raises [Stdlib.Invalid_argument] if the callee expression is not an lvalue
+ without offset.
+ Also see [callee] for a function which applies directly on Call
+ statements. *)
+val eval_callee : Cil_types.exp -> request -> Kernel_function.t list result
+
+
+(** Evaluated values conversion *)
+
+(** In all functions below, if the abstract value inferred by Eva does not fit
+ in the required type, [Error Top] is returned, as Top is the only possible
+ over-approximation of the request. *)
+
+(** Converts the value into a singleton ocaml int. *)
+val as_int : value evaluation -> int result
+
+(** Converts the value into a singleton unbounded integer. *)
+val as_integer : value evaluation -> Integer.t result
+
+(** Converts the value into a floating point number. *)
+val as_float : value evaluation -> float result
+
+(** Converts the value into a C number abstraction. *)
+val as_ival : value evaluation -> Ival.t result
+
+(** Converts the value into a floating point abstraction. *)
+val as_fval : value evaluation -> Fval.t result
+
+(** Converts the value into a Cvalue abstraction. Converts error cases
+ into bottom and top values accordingly. *)
+val as_cvalue : value evaluation -> Cvalue.V.t
+
+(** Converts the value into a Cvalue abstraction. *)
+val as_cvalue_result : value evaluation -> Cvalue.V.t result
+
+
+(** Converts into a C location abstraction. *)
+val as_location : address evaluation -> Locations.location result
+
+(** Converts into a Zone. Error cases are converted into bottom or top zones
+ accordingly. *)
+val as_zone: address evaluation -> Locations.Zone.t
+
+(** Converts into a Zone result. *)
+val as_zone_result : address evaluation -> Locations.Zone.t result
+
+
+(** Evaluation properties *)
+
+(** Returns whether the evaluated value is initialized or not. If the value have
+ been evaluated from a Cil expression, it is always initialized. *)
+val is_initialized : value evaluation -> bool
+
+(** Returns the set of alarms emitted during the evaluation. *)
+val alarms : 'a evaluation -> Alarms.t list
+
+
+(** Reachability *)
+
+(** Returns true if there are no reachable states for the given request. *)
+val is_empty : request -> bool
+
+(** Returns true if an evaluation leads to bottom, i.e. if the given expression
+ or lvalue cannot be evaluated to a valid result for the given request. *)
+val is_bottom : 'a evaluation -> bool
+
+(** Returns true if the function has been analyzed. *)
+val is_called : Cil_types.kernel_function -> bool
+
+(** Returns true if the statement has been reached by the analysis. *)
+val is_reachable : Cil_types.stmt -> bool
+
+(** Returns true if the statement has been reached by the analysis, or if
+ the main function has been analyzed for [Kglobal]. *)
+val is_reachable_kinstr : Cil_types.kinstr -> bool
+
+
+(*** Callers / Callees / Callsites *)
+
+(** Returns the list of inferred callers of the given function. *)
+val callers : Cil_types.kernel_function -> Cil_types.kernel_function list
+
+(** Returns the list of inferred callers, and for each of them, the list
+ of callsites (the call statements) inside. *)
+val callsites : Cil_types.kernel_function ->
+ (Cil_types.kernel_function * Cil_types.stmt list) list
+
+
+(** Returns the kernel functions called in the given statement.
+ If the callee expression doesn't always evaluate to a function, those
+ spurious values are ignored. If it always evaluate to a non-function value
+ then the returned list is empty.
+ Raises [Stdlib.Invalid_argument] if the statement is not a [Call]
+ instruction or a [Local_init] with [ConsInit] initializer. *)
+val callee : Cil_types.stmt -> Kernel_function.t list
+
+[@@@ api_end]
diff --git a/src/plugins/value/utils/summary.ml b/src/plugins/value/utils/summary.ml
index 1429c0262b314bff082b941cf0e2fe9d495a1245..c75d03fb740c4d8e94f3de402dc78950783c6288 100644
--- a/src/plugins/value/utils/summary.ml
+++ b/src/plugins/value/utils/summary.ml
@@ -148,7 +148,7 @@ end
(* --- Function stats computation --- *)
let get_status ip =
- let eva_emitter = Value_util.emitter in
+ let eva_emitter = Eva_utils.emitter in
let aux_status emitter status acc =
let emitter = Emitter.Usable_emitter.get emitter.Property_status.emitter in
if Emitter.equal eva_emitter emitter
@@ -207,7 +207,7 @@ module FunctionStats = struct
(FunctionStats_Type)
(struct
let name = "Eva.Summary.FunctionStats"
- let dependencies = [ Db.Value.self ]
+ let dependencies = [ Self.state ]
let size = 17
end)
@@ -427,6 +427,6 @@ let print_summary fmt =
Format.fprintf fmt "%s" bar
let print_summary () =
- let dkey = Value_parameters.dkey_summary in
+ let dkey = Self.dkey_summary in
let header fmt = Format.fprintf fmt " ====== ANALYSIS SUMMARY ======" in
- Value_parameters.printf ~header ~dkey ~level:1 " @[<v>%t@]" print_summary
+ Self.printf ~header ~dkey ~level:1 " @[<v>%t@]" print_summary
diff --git a/src/plugins/value/utils/unit_tests.ml b/src/plugins/value/utils/unit_tests.ml
index 50ef12be9835c4b409339706e9f370ed91d7a363..b7261099a512d7dc08cc405d807bae63d7d39416 100644
--- a/src/plugins/value/utils/unit_tests.ml
+++ b/src/plugins/value/utils/unit_tests.ml
@@ -28,7 +28,7 @@ let print = false
let report bug format =
if print || bug
- then Value_parameters.result ("%s" ^^ format) (if bug then "BUG " else "")
+ then Self.result ("%s" ^^ format) (if bug then "BUG " else "")
else Format.ifprintf Format.std_formatter format
@@ -128,7 +128,7 @@ end
(** Runs all tests. *)
let run () =
- Value_parameters.result "Runs unit tests: %s."
+ Self.result "Runs unit tests: %s."
(if print
then "all operations will be printed"
else "only faulty operations will be printed");
diff --git a/src/plugins/value/utils/unit_tests.mli b/src/plugins/value/utils/unit_tests.mli
index cf1fae9cef81e5104e4e6cb886c7a5170a7caa51..db0856b3653da1a60e995926306d1ba00e7fdcb2 100644
--- a/src/plugins/value/utils/unit_tests.mli
+++ b/src/plugins/value/utils/unit_tests.mli
@@ -20,8 +20,10 @@
(* *)
(**************************************************************************)
-(** Currently tested by this file:
+[@@@ api_start]
+(** Currently tested by this module:
- semantics of sign values. *)
(** Runs some programmatic tests on Eva. *)
val run: unit -> unit
+[@@@ api_end]
diff --git a/src/plugins/value/utils/widen.ml b/src/plugins/value/utils/widen.ml
index b124349d7b634f4038e1d7da6f9c3ca623254e9f..c22541b345139366301de50bf2d6de2c037e0950 100644
--- a/src/plugins/value/utils/widen.ml
+++ b/src/plugins/value/utils/widen.ml
@@ -98,7 +98,7 @@ class pragma_widen_visitor init_widen_hints init_enclosing_loops = object(self)
(* the annotation is empty or contains only variables *)
self#add_var_hints ~stmt var_hints
| (_lv, _lt) ->
- Value_parameters.warning ~once:true
+ Self.warning ~once:true
"could not interpret loop pragma relative to widening variables"
end
| Widen_hints l -> begin
@@ -124,7 +124,7 @@ class pragma_widen_visitor init_widen_hints init_enclosing_loops = object(self)
self#add_float_thresholds ~base float_thresholds;
) vars
| _ ->
- Value_parameters.warning ~once:true
+ Self.warning ~once:true
"could not interpret loop pragma relative to widening hint"
end
| _ -> ()
@@ -314,7 +314,7 @@ let base_of_static_hvars hvars =
| Widen_hints_ext.HintVar vi -> Some (Base.of_varinfo vi)
| Widen_hints_ext.HintMem (e, offset) ->
(* syntactic constraints prevent this from happening *)
- Value_parameters.fatal "unsupported lhost: %a" Printer.pp_lval (Mem e, offset)
+ Self.fatal "unsupported lhost: %a" Printer.pp_lval (Mem e, offset)
type threshold = Int_th of Integer.t | Real_th of logic_real
@@ -332,7 +332,7 @@ let threshold_of_threshold_term ht =
match constFoldTermToLogicReal ht.term_node with
| Some f -> Real_th f
| None ->
- Value_parameters.abort ~source:(fst ht.term_loc)
+ Self.abort ~source:(fst ht.term_loc)
"could not parse widening hint: %a@ \
If it contains variables, they must be global const integers."
Printer.pp_term ht
@@ -344,14 +344,14 @@ let thresholds_of_threshold_terms hts =
match threshold_of_threshold_term ht with
| Int_th i ->
if !has_float then
- Value_parameters.abort ~source:(fst ht.term_loc)
+ Self.abort ~source:(fst ht.term_loc)
"widening hint mixing integers and floats: %a"
Printer.pp_term ht;
has_int := true;
Ival.Widen_Hints.add i int_acc, float_acc
| Real_th f ->
if !has_int then
- Value_parameters.abort ~source:(fst ht.term_loc)
+ Self.abort ~source:(fst ht.term_loc)
"widening hint mixing integers and floats: %a"
Printer.pp_term ht;
has_float := true;
@@ -374,7 +374,7 @@ class hints_visitor init_widen_hints global = object(self)
let int_thresholds, float_thresholds =
thresholds_of_threshold_terms wh_terms
in
- Value_parameters.feedback ~source:(fst loc) ~dkey
+ Self.feedback ~source:(fst loc) ~dkey
"adding%s hint from annotation: %a, %t (for all statements)"
(if global then " global" else "")
(Pretty_utils.pp_opt ~none:(format_of_string "for all variables")
@@ -405,7 +405,7 @@ end
(* Precompute global widen hints, used for all functions *)
let compute_global_static_hints () =
- Value_parameters.debug ~dkey "computing global widen hints";
+ Self.debug ~dkey "computing global widen hints";
let global_widen_hints = ref (Global_Static_Hints.get ()) in
Globals.Functions.iter_on_fundecs (fun fd ->
let visitor = new hints_visitor global_widen_hints true in
@@ -493,7 +493,7 @@ module Parsed_Dynamic_Hints =
(struct
let name = "Widen.Parsed_Dynamic_Hints"
let size = 7
- let dependencies = [ Ast.self; Db.Value.self ]
+ let dependencies = [ Ast.self; Self.state ]
end)
let dynamic_bases_of_lval states e offset =
@@ -508,7 +508,7 @@ let dynamic_bases_of_lval states e offset =
(* Find syntactically the dynamic hints on [stmt]. *)
let extract_dynamic_hints stmt =
let source = fst (Stmt.loc stmt) in
- Value_parameters.debug ~source ~dkey
+ Self.debug ~source ~dkey
"computing dynamic hints for statement %d" stmt.sid;
let wh = Widen_hints_ext.get_stmt_widen_hint_terms stmt in
let aux l (hlv, threshold_terms) =
@@ -530,7 +530,7 @@ module Dynamic_Hints =
State_builder.Ref
(Widen_type)
(struct
- let dependencies = [ Ast.self; Db.Value.self ]
+ let dependencies = [ Ast.self; Self.state ]
let name = "Widen.Dynamic_Hints"
let default = Widen_type.default
end)
@@ -577,7 +577,7 @@ let dynamic_widen_hints_hook (stmt, _callstack, states) =
else
let new_hints =
Base.Hptset.fold (fun base acc ->
- Value_parameters.debug ~source ~dkey
+ Self.debug ~source ~dkey
"adding new base due to dynamic widen hint: %a, %a%a"
Base.pretty base
Ival.Widen_Hints.pretty dhint.int_thresholds
diff --git a/src/plugins/value/utils/widen_hints_ext.ml b/src/plugins/value/utils/widen_hints_ext.ml
index f7e2aef59a10a8b4e7fbeb9e7e6525009917ee39..bd46d2b96f4b737b2398b144bed8804c9181ebc4 100644
--- a/src/plugins/value/utils/widen_hints_ext.ml
+++ b/src/plugins/value/utils/widen_hints_ext.ml
@@ -22,7 +22,7 @@
open Cil_types
-let dkey = Value_parameters.register_category "widen-hints"
+let dkey = Self.register_category "widen-hints"
let error ?msg loc typing_context =
typing_context.Logic_typing.error loc
@@ -126,12 +126,12 @@ let widen_hint_terms_of_terms terms =
in
Some (hint_lval, hint_thresholds)
| _ ->
- Value_parameters.debug ~source:(fst lval_term.term_loc) ~dkey
+ Self.debug ~source:(fst lval_term.term_loc) ~dkey
"invalid var_term: %a@." Printer.pp_term lval_term;
raise Invalid_hint
end
| _ ->
- Value_parameters.debug ~dkey "invalid terms: %a@."
+ Self.debug ~dkey "invalid terms: %a@."
(Pretty_utils.pp_list ~sep:", " Printer.pp_term) terms;
raise Invalid_hint
with
diff --git a/src/plugins/value/utils/widen_hints_ext.mli b/src/plugins/value/utils/widen_hints_ext.mli
index e17c19f6d0115b790c6d44f537670af206b4e0e1..c65b2be878da5f9638c8b33e16caaa8524048cab 100644
--- a/src/plugins/value/utils/widen_hints_ext.mli
+++ b/src/plugins/value/utils/widen_hints_ext.mli
@@ -24,7 +24,7 @@
open Cil_types
-val dkey: Value_parameters.category
+val dkey: Self.category
type hint_vars =
| HintAllVars (* "all" vars: static hint *)
diff --git a/src/plugins/value/values/cvalue_backward.ml b/src/plugins/value/values/cvalue_backward.ml
index 889c776877859e26044a9b2aa40ea1c4b7d479c8..97c67f3aade2df6333bfb2fc874b37149f29731b 100644
--- a/src/plugins/value/values/cvalue_backward.ml
+++ b/src/plugins/value/values/cvalue_backward.ml
@@ -25,7 +25,7 @@ open Cvalue
let propagate_all_comparison typ =
not (Cil.isPointerType typ) ||
- Value_parameters.UndefinedPointerComparisonPropagateAll.get ()
+ Parameters.UndefinedPointerComparisonPropagateAll.get ()
let backward_int_relation typ op v1 v2 =
let v1' = V.backward_comp_int_left op v1 v2 in
@@ -35,14 +35,14 @@ let backward_int_relation typ op v1 v2 =
&& not (Cvalue_forward.are_comparable op v1 v2)
then begin
if not (Cvalue.V.equal v1 v1' || Cvalue.V.is_bottom v1') then
- Value_parameters.result
+ Self.result
~current:true ~once:true
- ~dkey:Value_parameters.dkey_pointer_comparison
+ ~dkey:Self.dkey_pointer_comparison
"not reducing %a to %a because of UPCPA" V.pretty v1 V.pretty v1';
if not (Cvalue.V.equal v2 v2' || Cvalue.V.is_bottom v2') then
- Value_parameters.result
+ Self.result
~current:true ~once:true
- ~dkey:Value_parameters.dkey_pointer_comparison
+ ~dkey:Self.dkey_pointer_comparison
"not reducing %a to %a because of UPCPA" V.pretty v2 V.pretty v2';
None
end
@@ -276,7 +276,7 @@ let backward_binop ~typ_res ~res_value ~typ_e1 v1 binop v2 =
(* comparison operators *)
| (Eq | Ne | Le | Lt | Ge | Gt), _ -> begin
- let binop = Value_util.conv_comp binop in
+ let binop = Eva_utils.conv_comp binop in
match V.is_included V.singleton_zero res_value,
V.is_included V.singleton_one res_value with
| true, true ->
@@ -372,7 +372,7 @@ let downcast_enabled ~ik_src ~ik_dst =
Kernel.SignedDowncast.get () ||
(* In this case, -eva-warn-signed-converted-downcast behaves exactly
as -warn-signed-downcast *)
- (Cil.isSigned ik_src && Value_parameters.WarnSignedConvertedDowncast.get ())
+ (Cil.isSigned ik_src && Parameters.WarnSignedConvertedDowncast.get ())
else Kernel.UnsignedDowncast.get ()
(* see .mli *)
diff --git a/src/plugins/value/values/cvalue_forward.ml b/src/plugins/value/values/cvalue_forward.ml
index 1a3e65a3cc587a02bc1a96f1f968e678a6f4a434..cc48ef0c78aed6b42658f906f4a76df24a9dcff5 100644
--- a/src/plugins/value/values/cvalue_forward.ml
+++ b/src/plugins/value/values/cvalue_forward.ml
@@ -189,9 +189,9 @@ let assume_comparable comparison v1 v2 =
| Abstract_value.Relation ->
let truth, reason = are_comparable_reason comparison v1 v2 in
if reason <> `Ok then
- Value_parameters.result
+ Self.result
~current:true ~once:true
- ~dkey:Value_parameters.dkey_pointer_comparison
+ ~dkey:Self.dkey_pointer_comparison
"invalid pointer comparison: %a" pp_incomparable_reason reason;
truth
| Abstract_value.Subtraction ->
@@ -357,7 +357,7 @@ let forward_minus_pp ~typ ev1 ev2 =
else Ival.scale_div ~pos:true size minus_offs
with Abstract_interp.Error_Top -> Ival.top
in
- if not (Value_parameters.WarnPointerSubstraction.get ()) then
+ if not (Parameters.WarnPointerSubstraction.get ()) then
(* Generate garbled mix if the two pointers disagree on their base *)
let minus_val = V.add_untyped Int_Base.minus_one ev1 ev2 in
try
@@ -402,7 +402,7 @@ let forward_binop_int ~typ ev1 op ev2 =
~contains_zero: (V.contains_zero ev1 || V.contains_zero ev2)
~contains_non_zero:(V.contains_non_zero ev1 && V.contains_non_zero ev2)
| Eq | Ne | Ge | Le | Gt | Lt ->
- let op = Value_util.conv_comp op in
+ let op = Eva_utils.conv_comp op in
let signed = Bit_utils.is_signed_int_enum_pointer (Cil.unrollType typ) in
V.inject_comp_result (V.forward_comp_int ~signed op ev1 ev2)
@@ -420,7 +420,7 @@ let forward_binop_float fkind ev1 op ev2 =
| Mult -> binary_float_floats "*." Fval.mul
| Div -> binary_float_floats "/." Fval.div
| Eq | Ne | Lt | Gt | Le | Ge ->
- let op = Value_util.conv_comp op in
+ let op = Eva_utils.conv_comp op in
V.inject_comp_result (Fval.forward_comp op f1 f2)
| _ -> assert false
@@ -527,7 +527,7 @@ let eval_float_constant f fkind fstring =
if Fc_float.is_nan f
then V.inject_float Fval.nan
else
- let all_rounding = Value_parameters.AllRoundingModesConstants.get in
+ let all_rounding = Parameters.AllRoundingModesConstants.get in
let fl, fu = match fstring with
| Some "INFINITY" -> f, f (* Special case for the INFINITY macro. *)
| Some string when fkind = Cil_types.FLongDouble || all_rounding () ->
@@ -539,7 +539,7 @@ let eval_float_constant f fkind fstring =
if Fc_float.is_infinite f_lower && Fc_float.is_infinite f_upper
then
begin
- Value_util.warning_once_current
+ Eva_utils.warning_once_current
"cannot parse floating-point constant, returning imprecise result";
neg_infinity, infinity
end
diff --git a/src/plugins/value/values/numerors/numerors_arithmetics.ml b/src/plugins/value/values/numerors/numerors_arithmetics.ml
index 85320659dbd099c51e367d1299da251ac2434872..50b0184d0ca43ca92f4efdbd4a69b47b5521080c 100644
--- a/src/plugins/value/values/numerors/numerors_arithmetics.ml
+++ b/src/plugins/value/values/numerors/numerors_arithmetics.ml
@@ -111,7 +111,7 @@ let non_bottom_narrow a b =
match I.narrow a b with
| `Value v -> v
| `Bottom ->
- Value_parameters.fatal
+ Self.fatal
"Numerors: a narrowing leads incorrectly to bottom.@ \
Narrow between %a@ and %a."
I.pretty a I.pretty b
diff --git a/src/plugins/value/values/numerors/numerors_float.ml b/src/plugins/value/values/numerors/numerors_float.ml
index b3816466d613ffa59d20e3cb82ac9b2440565814..079f8dfdceaa7bf2220d774f2e947295cbf0e42d 100644
--- a/src/plugins/value/values/numerors/numerors_float.ml
+++ b/src/plugins/value/values/numerors/numerors_float.ml
@@ -122,7 +122,7 @@ let neg_inf prec = of_mpfr prec @@ Mpfrf.of_float neg_infinity Mpfr.Near
*---------------------------------------------------------------------------*)
let compare (px, nx) (py, ny) =
if not (Precisions.eq px py) then
- Value_parameters.fatal
+ Self.fatal
"Numerors: impossible to compare two numbers with different precisions"
else Mpfrf.cmp nx ny
let eq a b = compare a b = 0
diff --git a/src/plugins/value/values/numerors/numerors_interval.ml b/src/plugins/value/values/numerors/numerors_interval.ml
index 98d2563bc6b30001d51b728256078f51a8a029a4..9d124f16bbcdf9f691b0860e3785f918fec836cb 100644
--- a/src/plugins/value/values/numerors/numerors_interval.ml
+++ b/src/plugins/value/values/numerors/numerors_interval.ml
@@ -51,15 +51,15 @@ let pretty fmt itv =
let prec = function NaN p -> p | I (x, _, _) -> F.prec x
let get_max_exponent = function
- | NaN _ -> Value_parameters.fatal "Numerors: can't return the exponent of a NaN"
+ | NaN _ -> Self.fatal "Numerors: can't return the exponent of a NaN"
| I (x, y, _) -> Stdlib.max (F.exponent x) (F.exponent y)
let get_exponents = function
- | NaN _ -> Value_parameters.fatal "Numerors: can't return the exponent of a NaN"
+ | NaN _ -> Self.fatal "Numerors: can't return the exponent of a NaN"
| I (x, y, _) -> F.exponent x, F.exponent y
let get_bounds = function
- | NaN _ -> Value_parameters.fatal "Numerors: can't return the bounds of a NaN"
+ | NaN _ -> Self.fatal "Numerors: can't return the bounds of a NaN"
| I (x, y, _) -> x, y
@@ -84,7 +84,7 @@ let make ?(nan = false) x y =
let bad_order = F.gt x y in
let bad_precs = not @@ Precisions.eq (F.prec x) (F.prec y) in
if there_a_nan || bad_order || bad_precs then
- Value_parameters.fatal
+ Self.fatal
"Numerors: impossible to create an interval with bounds %a and %a"
F.pretty x F.pretty y
else if F.is_pos_zero x && F.is_neg_zero y then
diff --git a/src/plugins/value/values/numerors/numerors_utils.ml b/src/plugins/value/values/numerors/numerors_utils.ml
index a58c8c8d170d7d26fbb485e8bf1a851ddcb52d4b..c0b5f95e5403102633195c8bacddce1e9c687efa 100644
--- a/src/plugins/value/values/numerors/numerors_utils.ml
+++ b/src/plugins/value/values/numerors/numerors_utils.ml
@@ -30,7 +30,7 @@ module Precisions = struct
type t = Simple | Double | Long_Double | Real
- let rp () = Value_parameters.Numerors_Real_Size.get ()
+ let rp () = Parameters.Numerors_Real_Size.get ()
let pretty fmt = function
| Simple -> Format.fprintf fmt "Simple"
@@ -125,7 +125,7 @@ module Mode = struct
type t = Abs_From_Rel | Rel_From_Abs | No_Interaction | With_Interactions
let get () =
- match Value_parameters.Numerors_Mode.get () with
+ match Parameters.Numerors_Mode.get () with
| "relative" -> Rel_From_Abs
| "absolute" -> Abs_From_Rel
| "none" -> No_Interaction
diff --git a/src/plugins/value/values/sign_value.ml b/src/plugins/value/values/sign_value.ml
index 08334941537bb65fd0931def46400ca033e12a12..b951eefd39f71757399e2e856172bd5e0d992a16 100644
--- a/src/plugins/value/values/sign_value.ml
+++ b/src/plugins/value/values/sign_value.ml
@@ -315,7 +315,7 @@ let backward_comp_right op ~left ~right =
let backward_binop ~input_type:_ ~resulting_type:_ op ~left ~right ~result =
match op with
| Ne | Eq | Le | Lt | Ge | Gt ->
- let op = Value_util.conv_comp op in
+ let op = Eva_utils.conv_comp op in
if equal zero result then
(* The comparison is false, as it always evaluate to false. Reduce by the
fact that the inverse comparison is true. *)
diff --git a/src/plugins/wp/.ocp-indent b/src/plugins/wp/.ocp-indent
deleted file mode 100644
index ef83851c8dc4f772b62ee7bca7afe13faf0c110d..0000000000000000000000000000000000000000
--- a/src/plugins/wp/.ocp-indent
+++ /dev/null
@@ -1 +0,0 @@
-match_clause = 4
diff --git a/src/plugins/wp/AssignsCompleteness.ml b/src/plugins/wp/AssignsCompleteness.ml
index e3454c40692c3fdd2910334565fdef1b3e17a476..2d977d7febc86363118184a4de78140cbf341482 100644
--- a/src/plugins/wp/AssignsCompleteness.ml
+++ b/src/plugins/wp/AssignsCompleteness.ml
@@ -128,30 +128,30 @@ let check_assigns kf assigns =
in
let vfrom acc = function
| t, FromAny when Logic_typing.is_pointer_type t.it_content.term_type ->
- incomplete acc
- begin fun _kf ->
- Wp_parameters.warning ~wkey:wkey_pedantic
- ~once:true ~source:(fst t.it_content.term_loc)
- "No \\from specification for assigned pointer '%a'.@ \
- Callers assumptions might be imprecise."
- Cil_printer.pp_identified_term t
- end
+ incomplete acc
+ begin fun _kf ->
+ Wp_parameters.warning ~wkey:wkey_pedantic
+ ~once:true ~source:(fst t.it_content.term_loc)
+ "No \\from specification for assigned pointer '%a'.@ \
+ Callers assumptions might be imprecise."
+ Cil_printer.pp_identified_term t
+ end
| _ -> acc
in List.fold_left vfrom acc froms
in
match assigns with
| Error l ->
- false,
- begin fun kf ->
- Wp_parameters.warning ~wkey:wkey_pedantic
- ~once:true ~source:(fst (Kernel_function.get_location kf))
- "No 'assigns' specification for function '%a'.@\n%a\
- Callers assumptions might be imprecise."
- Kernel_function.pretty kf
- pretty_behaviors_errors l
- end
+ false,
+ begin fun kf ->
+ Wp_parameters.warning ~wkey:wkey_pedantic
+ ~once:true ~source:(fst (Kernel_function.get_location kf))
+ "No 'assigns' specification for function '%a'.@\n%a\
+ Callers assumptions might be imprecise."
+ Kernel_function.pretty kf
+ pretty_behaviors_errors l
+ end
| Ok l ->
- List.fold_left vassigns complete l
+ List.fold_left vassigns complete l
let memo_compute kf =
Completeness.memo (fun kf -> check_assigns kf (collect_assigns kf)) kf
diff --git a/src/plugins/wp/Auto.ml b/src/plugins/wp/Auto.ml
index 1acae65f1a304d5682b6e844e19e1480e14da11c..600f8cb98f460df124d36709010a2c1524715291 100644
--- a/src/plugins/wp/Auto.ml
+++ b/src/plugins/wp/Auto.ml
@@ -124,9 +124,9 @@ struct
let update merge x v ofs map =
match Repr.term v with
| Int v ->
- let v0 = Integer.add v ofs in
- let v1 = try merge v0 (Tmap.find x map) with Not_found -> v0 in
- Tmap.add x v1 map
+ let v0 = Integer.add v ofs in
+ let v1 = try merge v0 (Tmap.find x map) with Not_found -> v0 in
+ Tmap.add x v1 map
| _ -> map
type rg = {
@@ -144,11 +144,11 @@ struct
match Repr.term p with
| And ps -> List.iter (add_bound rg) ps
| Lt(a,b) when Lang.F.is_int a && Lang.F.is_int b ->
- set_vmax rg a b Integer.minus_one ;
- set_vmin rg b a Integer.one ;
+ set_vmax rg a b Integer.minus_one ;
+ set_vmin rg b a Integer.one ;
| Leq(a,b) when Lang.F.is_int a && Lang.F.is_int b ->
- set_vmax rg a b Integer.zero ;
- set_vmin rg b a Integer.zero ;
+ set_vmax rg a b Integer.zero ;
+ set_vmin rg b a Integer.zero ;
| _ -> ()
let compute hs =
@@ -222,7 +222,7 @@ class autosplit =
| Bind (Exists,_,phi) -> is_split (F.repr (F.QED.lc_repr phi))
| And _ | Or _ | If _ | Imply _ -> true
| _ -> false
- in is_split (F.repr (F.QED.lc_repr phi))
+ in is_split (F.repr (F.QED.lc_repr phi))
| Neq(x,y) | Eq(x,y) -> (F.is_prop x) && (F.is_prop y)
| _ -> false
in
@@ -238,12 +238,12 @@ class autosplit =
let open Conditions in
match s.condition with
| Branch(_,sa,sb) ->
- let priority =
- if F.Vars.intersect target (Conditions.vars_hyp sa) ||
- F.Vars.intersect target (Conditions.vars_hyp sb)
- then 1.0 else 0.5 in
- let selection = Tactical.(Clause(Step s)) in
- push (split ~priority selection)
+ let priority =
+ if F.Vars.intersect target (Conditions.vars_hyp sa) ||
+ F.Vars.intersect target (Conditions.vars_hyp sb)
+ then 1.0 else 0.5 in
+ let selection = Tactical.(Clause(Step s)) in
+ push (split ~priority selection)
| _ -> ()
) (fst seq)
diff --git a/src/plugins/wp/Cache.ml b/src/plugins/wp/Cache.ml
index be67d7fbc64588fa81f58958e7106147cdac3753..0540c9fad569d29ec454fe1a3852bedbef932b3b 100644
--- a/src/plugins/wp/Cache.ml
+++ b/src/plugins/wp/Cache.ml
@@ -101,9 +101,9 @@ let parse_mode ~origin ~fallback = function
| "cleanup" -> Cleanup
| "" -> raise Not_found
| m ->
- Wp_parameters.warning ~current:false
- "Unknown %s mode %S (use %s instead)" origin m fallback ;
- raise Not_found
+ Wp_parameters.warning ~current:false
+ "Unknown %s mode %S (use %s instead)" origin m fallback ;
+ raise Not_found
let mode_name = function
| NoCache -> "none"
@@ -164,54 +164,54 @@ let promote ~timeout ~steplimit (res : VCS.result) =
| VCS.NoResult | VCS.Computing _ -> VCS.no_result
| VCS.Failed -> res
| VCS.Invalid | VCS.Valid | VCS.Unknown ->
- if not (steps_fits res.prover_steps steplimit) then
- { res with verdict = Stepout }
- else
- if not (time_fits res.prover_time timeout) then
- { res with verdict = Timeout }
- else res
+ if not (steps_fits res.prover_steps steplimit) then
+ { res with verdict = Stepout }
+ else
+ if not (time_fits res.prover_time timeout) then
+ { res with verdict = Timeout }
+ else res
| VCS.Timeout | VCS.Stepout ->
- if steps_seized res.prover_steps steplimit then
- { res with verdict = Stepout }
- else
- if time_seized res.prover_time timeout then
- { res with verdict = Timeout }
- else (* can be run a longer time or widely *)
- VCS.no_result
+ if steps_seized res.prover_steps steplimit then
+ { res with verdict = Stepout }
+ else
+ if time_seized res.prover_time timeout then
+ { res with verdict = Timeout }
+ else (* can be run a longer time or widely *)
+ VCS.no_result
let get_cache_result ~mode hash =
match mode with
| NoCache | Rebuild -> VCS.no_result
| Update | Cleanup | Replay | Offline ->
- try
- let dir = get_usable_dir ~make:true () in
- let hash = Lazy.force hash in
- let file = Printf.sprintf "%s/%s.json" dir hash in
- if not (Sys.file_exists file) then VCS.no_result
- else
- try
- mark_cache ~mode hash ;
- Json.load_file file |> ProofScript.result_of_json
- with err ->
- Wp_parameters.warning ~current:false ~once:true
- "invalid cache entry (%s)" (Printexc.to_string err) ;
- VCS.no_result
- with Not_found -> VCS.no_result
+ try
+ let dir = get_usable_dir ~make:true () in
+ let hash = Lazy.force hash in
+ let file = Printf.sprintf "%s/%s.json" dir hash in
+ if not (Sys.file_exists file) then VCS.no_result
+ else
+ try
+ mark_cache ~mode hash ;
+ Json.load_file file |> ProofScript.result_of_json
+ with err ->
+ Wp_parameters.warning ~current:false ~once:true
+ "invalid cache entry (%s)" (Printexc.to_string err) ;
+ VCS.no_result
+ with Not_found -> VCS.no_result
let set_cache_result ~mode hash prover result =
match mode with
| NoCache | Replay | Offline -> ()
| Rebuild | Update | Cleanup ->
- let hash = Lazy.force hash in
- try
- let dir = get_usable_dir ~make:true () in
- let file = Printf.sprintf "%s/%s.json" dir hash in
- mark_cache ~mode hash ;
- ProofScript.json_of_result (VCS.Why3 prover) result
- |> Json.save_file file
- with err ->
- Wp_parameters.warning ~current:false ~once:true
- "can not update cache (%s)" (Printexc.to_string err)
+ let hash = Lazy.force hash in
+ try
+ let dir = get_usable_dir ~make:true () in
+ let file = Printf.sprintf "%s/%s.json" dir hash in
+ mark_cache ~mode hash ;
+ ProofScript.json_of_result (VCS.Why3 prover) result
+ |> Json.save_file file
+ with err ->
+ Wp_parameters.warning ~current:false ~once:true
+ "can not update cache (%s)" (Printexc.to_string err)
let clear_result ~digest prover goal =
try
@@ -244,11 +244,11 @@ let cleanup_cache () =
) (Sys.readdir dir) ;
with
| Unix.Unix_error _ as exn ->
- Wp_parameters.warning ~current:false
- "Can not cleanup cache (%s)" (Printexc.to_string exn)
+ Wp_parameters.warning ~current:false
+ "Can not cleanup cache (%s)" (Printexc.to_string exn)
| Not_found ->
- Wp_parameters.warning ~current:false
- "Cannot cleanup cache"
+ Wp_parameters.warning ~current:false
+ "Cannot cleanup cache"
type 'a digest =
Why3Provers.t -> 'a -> string
@@ -262,29 +262,29 @@ let get_result ~digest ~runner ~timeout ~steplimit prover goal =
match mode with
| NoCache -> runner ~timeout ~steplimit prover goal
| Offline ->
- let hash = lazy (digest prover goal) in
- let result = get_cache_result ~mode hash |> VCS.cached in
- if VCS.is_verdict result then incr hits else incr miss ;
- Task.return result
+ let hash = lazy (digest prover goal) in
+ let result = get_cache_result ~mode hash |> VCS.cached in
+ if VCS.is_verdict result then incr hits else incr miss ;
+ Task.return result
| Update | Replay | Rebuild | Cleanup ->
- let hash = lazy (digest prover goal) in
- let result =
- get_cache_result ~mode hash
- |> promote ~timeout ~steplimit |> VCS.cached in
- if VCS.is_verdict result
- then
- begin
- incr hits ;
- Task.return result
+ let hash = lazy (digest prover goal) in
+ let result =
+ get_cache_result ~mode hash
+ |> promote ~timeout ~steplimit |> VCS.cached in
+ if VCS.is_verdict result
+ then
+ begin
+ incr hits ;
+ Task.return result
+ end
+ else
+ Task.finally
+ (runner ~timeout ~steplimit prover goal)
+ begin function
+ | Task.Result result when VCS.is_verdict result ->
+ incr miss ;
+ set_cache_result ~mode hash prover result
+ | _ -> ()
end
- else
- Task.finally
- (runner ~timeout ~steplimit prover goal)
- begin function
- | Task.Result result when VCS.is_verdict result ->
- incr miss ;
- set_cache_result ~mode hash prover result
- | _ -> ()
- end
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/CfgCompiler.ml b/src/plugins/wp/CfgCompiler.ml
index bd12d7d76ce4e0043b660f22c7da46c18b53e8f7..f2929d9055ce5d50cc93a08d8fdaff33363f93e9 100644
--- a/src/plugins/wp/CfgCompiler.ml
+++ b/src/plugins/wp/CfgCompiler.ml
@@ -222,7 +222,7 @@ struct
match src,tgt with
| Some src , Some tgt -> identify sigma ~src ~tgt
| Some _, None ->
- invalid_arg (Format.asprintf "P.relocate: tgt is smaller than src at %a" Node.pp n)
+ invalid_arg (Format.asprintf "P.relocate: tgt is smaller than src at %a" Node.pp n)
| _ -> ())
src tgt ;
let tgt = Node.Map.inter (fun _ _ tgt -> tgt) src tgt in
@@ -320,8 +320,8 @@ struct
let iter_succs : type a b. (Node.t -> unit) -> (a,b) edge -> unit = fun f -> function
| Goto n2 | Effect(_,n2) | Havoc(_,n2) -> f n2
| Branch(_,n2a,n2b) ->
- let f' = function None -> () | Some x -> f x in
- f' n2a; f' n2b
+ let f' = function None -> () | Some x -> f x in
+ f' n2a; f' n2b
| Either l -> List.iter f l
| Implies l -> List.iter (fun (_,a) -> f a) l
| Binding (_,n2) -> f n2
@@ -360,9 +360,9 @@ struct
let pretty_data fmt = function
| Meta(s_opt,str_opt) ->
- Format.fprintf fmt "Meta(%a,%a)"
- (Pretty_utils.pp_opt ~none:"None" Cil_datatype.Stmt.pretty_sid) s_opt
- (Pretty_utils.pp_opt ~none:"None" Format.pp_print_string) str_opt
+ Format.fprintf fmt "Meta(%a,%a)"
+ (Pretty_utils.pp_opt ~none:"None" Cil_datatype.Stmt.pretty_sid) s_opt
+ (Pretty_utils.pp_opt ~none:"None" Format.pp_print_string) str_opt
let pretty_env : type a. Format.formatter -> (_,a) env -> unit =
fun fmt env ->
@@ -383,12 +383,12 @@ struct
begin match edge with
| Goto n1 -> pp_edge n1
| Branch (_, n1, n2)->
- Option.iter pp_edge n1;
- Option.iter pp_edge n2
+ Option.iter pp_edge n1;
+ Option.iter pp_edge n2
| Either ns -> List.iter pp_edge ns
| Implies ns -> List.iter (fun (_,a) -> pp_edge a) ns
| Effect (e, n') ->
- pp_edge ~label:(Format.asprintf "%a" E.pretty e) n'
+ pp_edge ~label:(Format.asprintf "%a" E.pretty e) n'
| Havoc (_, n') -> pp_edge ~label:"havoc" n'
| Binding (_,n') -> pp_edge ~label:"binding" n'
end
@@ -459,16 +459,16 @@ struct
let add_edges : type a b. Node.t -> (a,b) edge -> unit = fun n1 -> function
| Goto n2 -> add_edge n1 [] n2
| Branch((_,c),n2,n2') ->
- let aux s = function
- | None -> ()
- | Some n -> add_edge n1 [`Label (escape "%s%a" s Lang.F.pp_pred c)] n
- in
- aux "" n2; aux "!" n2'
+ let aux s = function
+ | None -> ()
+ | Some n -> add_edge n1 [`Label (escape "%s%a" s Lang.F.pp_pred c)] n
+ in
+ aux "" n2; aux "!" n2'
| Either l -> List.iter (add_edge n1 []) l
| Implies l ->
- List.iter (fun (c,n) -> add_edge n1 [`Label (escape "%a" Lang.F.pp_pred (C.get c))] n) l
+ List.iter (fun (c,n) -> add_edge n1 [`Label (escape "%a" Lang.F.pp_pred (C.get c))] n) l
| Effect ((_,e),n2) ->
- add_edge n1 [`Label (escape "%a" Lang.F.pp_pred e)] n2
+ add_edge n1 [`Label (escape "%a" Lang.F.pp_pred e)] n2
| Havoc (_,n2) -> add_edge n1 [`Label (escape "havoc")] n2
| Binding (_,n2) -> add_edge n1 [`Label (escape "binding")] n2
in
@@ -602,31 +602,31 @@ struct
match Node.Map.find node env.succs with
| exception Not_found -> None
| Goto (node2) ->
- effects env post node2
+ effects env post node2
| Branch (_, node2, node3) ->
- union_opt_or S.union
- (option_bind ~f:(effects env post) node2)
- (option_bind ~f:(effects env post) node3)
+ union_opt_or S.union
+ (option_bind ~f:(effects env post) node2)
+ (option_bind ~f:(effects env post) node3)
| Either (l) ->
- (List.fold_left
- (fun acc node2 -> union_opt_or S.union
- acc (effects env post node2))
- None l)
+ (List.fold_left
+ (fun acc node2 -> union_opt_or S.union
+ acc (effects env post node2))
+ None l)
| Implies (l) ->
- (List.fold_left
- (fun acc (_,node2) -> union_opt_or S.union
- acc (effects env post node2))
- None l)
+ (List.fold_left
+ (fun acc (_,node2) -> union_opt_or S.union
+ acc (effects env post node2))
+ None l)
| Effect (effect , node2) ->
- add_only_if_alive S.union
- (E.writes effect)
- (effects env post node2)
+ add_only_if_alive S.union
+ (E.writes effect)
+ (effects env post node2)
| Havoc (m, node2) ->
- union_opt_and S.union
- (effects env m.post m.pre)
- (effects env post node2)
+ union_opt_and S.union
+ (effects env m.post m.pre)
+ (effects env post node2)
| Binding (_,node2) ->
- effects env post node2
+ effects env post node2
(** restrict a cfg to the nodes accessible from the pre post given,
and compute havoc effect *)
@@ -638,44 +638,44 @@ struct
let r = match Node.Map.find node cfg.succs with
| exception Not_found -> None
| (Goto (node2) | Effect (_ , node2)) as edge ->
- union_opt_and env_union
- (Some (new_env edge))
- (walk acc node2)
+ union_opt_and env_union
+ (Some (new_env edge))
+ (walk acc node2)
| Branch (pred, node2, node3) ->
- (** it is important to visit all the childrens *)
- let f acc node =
- match option_bind ~f:(walk acc) node with
- | None -> None, acc
- | Some acc -> node, acc in
- let node2, acc = f acc node2 in
- let node3, acc = f acc node3 in
- if node2 = None && node3 = None then None
- else Some (env_union acc (new_env (Branch(pred, node2, node3))))
+ (** it is important to visit all the childrens *)
+ let f acc node =
+ match option_bind ~f:(walk acc) node with
+ | None -> None, acc
+ | Some acc -> node, acc in
+ let node2, acc = f acc node2 in
+ let node3, acc = f acc node3 in
+ if node2 = None && node3 = None then None
+ else Some (env_union acc (new_env (Branch(pred, node2, node3))))
| Either (l) ->
- let acc,l = List.fold_left
- (fun ((acc,l) as old) node2 ->
- match walk acc node2 with
- | None -> old
- | Some acc -> (acc,node2::l))
- (acc,[]) l in
- if l = [] then None
- else Some (env_union acc (new_env (Either (List.rev l))))
+ let acc,l = List.fold_left
+ (fun ((acc,l) as old) node2 ->
+ match walk acc node2 with
+ | None -> old
+ | Some acc -> (acc,node2::l))
+ (acc,[]) l in
+ if l = [] then None
+ else Some (env_union acc (new_env (Either (List.rev l))))
| Implies (l) ->
- let acc,l = List.fold_left
- (fun ((acc,l) as old) ((_,node2) as e) ->
- match walk acc node2 with
- | None -> old
- | Some acc -> (acc,e::l))
- (acc,[]) l in
- if l = [] then None
- else Some (env_union acc (new_env (Implies (List.rev l))))
+ let acc,l = List.fold_left
+ (fun ((acc,l) as old) ((_,node2) as e) ->
+ match walk acc node2 with
+ | None -> old
+ | Some acc -> (acc,e::l))
+ (acc,[]) l in
+ if l = [] then None
+ else Some (env_union acc (new_env (Implies (List.rev l))))
| Havoc (m, node2) ->
- match effects cfg m.post m.pre with
- | None -> None
- | Some eff ->
- union_opt_and env_union
- (Some (new_env (Havoc(eff,node2))))
- (walk acc node2)
+ match effects cfg m.post m.pre with
+ | None -> None
+ | Some eff ->
+ union_opt_and env_union
+ (Some (new_env (Havoc(eff,node2))))
+ (walk acc node2)
in
if Node.Set.mem node posts && r = None
then Some acc
@@ -684,13 +684,13 @@ struct
match walk (new_env ()) pre with
| None -> (new_env ())
| Some acc ->
- { succs = acc.succs;
- datas = Node.Map.inter (fun _ _ v -> v) acc.succs cfg.datas;
- assumes = Bag.filter (fun (seq,_) ->
- Node.Map.subset (fun _ _ _ -> true)
- seq acc.succs) cfg.assumes;
- tmpnodes = cfg.tmpnodes;
- }
+ { succs = acc.succs;
+ datas = Node.Map.inter (fun _ _ v -> v) acc.succs cfg.datas;
+ assumes = Bag.filter (fun (seq,_) ->
+ Node.Map.subset (fun _ _ _ -> true)
+ seq acc.succs) cfg.assumes;
+ tmpnodes = cfg.tmpnodes;
+ }
(** succ is decreasing for this order *)
let topological (type a) (type b) (cfg:(a,b) env) =
@@ -749,7 +749,7 @@ struct
iter_succs incr_how_many_preds e;
match (e:(_,without_bindings) edge) with
| Goto n' when not (Node.Set.mem n used_nodes) ->
- Node.Map.add n n' acc
+ Node.Map.add n n' acc
| Goto _
| Branch (_,_,_)
| Either _
@@ -779,22 +779,22 @@ struct
Node.Set.mem b env.tmpnodes &&
true
->
- begin
- let find_opt k m =
- match Node.Map.find k m with
- | exception Not_found -> None
- | v -> Some v
- in
- match find_opt a env.succs, find_opt b env.succs with
- | Some Branch(c,Some n1, None), Some Branch(c',None, Some n2)
- | Some Branch(c,None, Some n2), Some Branch(c',Some n1,None) when C.equal c c' ->
- let n1 = find n1 in
- let n2 = find n2 in
- let br = Branch(c,Some n1, Some n2) in
- Node.Hashtbl.add to_remove a br;
- Node.Hashtbl.add to_remove b br
- | _ -> ()
- end
+ begin
+ let find_opt k m =
+ match Node.Map.find k m with
+ | exception Not_found -> None
+ | v -> Some v
+ in
+ match find_opt a env.succs, find_opt b env.succs with
+ | Some Branch(c,Some n1, None), Some Branch(c',None, Some n2)
+ | Some Branch(c,None, Some n2), Some Branch(c',Some n1,None) when C.equal c c' ->
+ let n1 = find n1 in
+ let n2 = find n2 in
+ let br = Branch(c,Some n1, Some n2) in
+ Node.Hashtbl.add to_remove a br;
+ Node.Hashtbl.add to_remove b br
+ | _ -> ()
+ end
| Goto _
| Branch (_,_,_)
| Effect (_,_)
@@ -808,37 +808,37 @@ struct
| _ when Node.Hashtbl.mem to_remove n -> None
| Goto _ when not (Node.Set.mem n used_nodes) -> None
| Goto n' ->
- let n'' = find n' in
- if Node.equal n' n'' then Some e
- else Some (Goto n'')
+ let n'' = find n' in
+ if Node.equal n' n'' then Some e
+ else Some (Goto n'')
| Branch (c,n1,n2) ->
- let n1' = Option.map find n1 in
- let n2' = Option.map find n2 in
- if Option.equal Node.equal n1 n1' && Option.equal Node.equal n2 n2'
- then Some e
- else Some (Branch(c,n1',n2'))
+ let n1' = Option.map find n1 in
+ let n2' = Option.map find n2 in
+ if Option.equal Node.equal n1 n1' && Option.equal Node.equal n2 n2'
+ then Some e
+ else Some (Branch(c,n1',n2'))
| Either l ->
- let l' = List.map find l in
- let l' = List.sort_uniq Node.compare l' in
- begin match l' with
- | [] -> assert false (* absurd: Either after restricted has at least one successor *)
- | [a] -> Some (Goto a)
- | [a;_] when Node.Hashtbl.mem to_remove a ->
- let br = Node.Hashtbl.find to_remove a in
- Some br
- | l' -> Some (Either l')
- end
+ let l' = List.map find l in
+ let l' = List.sort_uniq Node.compare l' in
+ begin match l' with
+ | [] -> assert false (* absurd: Either after restricted has at least one successor *)
+ | [a] -> Some (Goto a)
+ | [a;_] when Node.Hashtbl.mem to_remove a ->
+ let br = Node.Hashtbl.find to_remove a in
+ Some br
+ | l' -> Some (Either l')
+ end
| Implies l ->
- let l' = List.map (fun (g,n) -> (g,find n)) l in
- Some (Implies l')
+ let l' = List.map (fun (g,n) -> (g,find n)) l in
+ Some (Implies l')
| Effect (ef,n') ->
- let n'' = find n' in
- if Node.equal n' n'' then Some e
- else Some (Effect(ef,n''))
+ let n'' = find n' in
+ if Node.equal n' n'' then Some e
+ else Some (Effect(ef,n''))
| Havoc (h,n') ->
- let n'' = find n' in
- if Node.equal n' n'' then Some e
- else Some (Havoc(h,n''))
+ let n'' = find n' in
+ if Node.equal n' n'' then Some e
+ else Some (Havoc(h,n''))
)
env.succs
in
@@ -876,69 +876,69 @@ struct
let ret =
match Node.Map.find node env.succs with
| exception Not_found ->
- (** posts node *)
- let s1 = S.create () in
- allocate dom s1;
- s1
+ (** posts node *)
+ let s1 = S.create () in
+ allocate dom s1;
+ s1
| Goto (node2) ->
- let s1 = S.copy (aux node2) in
- allocate dom s1;
- add_edge node (Goto node2);
- s1
+ let s1 = S.copy (aux node2) in
+ allocate dom s1;
+ add_edge node (Goto node2);
+ s1
| Branch (pred, node2, node3) ->
- let dom = (S.union (C.reads pred) dom) in
- begin match node2, node3 with
- | (None, Some next) | (Some next, None) ->
- let s1 = S.copy (aux next) in
- allocate dom s1;
- let pred = C.relocate s1 pred in
- add_edge node (Branch(pred,node2,node3));
- s1
- | Some node2, Some node3 ->
- let s2 = aux node2 in
- let s3 = aux node3 in
- let s1,p2,p3 = S.merge s2 s3 in
- allocate dom s1;
- let node2' = add_binding_edge node2 p2 in
- let node3' = add_binding_edge node3 p3 in
- let pred = C.relocate s1 pred in
- add_edge node (Branch(pred,Some node2',Some node3'));
- s1
- | _ -> assert false
- end
+ let dom = (S.union (C.reads pred) dom) in
+ begin match node2, node3 with
+ | (None, Some next) | (Some next, None) ->
+ let s1 = S.copy (aux next) in
+ allocate dom s1;
+ let pred = C.relocate s1 pred in
+ add_edge node (Branch(pred,node2,node3));
+ s1
+ | Some node2, Some node3 ->
+ let s2 = aux node2 in
+ let s3 = aux node3 in
+ let s1,p2,p3 = S.merge s2 s3 in
+ allocate dom s1;
+ let node2' = add_binding_edge node2 p2 in
+ let node3' = add_binding_edge node3 p3 in
+ let pred = C.relocate s1 pred in
+ add_edge node (Branch(pred,Some node2',Some node3'));
+ s1
+ | _ -> assert false
+ end
| Either (l) ->
- let s1, pl = S.merge_list (List.map aux l) in
- allocate dom s1;
- let l = List.map2 add_binding_edge l pl in
- add_edge node (Either l);
- s1
+ let s1, pl = S.merge_list (List.map aux l) in
+ allocate dom s1;
+ let l = List.map2 add_binding_edge l pl in
+ add_edge node (Either l);
+ s1
| Implies (l) ->
- let dom =
- List.fold_left (fun acc (c,_) -> S.union (C.reads c) acc) dom l
- in
- let s1, pl = S.merge_list (List.map (fun (_,n) -> aux n) l) in
- allocate dom s1;
- let l = List.map2 (fun (c,a) b ->
- let a = add_binding_edge a b in
- let c = C.relocate s1 c in
- (c,a)) l pl
- in
- add_edge node (Implies l);
- s1
+ let dom =
+ List.fold_left (fun acc (c,_) -> S.union (C.reads c) acc) dom l
+ in
+ let s1, pl = S.merge_list (List.map (fun (_,n) -> aux n) l) in
+ allocate dom s1;
+ let l = List.map2 (fun (c,a) b ->
+ let a = add_binding_edge a b in
+ let c = C.relocate s1 c in
+ (c,a)) l pl
+ in
+ add_edge node (Implies l);
+ s1
| Effect (effect , node2) ->
- let s2 = aux node2 in
- let s1 = S.remove_chunks s2 (E.writes effect) in
- allocate dom s1;
- allocate (E.reads effect) s1;
- let effect = E.relocate {pre=s1;post=s2} effect in
- add_edge node (Effect(effect,node2));
- s1
+ let s2 = aux node2 in
+ let s1 = S.remove_chunks s2 (E.writes effect) in
+ allocate dom s1;
+ allocate (E.reads effect) s1;
+ let effect = E.relocate {pre=s1;post=s2} effect in
+ add_edge node (Effect(effect,node2));
+ s1
| Havoc (eff, node2) ->
- let s2 = aux node2 in
- let s1 = S.havoc s2 eff in
- allocate dom s1;
- add_edge node (Havoc(eff,node2));
- s1
+ let s2 = aux node2 in
+ let s1 = S.havoc s2 eff in
+ allocate dom s1;
+ add_edge node (Havoc(eff,node2));
+ s1
in
visited := Node.Map.add node ret !visited;
ret
@@ -960,8 +960,8 @@ struct
match s with
| Goto n1 | Havoc (_, n1) | Effect (_,n1) | Binding (_,n1) -> add n1 n
| Branch (_,Some n1,Some n2) ->
- add n1 n;
- add n2 n
+ add n1 n;
+ add n2 n
| Branch(_,Some n1,None) -> add n1 n
| Branch(_,None,Some n1) -> add n1 n
| Branch(_,None,None) -> ()
@@ -1017,8 +1017,8 @@ struct
match s with
| Goto n' | Havoc (_, n') -> add acc n' F.p_true
| Branch (c,Some n1,Some n2) ->
- let c = P.get c in
- add (add acc n1 c) n2 (F.p_not c)
+ let c = P.get c in
+ add (add acc n1 c) n2 (F.p_not c)
| Branch(c,Some n1,None) -> add acc n1 (P.get c)
| Branch(c,None,Some n1) -> add acc n1 (F.p_not (P.get c))
| Branch(_,None,None) -> acc
@@ -1026,8 +1026,8 @@ struct
| Implies l -> List.fold_left (fun acc (c,e) -> add acc e (P.get c)) acc l
| Effect (e,n') -> add acc n' (E.get e)
| Binding (b,n') ->
- let b = F.p_conj (Passive.conditions b (fun _ -> true)) in
- add acc n' b
+ let b = F.p_conj (Passive.conditions b (fun _ -> true)) in
+ add acc n' b
) env.succs Node.Map.empty
in
Node.Map.fold (fun n' preds f ->
@@ -1045,8 +1045,8 @@ struct
Bag.fold_left (fun (os,od) b ->
match b with
| Meta(os',od') ->
- (if os = None then os' else os),
- (if od = None then od' else od)
+ (if os = None then os' else os),
+ (if od = None then od' else od)
) (None,None) bag in
add_cond ?stmt ?descr f f'
) predecessors f
@@ -1058,49 +1058,49 @@ struct
let node_is_accessible = access n in
let f' = match s with
| Goto n' | Havoc (_, n') ->
- (* The havoc is already taken into account during {!domains} *)
- Conditions.Branch(node_is_accessible,
- have_access n',
- Conditions.empty)
+ (* The havoc is already taken into account during {!domains} *)
+ Conditions.Branch(node_is_accessible,
+ have_access n',
+ Conditions.empty)
| Branch (c,Some n1,Some n2) ->
- Conditions.Branch(node_is_accessible,
- !. (Conditions.Branch((C.get c),
- have_access n1,
- have_access n2)),
- Conditions.empty)
+ Conditions.Branch(node_is_accessible,
+ !. (Conditions.Branch((C.get c),
+ have_access n1,
+ have_access n2)),
+ Conditions.empty)
| Branch(c,Some n1,None) ->
- Conditions.Branch(node_is_accessible,
- Conditions.append
- (!. (Conditions.Have (C.get c)))
- (have_access n1),
- Conditions.empty)
+ Conditions.Branch(node_is_accessible,
+ Conditions.append
+ (!. (Conditions.Have (C.get c)))
+ (have_access n1),
+ Conditions.empty)
| Branch(c,_,Some n1) ->
- Conditions.Branch(node_is_accessible,
- Conditions.append
- (!. (Conditions.Have (F.p_not (C.get c))))
- (have_access n1),
- Conditions.empty)
+ Conditions.Branch(node_is_accessible,
+ Conditions.append
+ (!. (Conditions.Have (F.p_not (C.get c))))
+ (have_access n1),
+ Conditions.empty)
| Branch(_,None,None) -> assert false
| Either l ->
- let l = List.map have_access l in
- Conditions.Branch(node_is_accessible, either l, Conditions.empty)
+ let l = List.map have_access l in
+ Conditions.Branch(node_is_accessible, either l, Conditions.empty)
| Implies l ->
- let l = List.map
- (fun (c,n) -> !. (Conditions.Branch (C.get c, have_access n, Conditions.empty)))
- l in
- Conditions.Branch(node_is_accessible, Conditions.concat l, Conditions.empty)
+ let l = List.map
+ (fun (c,n) -> !. (Conditions.Branch (C.get c, have_access n, Conditions.empty)))
+ l in
+ Conditions.Branch(node_is_accessible, Conditions.concat l, Conditions.empty)
| Effect (e,n) ->
- Conditions.Branch(node_is_accessible,
- Conditions.append
- (!. (Conditions.Have (E.get e)))
- (have_access n) ,
- Conditions.empty)
+ Conditions.Branch(node_is_accessible,
+ Conditions.append
+ (!. (Conditions.Have (E.get e)))
+ (have_access n) ,
+ Conditions.empty)
| Binding (b,n') ->
- (** For basic: all the variables are important *)
- let b = !. (Conditions.Have(F.p_conj (Passive.conditions b (fun _ -> true)))) in
- Conditions.Branch(node_is_accessible,
- Conditions.append b (have_access n'),
- Conditions.empty) in
+ (** For basic: all the variables are important *)
+ let b = !. (Conditions.Have(F.p_conj (Passive.conditions b (fun _ -> true)))) in
+ Conditions.Branch(node_is_accessible,
+ Conditions.append b (have_access n'),
+ Conditions.empty) in
let stmt,descr =
let bag = match Node.Map.find n env.datas with
| exception Not_found -> Bag.empty
@@ -1109,8 +1109,8 @@ struct
Bag.fold_left (fun (os,od) b ->
match b with
| Meta(os',od') ->
- (if os = None then os' else os),
- (if od = None then od' else od)
+ (if os = None then os' else os),
+ (if od = None then od' else od)
) (None,None) bag in
add_cond ?stmt ?descr f f'
) env.succs f
@@ -1307,17 +1307,17 @@ struct
match cond with
| Conditions.Have c when F.is_ptrue c = Qed.Logic.Yes -> f
| _ ->
- Conditions.append (Conditions.sequence [Conditions.step ?descr ?stmt cond]) f
+ Conditions.append (Conditions.sequence [Conditions.step ?descr ?stmt cond]) f
let access env n = Node.Hashtbl.find env.full_conds n
let get_latest_node env = function
| [] -> env.root
| a::l ->
- let n = List.fold_left (fun a e ->
- if env.topo_order a < env.topo_order e then e else a
- ) a l in
- Node.Hashtbl.find env.subtrees n
+ let n = List.fold_left (fun a e ->
+ if env.topo_order a < env.topo_order e then e else a
+ ) a l in
+ Node.Hashtbl.find env.subtrees n
(** Add each assume to the sub-tree corresponding to the latest
node it uses. The assumes are true if all their nodes are
@@ -1343,7 +1343,7 @@ struct
| Qed.Logic.Yes -> Conditions.concat [f;f']
| Qed.Logic.No -> f
| Qed.Logic.Maybe ->
- add_cond f (Conditions.Branch(t.c,f',Conditions.empty))
+ add_cond f (Conditions.Branch(t.c,f',Conditions.empty))
let to_sequence_tree _ posts env =
let env,ordered = create_env_to_sequence_tree env in
@@ -1396,12 +1396,12 @@ struct
match Node.Map.find n user_reads with
| exception Not_found -> acc
| domain ->
- let domain' =
- try
- S.union (Node.Map.find n' acc) domain
- with Not_found -> domain
- in
- Node.Map.add n' domain' acc)
+ let domain' =
+ try
+ S.union (Node.Map.find n' acc) domain
+ with Not_found -> domain
+ in
+ Node.Map.add n' domain' acc)
subst user_reads
in
(** For each node what must be read for assumes *)
@@ -1420,19 +1420,19 @@ struct
let f, preds =
match mode with
| `Tree ->
- (** Add a unique post node *)
- let final_node = node () in
- let env =
- Node.Set.fold (fun p cfg ->
- let s = {pre=S.create();post=S.create()} in
- let e = s,Lang.F.p_true in
- let goto = effect p e final_node in
- concat goto cfg
- ) posts env
- in
- To_tree.to_sequence_tree pre posts env
+ (** Add a unique post node *)
+ let final_node = node () in
+ let env =
+ Node.Set.fold (fun p cfg ->
+ let s = {pre=S.create();post=S.create()} in
+ let e = s,Lang.F.p_true in
+ let goto = effect p e final_node in
+ concat goto cfg
+ ) posts env
+ in
+ To_tree.to_sequence_tree pre posts env
| (`Bool_Backward | `Bool_Forward) as mode ->
- to_sequence_bool ~mode pre posts env in
+ to_sequence_bool ~mode pre posts env in
let predssigmas =
Node.Map.merge
(fun _ p s -> Some (Option.value ~default:F.p_false p, Option.value ~default:(S.create ()) s))
diff --git a/src/plugins/wp/Cfloat.ml b/src/plugins/wp/Cfloat.ml
index 7dd70297684fa32b6293c1f90e365419fa3a98d4..de34f9a9cb1cf3837c7c3619e54563b3684d5eee 100644
--- a/src/plugins/wp/Cfloat.ml
+++ b/src/plugins/wp/Cfloat.ml
@@ -229,9 +229,9 @@ let float_lit ulp (q : Q.t) =
let rec lookup ulp v = function
| [] -> Pretty_utils.to_string Floating_point.pretty v
| pp::pps ->
- let r = force_float @@ pp v in
- if reparse ulp r = v then r else
- lookup ulp v pps
+ let r = force_float @@ pp v in
+ if reparse ulp r = v then r else
+ lookup ulp v pps
in lookup ulp v printers
(* -------------------------------------------------------------------------- *)
@@ -266,11 +266,11 @@ let rec exact e =
let round ulp e =
match F.repr e with
| Qed.Logic.Fun( f , [ b ] ) ->
- begin
- match find f with
- | REAL , ulp2 when ulp2 = ulp -> b
- | _ -> qmake ulp (exact e )
- end
+ begin
+ match find f with
+ | REAL , ulp2 when ulp2 = ulp -> b
+ | _ -> qmake ulp (exact e )
+ end
| _ -> qmake ulp (exact e)
let compute_float op ulp xs =
@@ -280,10 +280,10 @@ let compute_float op ulp xs =
| SUB , [ x ; y ] -> qmake ulp (Q.sub (exact x) (exact y))
| MUL , [ x ; y ] -> qmake ulp (Q.mul (exact x) (exact y))
| DIV , [ x ; y ] ->
- let res = match Q.div (exact x) (exact y) with
- | x when Q.classify x = Q.NZERO -> x
- | _ -> raise Not_found (* let Why3 take care of the division*)
- in qmake ulp res
+ let res = match Q.div (exact x) (exact y) with
+ | x when Q.classify x = Q.NZERO -> x
+ | _ -> raise Not_found (* let Why3 take care of the division*)
+ in qmake ulp res
| ROUND , [ x ] -> round ulp x
| REAL , [ x ] -> F.e_real (exact x)
| LE , [ x ; y ] -> F.e_bool (Q.leq (exact x) (exact y))
@@ -332,12 +332,12 @@ module Compute = WpContext.StaticGenerator
let name = op_name op in
let phi = match op with
| LT | EQ | LE | NE ->
- let prop = Pretty_utils.sfprintf "%s_%a" name pp_suffix ft in
- let bool = Pretty_utils.sfprintf "%s_%ab" name pp_suffix ft in
- extern_p ~library ~bool ~prop ()
+ let prop = Pretty_utils.sfprintf "%s_%a" name pp_suffix ft in
+ let bool = Pretty_utils.sfprintf "%s_%ab" name pp_suffix ft in
+ extern_p ~library ~bool ~prop ()
| _ ->
- let result = return_type ft op in
- extern_f ~library ~result "%s_%a" name pp_suffix ft
+ let result = return_type ft op in
+ extern_f ~library ~result "%s_%a" name pp_suffix ft
in
Lang.F.set_builtin phi impl ;
REGISTRY.define phi (op, ft) ;
diff --git a/src/plugins/wp/Cint.ml b/src/plugins/wp/Cint.ml
index 9555265eae50bf1a33b871e9a9d92e8ac88f2232..9e08041e9d93502d540b5630a880d5a5c28b8ac2 100644
--- a/src/plugins/wp/Cint.ml
+++ b/src/plugins/wp/Cint.ml
@@ -156,8 +156,7 @@ let rec is_positive_or_null e = match F.repr e with
| _ -> (* try some improvement first then ask to qed *)
let improved_is_positive_or_null e = match F.repr e with
| Logic.Add es -> List.for_all is_positive_or_null es
- | Logic.Mul es ->
- (match mul_xor_sign es with | Some b -> b | _ -> false)
+ | Logic.Mul es -> (match mul_xor_sign es with | Some b -> b | _ -> false)
| Logic.Mod(e1,e2) when is_positive e2 || is_negative e2 ->
(* e2<>0 ==> ( 0<=(e1 % e2) <=> 0<=e1 ) *)
is_positive_or_null e1
@@ -1197,7 +1196,7 @@ let is_cint_simplifier =
reduce Abstract_interp.Comp.Ge var_domain b
| Lt(a,b) when Lang.F.equal a var && is_int b ->
reduce Abstract_interp.Comp.Lt var_domain b
- | Lt(b,a) when Lang.F.equal a var && is_int b->
+ | Lt(b,a) when Lang.F.equal a var && is_int b ->
reduce Abstract_interp.Comp.Gt var_domain b
| And l -> List.iter (reduce_on_neg var var_domain) l
| Not p -> reduce_on_pos var var_domain p
diff --git a/src/plugins/wp/Cleaning.ml b/src/plugins/wp/Cleaning.ml
index 8307a1c8861648878ca793c587c617f00377e31e..755cf8cb31f17d3409928ee20bd36f47d2dc4427 100644
--- a/src/plugins/wp/Cleaning.ml
+++ b/src/plugins/wp/Cleaning.ml
@@ -66,29 +66,29 @@ let rec add_pred m p =
| And ps -> List.fold_left add_pred m ps
| If(e,a,b) -> add_pred (add_pred (set_top m e) a) b
| Eq(a,b) ->
- begin
- match F.p_expr a , F.p_expr b with
- | Fvar x , Fvar y -> add_var x y (add_var y x m)
- | _ -> set_top m p
- end
+ begin
+ match F.p_expr a , F.p_expr b with
+ | Fvar x , Fvar y -> add_var x y (add_var y x m)
+ | _ -> set_top m p
+ end
| Fvar x -> add_true m x
| Not p ->
- begin
- match F.p_expr p with
- | Fvar x -> add_false m x
- | _ -> set_top m p
- end
+ begin
+ match F.p_expr p with
+ | Fvar x -> add_false m x
+ | _ -> set_top m p
+ end
| _ -> set_top m p
let rec add_type m p =
match F.p_expr p with
| And ps -> List.fold_left add_type m ps
| Fun(f,[e]) ->
- begin
- match F.e_expr e with
- | Fvar x -> add_fun x f m
- | _ -> set_top m p
- end
+ begin
+ match F.e_expr e with
+ | Fvar x -> add_fun x f m
+ | _ -> set_top m p
+ end
| _ -> set_top m p
(* -------------------------------------------------------------------------- *)
@@ -123,12 +123,12 @@ let is_false x m =
let is_var x m =
try match Vmap.find x m.eq_var with
| EQ y ->
- begin
- match get x m.eq_fun , get y m.eq_fun with
- | None , _ -> true (* we eliminate x, which has no guard... *)
- | Some (EQ f) , Some (EQ g) -> Fun.equal f g
- | _ -> false
- end
+ begin
+ match get x m.eq_fun , get y m.eq_fun with
+ | None , _ -> true (* we eliminate x, which has no guard... *)
+ | Some (EQ f) , Some (EQ g) -> Fun.equal f g
+ | _ -> false
+ end
| _ -> false
with Not_found -> false
@@ -141,27 +141,27 @@ let rec filter_pred m p =
| And ps -> F.p_all (filter_pred m) ps
| If(e,a,b) -> p_if e (filter_pred m a) (filter_pred m b)
| Eq(a,b) ->
- begin
- match F.p_expr a , F.p_expr b with
- | Fvar x , Fvar y when is_var x m || is_var y m -> p_true
- | _ -> p
- end
+ begin
+ match F.p_expr a , F.p_expr b with
+ | Fvar x , Fvar y when is_var x m || is_var y m -> p_true
+ | _ -> p
+ end
| Fvar x when is_true x m.eq_var -> p_true
| Not q ->
- begin
- match F.p_expr q with
- | Fvar x when is_false x m.eq_var -> p_true
- | _ -> p
- end
+ begin
+ match F.p_expr q with
+ | Fvar x when is_false x m.eq_var -> p_true
+ | _ -> p
+ end
| _ -> p
let rec filter_type m p =
match F.p_expr p with
| And ps -> F.p_all (filter_type m) ps
| Fun(_,[e]) ->
- begin
- match F.p_expr e with
- | Fvar x when is_var x m -> p_true
- | _ -> p
- end
+ begin
+ match F.p_expr e with
+ | Fvar x when is_var x m -> p_true
+ | _ -> p
+ end
| _ -> p
diff --git a/src/plugins/wp/Cmath.ml b/src/plugins/wp/Cmath.ml
index d286e62658799691ff7b7ecdb7613a051807a7d6..4a96a3af79c99dad19cb71ee95ea66f6f2fd5705 100644
--- a/src/plugins/wp/Cmath.ml
+++ b/src/plugins/wp/Cmath.ml
@@ -68,18 +68,18 @@ let builtin_truncate f e =
| Kint _ -> e
| Kreal r when Q.(equal r zero) -> e_zero
| Kreal r ->
- begin
- try
- (* Waiting for Z-Arith to have truncation to big-int *)
- let truncated = int_of_float (Q.to_float r) in
- let reversed = Q.of_int truncated in
- let base = F.e_int truncated in
- if Q.equal r reversed then base else
- if f == f_ceil && Q.(lt zero r) then F.(e_add base e_one) else
- if f == f_floor && Q.(lt r zero) then F.(e_sub base e_one) else
- base
- with _ -> raise Not_found
- end
+ begin
+ try
+ (* Waiting for Z-Arith to have truncation to big-int *)
+ let truncated = int_of_float (Q.to_float r) in
+ let reversed = Q.of_int truncated in
+ let base = F.e_int truncated in
+ if Q.equal r reversed then base else
+ if f == f_ceil && Q.(lt zero r) then F.(e_add base e_one) else
+ if f == f_floor && Q.(lt r zero) then F.(e_sub base e_one) else
+ base
+ with _ -> raise Not_found
+ end
| Fun( f , [e] ) when f == f_real_of_int -> e
| _ -> raise Not_found
@@ -104,17 +104,17 @@ let builtin_positive_eq lfun ~domain ~zero ~injective a b =
begin match F.repr a , F.repr b with
| Fun(f,[a]) , Fun(f',[b])
when injective && f == lfun && f' == lfun && domain a && domain b ->
- (* injective a in domain && b in domain -> ( f(a) = f(b) <-> a = b ) *)
- e_eq a b
+ (* injective a in domain && b in domain -> ( f(a) = f(b) <-> a = b ) *)
+ e_eq a b
| Fun(f,[a]) , _ when f == lfun && domain a ->
- if QED.eval_lt b zero then
- (* a in domain && b < 0 -> ( f(a) = b <-> false ) *)
- e_false
- else
- if QED.eval_eq zero b then
- (* a in domain && b = 0 -> ( f(a) = 0 <-> a = 0 ) *)
- e_eq a zero
- else raise Not_found
+ if QED.eval_lt b zero then
+ (* a in domain && b < 0 -> ( f(a) = b <-> false ) *)
+ e_false
+ else
+ if QED.eval_eq zero b then
+ (* a in domain && b = 0 -> ( f(a) = 0 <-> a = 0 ) *)
+ e_eq a zero
+ else raise Not_found
| _ -> raise Not_found
end
@@ -125,20 +125,20 @@ let builtin_positive_leq lfun ~domain ~zero ~monotonic a b =
begin match F.repr a , F.repr b with
| Fun(f,[a]) , Fun(f',[b])
when monotonic && f == lfun && f' == lfun && domain a && domain b ->
- (* increasing && a in domain && b in domain -> ( f(a) <= f(b) <-> a <= b) *)
- e_leq a b
+ (* increasing && a in domain && b in domain -> ( f(a) <= f(b) <-> a <= b) *)
+ e_leq a b
| Fun(f,[a]) , _ when f == lfun && domain a ->
- if QED.eval_lt b zero then
- (* a in domain && b < 0 -> ( f(a) <= b <-> false ) *)
- e_false
- else
- if QED.eval_eq zero b then
- (* a in domain && b = 0 -> ( f(a) <= b <-> a = 0 )*)
- e_eq a zero
- else raise Not_found
+ if QED.eval_lt b zero then
+ (* a in domain && b < 0 -> ( f(a) <= b <-> false ) *)
+ e_false
+ else
+ if QED.eval_eq zero b then
+ (* a in domain && b = 0 -> ( f(a) <= b <-> a = 0 )*)
+ e_eq a zero
+ else raise Not_found
| _ , Fun(f,[b]) when f == lfun && domain b && QED.eval_leq a zero ->
- (* b in domain && a <= 0 -> ( a <= f(b) <-> true *)
- e_true
+ (* b in domain && a <= 0 -> ( a <= f(b) <-> true *)
+ e_true
| _ -> raise Not_found
end
@@ -149,11 +149,11 @@ let builtin_strict_eq lfun ~domain ~zero ~injective a b =
begin match F.repr a , F.repr b with
| Fun(f,[a]) , Fun(f',[b])
when injective && f == lfun && f' == lfun && domain a && domain b ->
- (* injective && a in domain && b in domain -> ( f(a) = f(b) <-> a = b ) *)
- e_eq a b
+ (* injective && a in domain && b in domain -> ( f(a) = f(b) <-> a = b ) *)
+ e_eq a b
| Fun(f,[a]) , _ when f == lfun && domain a && QED.eval_leq b zero ->
- (* a in domain && b <= 0 -> ( f(a) = b <-> false ) *)
- e_false
+ (* a in domain && b <= 0 -> ( f(a) = b <-> false ) *)
+ e_false
| _ -> raise Not_found
end
@@ -164,14 +164,14 @@ let builtin_strict_leq lfun ~domain ~zero ~monotonic a b =
begin match F.repr a , F.repr b with
| Fun(f,[a]) , Fun(f',[b])
when monotonic && f == lfun && f' == lfun && domain a && domain b ->
- (* increasing && a in domain && b in domain -> ( f(a) <= f(b) <-> a <= b ) *)
- e_leq a b
+ (* increasing && a in domain && b in domain -> ( f(a) <= f(b) <-> a <= b ) *)
+ e_leq a b
| Fun(f,[a]) , _ when f == lfun && domain a && QED.eval_leq b zero ->
- (* a in domain && b <= 0 -> ( f(a) <= b <-> false ) *)
- e_false
+ (* a in domain && b <= 0 -> ( f(a) <= b <-> false ) *)
+ e_false
| _ , Fun(f,[b]) when f == lfun && domain b && QED.eval_leq a zero ->
- (* b in domain && a <= 0 -> ( a <= f(b) <-> true ) *)
- e_true
+ (* b in domain && a <= 0 -> ( a <= f(b) <-> true ) *)
+ e_true
| _ -> raise Not_found
end
@@ -202,10 +202,10 @@ let builtin_abs f z e =
| Kint k -> e_zint (Integer.abs k)
| Kreal r when Q.lt r Q.zero -> e_real (Q.neg r)
| _ ->
- match is_true (e_leq z e) with
- | Yes -> e
- | No -> e_opp e
- | Maybe -> raise Not_found
+ match is_true (e_leq z e) with
+ | Yes -> e
+ | No -> e_opp e
+ | Maybe -> raise Not_found
let builtin_iabs_eq = builtin_positive_eq f_iabs
~domain:domain_abs ~zero:e_zero ~injective:false
@@ -233,7 +233,7 @@ let builtin_sqrt e =
| Kreal r when r == Q.zero -> F.e_zero_real (* srqt(0)==0 *)
| Kreal r when r == Q.one -> F.e_one_real (* srqt(1)==1 *)
| Mul[a;b] when eval_eq a b -> (* a==b ==> sqrt(a*b)==|a| *)
- e_fun f_rabs [a] (* a is smaller *)
+ e_fun f_rabs [a] (* a is smaller *)
| _ -> raise Not_found
let builtin_sqrt_eq = builtin_positive_eq f_sqrt
@@ -261,9 +261,9 @@ let builtin_exp e =
match F.repr e with
| Kreal r when r == Q.zero -> F.e_one_real (* exp(0)==1 *)
| Times(n,r) when n == Z.minus_one -> (* exp(-r) = 1/exp(r) *)
- F.e_div F.e_one_real (F.e_fun f_exp [r])
+ F.e_div F.e_one_real (F.e_fun f_exp [r])
| Fun( f , [x] ) when f == f_log && domain_log x ->
- (* 0<x ==> exp(log(x)) = x *) x
+ (* 0<x ==> exp(log(x)) = x *) x
| _ -> raise Not_found
let builtin_log e =
@@ -272,8 +272,8 @@ let builtin_log e =
| Kreal r when r == Q.one -> F.e_zero_real (* log(1) == 0 *)
| Fun( f , [x] ) when f == f_exp -> x (* log(exp(x)) == x *)
| Fun( f , [x;n] ) when f == f_pow && domain_log x ->
- (* 0<x ==> log(x^n) == n*log(x) *)
- F.e_mul n (F.e_fun f_log [x])
+ (* 0<x ==> log(x^n) == n*log(x) *)
+ F.e_mul n (F.e_fun f_log [x])
| _ -> raise Not_found
(* a^n = e^(n.log a) *)
diff --git a/src/plugins/wp/CodeSemantics.ml b/src/plugins/wp/CodeSemantics.ml
index d058aa8f72c4dd97e2b4588f2befe35b916baa3e..11b8844e512993c0c0d1b67b1a758218b2fe6378 100644
--- a/src/plugins/wp/CodeSemantics.ml
+++ b/src/plugins/wp/CodeSemantics.ml
@@ -38,7 +38,7 @@ let constfold_ctyp = function
| TArray (ty,Some len,attr) as ct -> begin
match Cil.constFold true len with
| {enode = (Const CInt64 _) } as len ->
- TArray(ty,Some len,attr)
+ TArray(ty,Some len,attr)
| _ -> ct
end
| ct -> ct
@@ -94,23 +94,23 @@ struct
| C_float _ -> is_zero_float (M.load sigma obj l)
| C_pointer _ -> is_zero_ptr (M.load sigma obj l)
| C_comp { cfields = None } ->
- p_true (* cannot say anything interesting here *)
+ p_true (* cannot say anything interesting here *)
| C_comp { cfields = Some fields } ->
- p_all
- (fun f -> is_zero sigma (Ctypes.object_of f.ftype) (M.field l f))
- fields
+ p_all
+ (fun f -> is_zero sigma (Ctypes.object_of f.ftype) (M.field l f))
+ fields
| C_array a ->
- (*TODO[LC] make zero-initializers model-dependent.
- For instance, a[N][M] becomes a[N*M] in MemTyped,
- but not in MemVar *)
- let x = Lang.freshvar ~basename:"k" Logic.Int in
- let k = e_var x in
- let obj = Ctypes.object_of a.arr_element in
- let range = match a.arr_flat with
- | None -> []
- | Some f -> [ p_leq e_zero k ; p_lt k (e_int f.arr_size) ] in
- let init = is_zero sigma obj (M.shift l obj k) in
- p_forall [x] (p_hyps range init)
+ (*TODO[LC] make zero-initializers model-dependent.
+ For instance, a[N][M] becomes a[N*M] in MemTyped,
+ but not in MemVar *)
+ let x = Lang.freshvar ~basename:"k" Logic.Int in
+ let k = e_var x in
+ let obj = Ctypes.object_of a.arr_element in
+ let range = match a.arr_flat with
+ | None -> []
+ | Some f -> [ p_leq e_zero k ; p_lt k (e_int f.arr_size) ] in
+ let init = is_zero sigma obj (M.shift l obj k) in
+ p_forall [x] (p_hyps range init)
let is_exp_range sigma l obj a b v =
let x = Lang.freshvar ~basename:"k" Logic.Int in
@@ -120,11 +120,11 @@ struct
match v with
| None -> is_zero sigma obj (M.shift l obj k)
| Some v ->
- let elt = (M.load sigma obj (M.shift l obj k)) in
- if Ctypes.is_pointer obj then
- M.loc_eq (cloc elt) (cloc v)
- else
- p_equal (cval elt) (cval v)
+ let elt = (M.load sigma obj (M.shift l obj k)) in
+ if Ctypes.is_pointer obj then
+ M.loc_eq (cloc elt) (cloc v)
+ else
+ p_equal (cval elt) (cval v)
in
p_forall [x] (p_hyps range init)
@@ -150,10 +150,10 @@ struct
| NoOffset -> l
| Field(f,offset) -> loc_of_offset env (M.field l f) f.ftype offset
| Index(e,offset) ->
- let k = val_of_exp env e in
- let te = Cil.typeOf_array_elem typ in
- let obj = Ctypes.object_of te in
- loc_of_offset env (M.shift l obj k) te offset
+ let k = val_of_exp env e in
+ let te = Cil.typeOf_array_elem typ in
+ let obj = Ctypes.object_of te in
+ loc_of_offset env (M.shift l obj k) te offset
let lval env (lhost,offset) =
loc_of_offset env (loc_of_lhost env lhost) (Cil.typeOfLhost lhost) offset
@@ -172,7 +172,7 @@ struct
| C_float _ , LNot -> Cvalues.bool_eq (val_of_exp env e) e_zero_real
| C_pointer _ , LNot -> Cvalues.is_true (M.is_null (loc_of_exp env e))
| _ ->
- Warning.error "Undefined unary operator (%a)" Printer.pp_typ typ
+ Warning.error "Undefined unary operator (%a)" Printer.pp_typ typ
in Val v
(* -------------------------------------------------------------------------- *)
@@ -197,11 +197,11 @@ struct
Cvalues.is_true (lop (loc_of_exp env e1) (loc_of_exp env e2))
else match Cil.unrollType t1 with
| TFloat(f,_) ->
- let p = fop (Ctypes.c_float f)
- (val_of_exp env e1) (val_of_exp env e2) in
- e_if (F.e_prop p) e_one e_zero
+ let p = fop (Ctypes.c_float f)
+ (val_of_exp env e1) (val_of_exp env e2) in
+ e_if (F.e_prop p) e_one e_zero
| _ ->
- iop (val_of_exp env e1) (val_of_exp env e2)
+ iop (val_of_exp env e1) (val_of_exp env e2)
let bool_of_exp env e =
match Ctypes.object_of (Cil.typeOf e) with
@@ -230,17 +230,17 @@ struct
| LAnd -> Val (Cvalues.bool_and (bool_of_exp env e1) (bool_of_exp env e2))
| LOr -> Val (Cvalues.bool_or (bool_of_exp env e1) (bool_of_exp env e2))
| PlusPI ->
- let te = Cil.typeOf_pointed (Cil.typeOf e1) in
- let obj = Ctypes.object_of te in
- Loc(M.shift (loc_of_exp env e1) obj (val_of_exp env e2))
+ let te = Cil.typeOf_pointed (Cil.typeOf e1) in
+ let obj = Ctypes.object_of te in
+ Loc(M.shift (loc_of_exp env e1) obj (val_of_exp env e2))
| MinusPI ->
- let te = Cil.typeOf_pointed (Cil.typeOf e1) in
- let obj = Ctypes.object_of te in
- Loc(M.shift (loc_of_exp env e1) obj (e_opp (val_of_exp env e2)))
+ let te = Cil.typeOf_pointed (Cil.typeOf e1) in
+ let obj = Ctypes.object_of te in
+ Loc(M.shift (loc_of_exp env e1) obj (e_opp (val_of_exp env e2)))
| MinusPP ->
- let te = Cil.typeOf_pointed (Cil.typeOf e1) in
- let obj = Ctypes.object_of te in
- Val(M.loc_diff obj (loc_of_exp env e1) (loc_of_exp env e2))
+ let te = Cil.typeOf_pointed (Cil.typeOf e1) in
+ let obj = Ctypes.object_of te in
+ Val(M.loc_diff obj (loc_of_exp env e1) (loc_of_exp env e2))
(* -------------------------------------------------------------------------- *)
(* --- Cast --- *)
@@ -250,40 +250,40 @@ struct
match Ctypes.object_of tr , Ctypes.object_of te with
| C_int ir , C_int ie ->
- let v = cval ve in
- Val( if Ctypes.sub_c_int ie ir then v else Cint.downcast ir v )
+ let v = cval ve in
+ Val( if Ctypes.sub_c_int ie ir then v else Cint.downcast ir v )
| C_float fr , C_float fe ->
- let v = cval ve in
- Val( if Ctypes.equal_float fe fr then v else
- Cfloat.float_of_real fr (Cfloat.real_of_float fe v) )
+ let v = cval ve in
+ Val( if Ctypes.equal_float fe fr then v else
+ Cfloat.float_of_real fr (Cfloat.real_of_float fe v) )
| C_int ir , C_float fr ->
- Val(Cint.of_real ir (Cfloat.real_of_float fr (cval ve)))
+ Val(Cint.of_real ir (Cfloat.real_of_float fr (cval ve)))
| C_float fr , C_int _ ->
- Val(Cfloat.float_of_real fr (Cmath.real_of_int (cval ve)))
+ Val(Cfloat.float_of_real fr (Cmath.real_of_int (cval ve)))
| C_pointer tr , C_pointer te ->
- let obj_r = Ctypes.object_of tr in
- let obj_e = Ctypes.object_of te in
- if Ctypes.compare obj_r obj_e = 0
- then ve
- else Loc (M.cast {pre=obj_e;post=obj_r} (cloc ve))
+ let obj_r = Ctypes.object_of tr in
+ let obj_e = Ctypes.object_of te in
+ if Ctypes.compare obj_r obj_e = 0
+ then ve
+ else Loc (M.cast {pre=obj_e;post=obj_r} (cloc ve))
| C_pointer te , C_int _ ->
- let e = cval ve in
- Loc(if F.equal e (F.e_zero) then M.null
- else M.loc_of_int (Ctypes.object_of te) e)
+ let e = cval ve in
+ Loc(if F.equal e (F.e_zero) then M.null
+ else M.loc_of_int (Ctypes.object_of te) e)
| C_int ir , C_pointer _ ->
- Val (M.int_of_loc ir (cloc ve))
+ Val (M.int_of_loc ir (cloc ve))
| t1, t2 when Ctypes.equal t1 t2 -> ve
| _ ->
- Warning.error "cast (%a) into (%a) not yet implemented"
- Printer.pp_typ te Printer.pp_typ tr
+ Warning.error "cast (%a) into (%a) not yet implemented"
+ Printer.pp_typ te Printer.pp_typ tr
(* -------------------------------------------------------------------------- *)
(* --- Undefined Exp --- *)
@@ -306,22 +306,22 @@ struct
| Const c -> Val (Cvalues.constant c)
| Lval lv ->
- if Cil.isVolatileLval lv &&
- Cvalues.volatile ~warn:"unsafe read-access to volatile l-value" ()
- then exp_undefined e
- else
- let loc = lval env lv in
- let typ = Cil.typeOfLval lv in
- let obj = Ctypes.object_of typ in
- let data = M.load env obj loc in
- Lang.assume (Cvalues.is_object obj data) ;
- data
+ if Cil.isVolatileLval lv &&
+ Cvalues.volatile ~warn:"unsafe read-access to volatile l-value" ()
+ then exp_undefined e
+ else
+ let loc = lval env lv in
+ let typ = Cil.typeOfLval lv in
+ let obj = Ctypes.object_of typ in
+ let data = M.load env obj loc in
+ Lang.assume (Cvalues.is_object obj data) ;
+ data
| AddrOf lv ->
- Loc (lval env lv)
+ Loc (lval env lv)
| StartOf lv ->
- Loc (Cvalues.startof ~shift:M.shift (lval env lv) (Cil.typeOfLval lv))
+ Loc (Cvalues.startof ~shift:M.shift (lval env lv) (Cil.typeOfLval lv))
| UnOp(op,e,ty) -> exp_unop env ty op e
| BinOp(op,e1,e2,tr) -> exp_binop env tr op e1 e2
@@ -357,18 +357,18 @@ struct
| Loc p , Loc q -> M.loc_eq p q
| Val a , Val b -> p_equal a b
| _ ->
- if is_ptr t
- then M.loc_eq (cloc v1) (cloc v2)
- else p_equal (cval v1) (cval v2)
+ if is_ptr t
+ then M.loc_eq (cloc v1) (cloc v2)
+ else p_equal (cval v1) (cval v2)
let neq_t is_ptr t v1 v2 =
match v1 , v2 with
| Loc p , Loc q -> M.loc_neq p q
| Val a , Val b -> p_neq a b
| _ ->
- if is_ptr t
- then M.loc_neq (cloc v1) (cloc v2)
- else p_neq (cval v1) (cval v2)
+ if is_ptr t
+ then M.loc_neq (cloc v1) (cloc v2)
+ else p_neq (cval v1) (cval v2)
let equal_typ t v1 v2 = eq_t Cil.isPointerType t v1 v2
let equal_obj obj v1 v2 = eq_t Ctypes.is_pointer obj v1 v2
@@ -400,13 +400,13 @@ struct
| BinOp( Ge, e1,e2,_) -> compare env p_leq M.loc_leq Cfloat.fle e2 e1
| _ ->
- begin
- match Ctypes.object_of (Cil.typeOf e) with
- | C_int _ -> p_neq (val_of_exp env e) e_zero
- | C_float _ -> p_neq (val_of_exp env e) e_zero_real
- | C_pointer _ -> p_not (M.is_null (loc_of_exp env e))
- | obj -> Warning.error "Condition from (%a)" Ctypes.pretty obj
- end
+ begin
+ match Ctypes.object_of (Cil.typeOf e) with
+ | C_int _ -> p_neq (val_of_exp env e) e_zero
+ | C_float _ -> p_neq (val_of_exp env e) e_zero_real
+ | C_pointer _ -> p_not (M.is_null (loc_of_exp env e))
+ | obj -> Warning.error "Condition from (%a)" Ctypes.pretty obj
+ end
(* -------------------------------------------------------------------------- *)
(* --- BootStrapping --- *)
@@ -445,19 +445,19 @@ struct
let l = lval sigma lv in
let value_hyp = match init with
| Some e ->
- let v = M.load sigma obj l in
- p_equal (val_of_exp sigma e) (cval v)
+ let v = M.load sigma obj l in
+ p_equal (val_of_exp sigma e) (cval v)
| None -> is_zero sigma obj l
in
let init_hyp = match init with
| Some { enode = Lval lv_init }
when Cil.(isStructOrUnionType @@ typeOfLval lv_init) ->
- let l_initializer = lval sigma lv_init in
- p_equal
- (M.load_init sigma obj l)
- (M.load_init sigma obj l_initializer)
+ let l_initializer = lval sigma lv_init in
+ p_equal
+ (M.load_init sigma obj l)
+ (M.load_init sigma obj l_initializer)
| _ ->
- M.initialized sigma (Rloc(obj, l))
+ M.initialized sigma (Rloc(obj, l))
in
value_hyp, init_hyp
) () in
@@ -488,117 +488,117 @@ struct
match init with
| SingleInit exp ->
- init_value ~sigma lv (Cil.typeOfLval lv) (Some exp) :: acc
+ init_value ~sigma lv (Cil.typeOfLval lv) (Some exp) :: acc
| CompoundInit ( ct , initl ) ->
- let ct = constfold_ctyp ct in
- let acc = (* updated acc with default init of structure *)
- match ct with
- | TComp ( { cfields = None },_) ->
- Wp_parameters.fatal
- "Initializer for incomplete type %a" Cil_printer.pp_typ ct
- | TComp ( { cstruct ; cfields = Some fields },_)
- when cstruct && (* not for union... *)
- (List.length initl) < (List.length fields) ->
- (* default init for unintialized field of a struct *)
- List.fold_left
- (fun acc f ->
- if List.exists
- (function
- | Field(g,_),_ -> Fieldinfo.equal f g
- | _ -> WpLog.fatal "Kernel invariant broken into an initializer")
- initl
- then acc
- else
- let init =
- init_value ~sigma
- (Cil.addOffsetLval (Field(f, NoOffset)) lv)
- f.ftype None in
- init :: acc)
- acc (List.rev fields)
-
- | _ -> acc
- in
+ let ct = constfold_ctyp ct in
+ let acc = (* updated acc with default init of structure *)
match ct with
- | TArray (ty,len,_) ->
- let delayed =
- match len with (* number of required elements *)
- | Some {enode = (Const CInt64 (size,_,_))} ->
- (size, None)
- | _ -> (* CIL invariant broken. *)
- WpLog.fatal "CIL invariant broken: unknown initialized array size"
- in
- let make_quant acc = function
- (* adds delayed initializations from info about
- the last consecutive indices having
- the same value, but that have not yet initialized. *)
- | (_,None) -> acc (* nothing was delayed *)
- | (il,Some (i0,_,exp)) when Integer.lt il i0 ->
- (* Added pred: \forall i \in [il .. i0] ; t[i]==exp *)
- init_range ~sigma lv ty il i0 (Some exp) :: acc
- | (_il,Some (_i0,off,exp)) ->
- (* case [_il=_i0], so uses [off] corresponding to [_i0]
- Added pred: t[i]==exp*)
- let lv = Cil.addOffsetLval off lv in
- init_value ~sigma lv ty (Some exp) :: acc
- in
- let add_missing_indices acc i0 = function
- (* adds eventual default value for missing indices. *)
- | (i1, _) ->
- if Integer.ge i0 i1 then (* no hole *) acc
- else (* defaults values
- Added pred: \forall i \in [i0 .. i1[ ; t[i]==default *)
- init_range ~sigma lv ty i0 (Integer.pred i1) None :: acc
- in
- let acc, delayed =
- List.fold_left
- (fun (acc,delayed) (off,init) ->
- let off = constfold_coffset off in
- let idx,acc = match off with
- | Index({enode=Const CInt64 (idx,_,_)}, _) ->
- (match delayed with
- | (iprev, _) when Integer.lt iprev idx ->
- (* CIL invariant broken.
- without that invariant, an algo with a 2sd pass
- is required for introducing default values *)
- WpLog.fatal "CIL invariant broken: unordered initializer";
- | _ -> ()) ;
- idx,
- (* adds default values for missing indices *)
- add_missing_indices acc (Integer.succ idx) delayed
- | _ -> (* CIL invariant broken. *)
- WpLog.fatal "CIL invariant broken: unknown initialized index"
- in
- match off, init with (* only simple init can be delayed *)
- | Index(_, NoOffset), SingleInit init -> begin
- match delayed with
- | (i_prev,(Some (_,_,init_delayed) as delayed_info))
- when Wp_parameters.InitWithForall.get ()
- && Integer.equal (Integer.pred i_prev) idx
- && ExpStructEq.equal init_delayed init ->
- acc, (idx,delayed_info)
- | _ -> (* flush the delayed init, and store the new one *)
- let acc = make_quant acc delayed in
- acc, (idx, Some (idx,off,init))
- end
- | Index(_, _),_ ->
- (* flush the delayed init, and adds the current one *)
- let acc = make_quant acc delayed in
- let lv = Cil.addOffsetLval off lv in
- (init_variable ~sigma lv init acc), (idx, None)
- | _ -> WpLog.fatal "CIL invariant broken: not an index"
- )
- (acc,delayed)
- (List.rev initl)
- in
- let acc = make_quant acc delayed in
- add_missing_indices acc Integer.zero delayed
- | _ ->
- List.fold_left
- (fun acc (off,init) ->
+ | TComp ( { cfields = None },_) ->
+ Wp_parameters.fatal
+ "Initializer for incomplete type %a" Cil_printer.pp_typ ct
+ | TComp ( { cstruct ; cfields = Some fields },_)
+ when cstruct && (* not for union... *)
+ (List.length initl) < (List.length fields) ->
+ (* default init for unintialized field of a struct *)
+ List.fold_left
+ (fun acc f ->
+ if List.exists
+ (function
+ | Field(g,_),_ -> Fieldinfo.equal f g
+ | _ -> WpLog.fatal "Kernel invariant broken into an initializer")
+ initl
+ then acc
+ else
+ let init =
+ init_value ~sigma
+ (Cil.addOffsetLval (Field(f, NoOffset)) lv)
+ f.ftype None in
+ init :: acc)
+ acc (List.rev fields)
+
+ | _ -> acc
+ in
+ match ct with
+ | TArray (ty,len,_) ->
+ let delayed =
+ match len with (* number of required elements *)
+ | Some {enode = (Const CInt64 (size,_,_))} ->
+ (size, None)
+ | _ -> (* CIL invariant broken. *)
+ WpLog.fatal "CIL invariant broken: unknown initialized array size"
+ in
+ let make_quant acc = function
+ (* adds delayed initializations from info about
+ the last consecutive indices having
+ the same value, but that have not yet initialized. *)
+ | (_,None) -> acc (* nothing was delayed *)
+ | (il,Some (i0,_,exp)) when Integer.lt il i0 ->
+ (* Added pred: \forall i \in [il .. i0] ; t[i]==exp *)
+ init_range ~sigma lv ty il i0 (Some exp) :: acc
+ | (_il,Some (_i0,off,exp)) ->
+ (* case [_il=_i0], so uses [off] corresponding to [_i0]
+ Added pred: t[i]==exp*)
+ let lv = Cil.addOffsetLval off lv in
+ init_value ~sigma lv ty (Some exp) :: acc
+ in
+ let add_missing_indices acc i0 = function
+ (* adds eventual default value for missing indices. *)
+ | (i1, _) ->
+ if Integer.ge i0 i1 then (* no hole *) acc
+ else (* defaults values
+ Added pred: \forall i \in [i0 .. i1[ ; t[i]==default *)
+ init_range ~sigma lv ty i0 (Integer.pred i1) None :: acc
+ in
+ let acc, delayed =
+ List.fold_left
+ (fun (acc,delayed) (off,init) ->
+ let off = constfold_coffset off in
+ let idx,acc = match off with
+ | Index({enode=Const CInt64 (idx,_,_)}, _) ->
+ (match delayed with
+ | (iprev, _) when Integer.lt iprev idx ->
+ (* CIL invariant broken.
+ without that invariant, an algo with a 2sd pass
+ is required for introducing default values *)
+ WpLog.fatal "CIL invariant broken: unordered initializer";
+ | _ -> ()) ;
+ idx,
+ (* adds default values for missing indices *)
+ add_missing_indices acc (Integer.succ idx) delayed
+ | _ -> (* CIL invariant broken. *)
+ WpLog.fatal "CIL invariant broken: unknown initialized index"
+ in
+ match off, init with (* only simple init can be delayed *)
+ | Index(_, NoOffset), SingleInit init -> begin
+ match delayed with
+ | (i_prev,(Some (_,_,init_delayed) as delayed_info))
+ when Wp_parameters.InitWithForall.get ()
+ && Integer.equal (Integer.pred i_prev) idx
+ && ExpStructEq.equal init_delayed init ->
+ acc, (idx,delayed_info)
+ | _ -> (* flush the delayed init, and store the new one *)
+ let acc = make_quant acc delayed in
+ acc, (idx, Some (idx,off,init))
+ end
+ | Index(_, _),_ ->
+ (* flush the delayed init, and adds the current one *)
+ let acc = make_quant acc delayed in
let lv = Cil.addOffsetLval off lv in
- init_variable ~sigma lv init acc)
- acc (List.rev initl)
+ (init_variable ~sigma lv init acc), (idx, None)
+ | _ -> WpLog.fatal "CIL invariant broken: not an index"
+ )
+ (acc,delayed)
+ (List.rev initl)
+ in
+ let acc = make_quant acc delayed in
+ add_missing_indices acc Integer.zero delayed
+ | _ ->
+ List.fold_left
+ (fun acc (off,init) ->
+ let lv = Cil.addOffsetLval off lv in
+ init_variable ~sigma lv init acc)
+ acc (List.rev initl)
let init ~sigma v = function
| None -> [init_value ~sigma (Cil.var v) v.vtype None]
diff --git a/src/plugins/wp/Conditions.ml b/src/plugins/wp/Conditions.ml
index a8bc20956ca3a1d9699280836c97f0cbe9672085..1ef79432ab2786b3bb365ea1f85347447b00c856 100644
--- a/src/plugins/wp/Conditions.ml
+++ b/src/plugins/wp/Conditions.ml
@@ -133,7 +133,7 @@ let core_cond = function
| Branch(_,sa,sb) -> Pset.inter sa.seq_core sb.seq_core
| Either [] -> Pset.empty
| Either (c::cs) ->
- List.fold_left (fun w s -> Pset.inter w s.seq_core) c.seq_core cs
+ List.fold_left (fun w s -> Pset.inter w s.seq_core) c.seq_core cs
let add_core_step ps s = Pset.union ps (core_cond s.condition)
@@ -147,12 +147,12 @@ let catg_seq s = s.seq_catg
let catg_cond = function
| State _ -> TRUE
| Have p | Type p | When p | Core p | Init p ->
- begin
- match F.is_ptrue p with
- | No -> FALSE
- | Maybe -> MAYBE
- | Yes -> EMPTY
- end
+ begin
+ match F.is_ptrue p with
+ | No -> FALSE
+ | Maybe -> MAYBE
+ | Yes -> EMPTY
+ end
| Either cs -> c_disj catg_seq cs
| Branch(_,a,b) -> c_or a.seq_catg b.seq_catg
let catg_step s = catg_cond s.condition
@@ -184,9 +184,9 @@ let rec equal_cond ca cb =
| Init p , Init q
-> p == q
| Branch(p,a,b) , Branch(q,a',b') ->
- p == q && equal_seq a a' && equal_seq b b'
+ p == q && equal_seq a a' && equal_seq b b'
| Either u, Either v ->
- Qed.Hcons.equal_list equal_seq u v
+ Qed.Hcons.equal_list equal_seq u v
| State _ , _ | _ , State _
| Type _ , _ | _ , Type _
| Have _ , _ | _ , Have _
@@ -416,8 +416,8 @@ let prenex_intro p =
| Imply(h,p) -> walk (h::hs) xs p
| Bind(Forall,_,_) -> bind hs xs p
| _ ->
- if hs = [] then raise Exit ;
- F.p_forall (List.rev xs) (F.p_hyps (List.concat hs) p)
+ if hs = [] then raise Exit ;
+ F.p_forall (List.rev xs) (F.p_hyps (List.concat hs) p)
(* invariant: result <-> forall hs xs (\tau.bind) *)
and bind hs xs p =
let pool = Lang.get_pool () in
@@ -443,17 +443,17 @@ let rec exist_intro p =
match F.p_expr p with
| And ps -> F.p_all exist_intro ps
| Bind(Exists,_,_) ->
- let pool = Lang.get_pool () in
- let _,t = e_open ~pool ~exists:true
- ~forall:false ~lambda:false (e_prop p) in
- exist_intro (F.p_bool t)
+ let pool = Lang.get_pool () in
+ let _,t = e_open ~pool ~exists:true
+ ~forall:false ~lambda:false (e_prop p) in
+ exist_intro (F.p_bool t)
| _ -> (* Note: Qed implement De Morgan rules
such that [p] cannot match the
decomposable representations:
Not Or, Not Imply, Not Forall *)
- if Wp_parameters.Prenex.get ()
- then prenex_intro p
- else p
+ if Wp_parameters.Prenex.get ()
+ then prenex_intro p
+ else p
let rec exist_intros = function
| [] -> []
@@ -462,15 +462,15 @@ let rec exist_intros = function
match F.p_expr p with
| And ps -> exist_intros (ps@hs)
| Bind(Exists,_,_) ->
- let pool = Lang.get_pool () in
- let _,t = F.QED.e_open ~pool ~exists:true
- ~forall:false ~lambda:false (e_prop p) in
- exist_intros ((F.p_bool t)::hs)
+ let pool = Lang.get_pool () in
+ let _,t = F.QED.e_open ~pool ~exists:true
+ ~forall:false ~lambda:false (e_prop p) in
+ exist_intros ((F.p_bool t)::hs)
| _ -> (* Note: Qed implement De Morgan rules
such that [p] cannot match the
decomposable representations:
Not Or, Not Imply, Not Forall *)
- p::(exist_intros hs)
+ p::(exist_intros hs)
end
(* -------------------------------------------------------------------------- *)
@@ -481,31 +481,31 @@ let rec forall_intro p =
let open Qed.Logic in
match F.p_expr p with
| Bind(Forall,_,_) ->
- let pool = Lang.get_pool () in
- let _,t = F.QED.e_open ~pool ~forall:true
- ~exists:false ~lambda:false (e_prop p) in
- forall_intro (F.p_bool t)
+ let pool = Lang.get_pool () in
+ let _,t = F.QED.e_open ~pool ~forall:true
+ ~exists:false ~lambda:false (e_prop p) in
+ forall_intro (F.p_bool t)
| Imply(hs,p) ->
- let hs = exist_intros hs in
- let hp,p = forall_intro p in
- hs @ hp , p
+ let hs = exist_intros hs in
+ let hp,p = forall_intro p in
+ hs @ hp , p
| Or qs -> (* analogy with Imply *)
- let hps,ps = List.fold_left (fun (hs,ps) q ->
- let hp,p = forall_intro q in (* q <==> (hp ==> p) *)
- (hp @ hs), (p::ps)) ([],[]) qs
- in (* ORs qs <==> ORs (hps ==> ps)
- <==> ((ANDs hps) ==> ORs ps) *)
- let hps,ps = List.fold_left (fun (hs,ps) q ->
- match F.repr (F.e_prop q) with
- | Neq _ -> ((F.p_not q)::hs), ps
- | _ -> hs, (q::ps)) (hps,[]) ps
- in (* ORs qs <==> ((ANDs hps) ==> ORs ps)) *)
- hps, (F.p_disj ps)
+ let hps,ps = List.fold_left (fun (hs,ps) q ->
+ let hp,p = forall_intro q in (* q <==> (hp ==> p) *)
+ (hp @ hs), (p::ps)) ([],[]) qs
+ in (* ORs qs <==> ORs (hps ==> ps)
+ <==> ((ANDs hps) ==> ORs ps) *)
+ let hps,ps = List.fold_left (fun (hs,ps) q ->
+ match F.repr (F.e_prop q) with
+ | Neq _ -> ((F.p_not q)::hs), ps
+ | _ -> hs, (q::ps)) (hps,[]) ps
+ in (* ORs qs <==> ((ANDs hps) ==> ORs ps)) *)
+ hps, (F.p_disj ps)
| _ -> (* Note: Qed implement De Morgan rules
such that [p] cannot match the
decomposable representations:
Not And, Not Exists *)
- [] , p
+ [] , p
(* -------------------------------------------------------------------------- *)
(* --- Constructors --- *)
@@ -536,20 +536,20 @@ let assume ?descr ?stmt ?deps ?warn ?(init=false) ?(domain=false) p hs =
match F.is_ptrue p with
| Yes -> hs
| No ->
- let cond = if init then Init p else if domain then Type p else Have p in
- let s = step ?descr ?stmt ?deps ?warn cond in
- Bundle.add s Bundle.empty
+ let cond = if init then Init p else if domain then Type p else Have p in
+ let s = step ?descr ?stmt ?deps ?warn cond in
+ Bundle.add s Bundle.empty
| Maybe ->
- begin
- match Bundle.category hs with
- | MAYBE | TRUE | EMPTY ->
- let p = exist_intro p in
- let cond =
- if init then Init p else if domain then Type p else Have p in
- let s = step ?descr ?stmt ?deps ?warn cond in
- Bundle.add s hs
- | FALSE -> hs
- end
+ begin
+ match Bundle.category hs with
+ | MAYBE | TRUE | EMPTY ->
+ let p = exist_intro p in
+ let cond =
+ if init then Init p else if domain then Type p else Have p in
+ let s = step ?descr ?stmt ?deps ?warn cond in
+ Bundle.add s hs
+ | FALSE -> hs
+ end
let join = function None -> None | Some s -> Some (step (State s))
@@ -558,37 +558,37 @@ let branch ?descr ?stmt ?deps ?warn p ha hb =
| Yes -> ha
| No -> hb
| Maybe ->
- match Bundle.category ha , Bundle.category hb with
- | TRUE , TRUE -> Bundle.empty
- | _ , FALSE -> assume ?descr ?stmt ?deps ?warn p ha
- | FALSE , _ -> assume ?descr ?stmt ?deps ?warn (p_not p) hb
- | _ ->
- let ha,hs,hb = Bundle.factorize ha hb in
- if Bundle.is_empty ha && Bundle.is_empty hb then hs else
- let join = join (Bundle.head hs) in
- let a = Bundle.freeze ?join ha in
- let b = Bundle.freeze ?join hb in
- let s = step ?descr ?stmt ?deps ?warn (Branch(p,a,b)) in
- Bundle.add s hs
+ match Bundle.category ha , Bundle.category hb with
+ | TRUE , TRUE -> Bundle.empty
+ | _ , FALSE -> assume ?descr ?stmt ?deps ?warn p ha
+ | FALSE , _ -> assume ?descr ?stmt ?deps ?warn (p_not p) hb
+ | _ ->
+ let ha,hs,hb = Bundle.factorize ha hb in
+ if Bundle.is_empty ha && Bundle.is_empty hb then hs else
+ let join = join (Bundle.head hs) in
+ let a = Bundle.freeze ?join ha in
+ let b = Bundle.freeze ?join hb in
+ let s = step ?descr ?stmt ?deps ?warn (Branch(p,a,b)) in
+ Bundle.add s hs
let either ?descr ?stmt ?deps ?warn cases =
match disjunction Bundle.category cases with
| D_TRUE -> Bundle.empty
| D_FALSE ->
+ let s = step ?descr ?stmt ?deps ?warn (Have p_false) in
+ Bundle.add s Bundle.empty
+ | D_EITHER cases ->
+ let trunk = Bundle.big_inter cases in
+ let cases = List.map (fun case -> Bundle.diff case trunk) cases in
+ match disjunction Bundle.category cases with
+ | D_TRUE -> trunk
+ | D_FALSE ->
let s = step ?descr ?stmt ?deps ?warn (Have p_false) in
Bundle.add s Bundle.empty
- | D_EITHER cases ->
- let trunk = Bundle.big_inter cases in
- let cases = List.map (fun case -> Bundle.diff case trunk) cases in
- match disjunction Bundle.category cases with
- | D_TRUE -> trunk
- | D_FALSE ->
- let s = step ?descr ?stmt ?deps ?warn (Have p_false) in
- Bundle.add s Bundle.empty
- | D_EITHER cases ->
- let cases = List.map Bundle.freeze cases in
- let s = step ?descr ?stmt ?deps ?warn (Either cases) in
- Bundle.add s trunk
+ | D_EITHER cases ->
+ let cases = List.map Bundle.freeze cases in
+ let s = step ?descr ?stmt ?deps ?warn (Either cases) in
+ Bundle.add s trunk
let merge cases = either ~descr:"Merge" cases
@@ -599,9 +599,9 @@ let merge cases = either ~descr:"Merge" cases
let rec flat_catg = function
| [] -> EMPTY
| s::cs ->
- match catg_step s with
- | EMPTY -> flat_catg cs
- | r -> r
+ match catg_step s with
+ | EMPTY -> flat_catg cs
+ | r -> r
let flat_cons step tail =
match flat_catg tail with
@@ -613,10 +613,10 @@ let flat_concat head tail =
| EMPTY -> tail
| FALSE -> head
| MAYBE|TRUE ->
- match flat_catg tail with
- | EMPTY -> head
- | FALSE -> tail
- | MAYBE|TRUE -> head @ tail
+ match flat_catg tail with
+ | EMPTY -> head
+ | FALSE -> tail
+ | MAYBE|TRUE -> head @ tail
let core_residual step core = {
id = noid ;
@@ -640,55 +640,55 @@ let core_branch step p a b =
let rec flatten_sequence m = function
| [] -> []
| step :: seq ->
- match step.condition with
- | State _ -> flat_cons step (flatten_sequence m seq)
- | Have p | Type p | When p | Core p | Init p ->
- begin
- match F.is_ptrue p with
- | Yes -> m := true ; flatten_sequence m seq
- | No -> (* FALSE context *) if seq <> [] then m := true ; [step]
- | Maybe -> flat_cons step (flatten_sequence m seq)
- end
- | Branch(p,a,b) ->
- begin
- match F.is_ptrue p with
- | Yes -> m := true ; flat_concat a.seq_list (flatten_sequence m seq)
- | No -> m := true ; flat_concat b.seq_list (flatten_sequence m seq)
- | Maybe ->
- let sa = a.seq_list in
- let sb = b.seq_list in
- match a.seq_catg , b.seq_catg with
- | (TRUE|EMPTY) , (TRUE|EMPTY) ->
- m := true ; flatten_sequence m seq
- | _ , FALSE ->
- m := true ;
- let step = update_cond step (Have p) in
- step :: sa @ flatten_sequence m seq
- | FALSE , _ ->
- m := true ;
- let step = update_cond step (Have (p_not p)) in
- step :: sb @ flatten_sequence m seq
- | _ ->
- begin
- match Core.factorize a b with
- | None -> step :: flatten_sequence m seq
- | Some( core , a , b ) ->
- m := true ;
- let score = core_residual step core in
- let scond = core_branch step p a b in
- score :: scond :: flatten_sequence m seq
- end
- end
- | Either [] -> (* FALSE context *) if seq <> [] then m := true ; [step]
- | Either cases ->
- match disjunction catg_seq cases with
- | D_TRUE -> m := true ; flatten_sequence m seq
- | D_FALSE -> m := true ; [ update_cond step (Have p_false) ]
- | D_EITHER [hc] ->
- m := true ; flat_concat hc.seq_list (flatten_sequence m seq)
- | D_EITHER cs ->
- let step = update_cond step (Either cs) in
- flat_cons step (flatten_sequence m seq)
+ match step.condition with
+ | State _ -> flat_cons step (flatten_sequence m seq)
+ | Have p | Type p | When p | Core p | Init p ->
+ begin
+ match F.is_ptrue p with
+ | Yes -> m := true ; flatten_sequence m seq
+ | No -> (* FALSE context *) if seq <> [] then m := true ; [step]
+ | Maybe -> flat_cons step (flatten_sequence m seq)
+ end
+ | Branch(p,a,b) ->
+ begin
+ match F.is_ptrue p with
+ | Yes -> m := true ; flat_concat a.seq_list (flatten_sequence m seq)
+ | No -> m := true ; flat_concat b.seq_list (flatten_sequence m seq)
+ | Maybe ->
+ let sa = a.seq_list in
+ let sb = b.seq_list in
+ match a.seq_catg , b.seq_catg with
+ | (TRUE|EMPTY) , (TRUE|EMPTY) ->
+ m := true ; flatten_sequence m seq
+ | _ , FALSE ->
+ m := true ;
+ let step = update_cond step (Have p) in
+ step :: sa @ flatten_sequence m seq
+ | FALSE , _ ->
+ m := true ;
+ let step = update_cond step (Have (p_not p)) in
+ step :: sb @ flatten_sequence m seq
+ | _ ->
+ begin
+ match Core.factorize a b with
+ | None -> step :: flatten_sequence m seq
+ | Some( core , a , b ) ->
+ m := true ;
+ let score = core_residual step core in
+ let scond = core_branch step p a b in
+ score :: scond :: flatten_sequence m seq
+ end
+ end
+ | Either [] -> (* FALSE context *) if seq <> [] then m := true ; [step]
+ | Either cases ->
+ match disjunction catg_seq cases with
+ | D_TRUE -> m := true ; flatten_sequence m seq
+ | D_FALSE -> m := true ; [ update_cond step (Have p_false) ]
+ | D_EITHER [hc] ->
+ m := true ; flat_concat hc.seq_list (flatten_sequence m seq)
+ | D_EITHER cs ->
+ let step = update_cond step (Either cs) in
+ flat_cons step (flatten_sequence m seq)
(* -------------------------------------------------------------------------- *)
(* --- Mapping --- *)
@@ -709,10 +709,10 @@ and map_step f h = update_cond h (map_condition f h.condition)
and map_steplist f = function
| [] -> []
| h::hs ->
- let h = map_step f h in
- if is_absurd_h h then [h] else
- let hs = map_steplist f hs in
- if is_trivial_h h then hs else h :: hs
+ let h = map_step f h in
+ if is_absurd_h h then [h] else
+ let hs = map_steplist f hs in
+ if is_trivial_h h then hs else h :: hs
and map_sequence f s =
sequence (map_steplist f s.seq_list)
@@ -728,21 +728,21 @@ module Ground = Letify.Ground
let rec ground_flow ~fwd env h =
match h.condition with
| State s ->
- let s = Mstate.apply (Ground.e_apply env) s in
- update_cond h (State s)
+ let s = Mstate.apply (Ground.e_apply env) s in
+ update_cond h (State s)
| Type _ | Have _ | When _ | Core _ | Init _ ->
- let phi = if fwd then Ground.forward else Ground.backward in
- let cond = map_condition (phi env) h.condition in
- update_cond h cond
+ let phi = if fwd then Ground.forward else Ground.backward in
+ let cond = map_condition (phi env) h.condition in
+ update_cond h cond
| Branch(p,a,b) ->
- let p,wa,wb = Ground.branch env p in
- let a = ground_flowseq ~fwd wa a in
- let b = ground_flowseq ~fwd wb b in
- update_cond h (Branch(p,a,b))
+ let p,wa,wb = Ground.branch env p in
+ let a = ground_flowseq ~fwd wa a in
+ let b = ground_flowseq ~fwd wb b in
+ update_cond h (Branch(p,a,b))
| Either ws ->
- let ws = List.map
- (fun w -> ground_flowseq ~fwd (Ground.copy env) w) ws in
- update_cond h (Either ws)
+ let ws = List.map
+ (fun w -> ground_flowseq ~fwd (Ground.copy env) w) ws in
+ update_cond h (Either ws)
and ground_flowseq ~fwd env hs =
sequence (ground_flowlist ~fwd env hs.seq_list)
@@ -755,10 +755,10 @@ and ground_flowlist ~fwd env hs =
and ground_flowdir ~fwd env = function
| [] -> []
| h::hs ->
- let h = ground_flow ~fwd env h in
- if is_absurd_h h then [h] else
- let hs = ground_flowdir ~fwd env hs in
- if is_trivial_h h then hs else h :: hs
+ let h = ground_flow ~fwd env h in
+ if is_absurd_h h then [h] else
+ let hs = ground_flowdir ~fwd env hs in
+ if is_trivial_h h then hs else h :: hs
let ground (hs,g) =
let hs = ground_flowlist ~fwd:true (Ground.top ()) hs in
@@ -804,16 +804,16 @@ let letify_assume sref (_,step) =
match step.condition with
| Type _ | Branch _ | Either _ | State _ -> ()
| Init p | Have p | When p | Core p ->
- if Wp_parameters.Simpl.get () then
- sref := Sigma.assume current p
+ if Wp_parameters.Simpl.get () then
+ sref := Sigma.assume current p
end ; current
let rec letify_type sigma used p = match F.p_expr p with
| And ps -> p_all (letify_type sigma used) ps
| _ ->
- let p = Sigma.p_apply sigma p in
- let vs = F.varsp p in
- if Vars.intersect used vs || Vars.is_empty vs then p else F.p_true
+ let p = Sigma.p_apply sigma p in
+ let vs = F.varsp p in
+ if Vars.intersect used vs || Vars.is_empty vs then p else F.p_true
let rec letify_seq sigma0 ~target ~export (seq : step list) =
let dseq = Array.map (dseq_of_step sigma0) (Array.of_list seq) in
@@ -841,35 +841,35 @@ and letify_step dseq dsigma ~required ~target ~used i (d,s) =
let cond = match s.condition with
| State s -> State (Mstate.apply (Sigma.e_apply sigma) s)
| Init p ->
- let p = Sigma.p_apply sigma p in
- let ps = Letify.add_definitions sigma d required [p] in
- Init (p_conj ps)
+ let p = Sigma.p_apply sigma p in
+ let ps = Letify.add_definitions sigma d required [p] in
+ Init (p_conj ps)
| Have p ->
- let p = Sigma.p_apply sigma p in
- let ps = Letify.add_definitions sigma d required [p] in
- Have (p_conj ps)
+ let p = Sigma.p_apply sigma p in
+ let ps = Letify.add_definitions sigma d required [p] in
+ Have (p_conj ps)
| Core p ->
- let p = Sigma.p_apply sigma p in
- let ps = Letify.add_definitions sigma d required [p] in
- Core (p_conj ps)
+ let p = Sigma.p_apply sigma p in
+ let ps = Letify.add_definitions sigma d required [p] in
+ Core (p_conj ps)
| When p ->
- let p = Sigma.p_apply sigma p in
- let ps = Letify.add_definitions sigma d required [p] in
- When (p_conj ps)
+ let p = Sigma.p_apply sigma p in
+ let ps = Letify.add_definitions sigma d required [p] in
+ When (p_conj ps)
| Type p ->
- Type (letify_type sigma used p)
+ Type (letify_type sigma used p)
| Branch(p,a,b) ->
- let p = Sigma.p_apply sigma p in
- let step = F.varsp p in
- let (target,export) = locals sigma ~target ~required ~step i dseq in
- let sa = Sigma.assume sigma p in
- let sb = Sigma.assume sigma (p_not p) in
- let a = letify_case sa ~target ~export a in
- let b = letify_case sb ~target ~export b in
- Branch(p,a,b)
+ let p = Sigma.p_apply sigma p in
+ let step = F.varsp p in
+ let (target,export) = locals sigma ~target ~required ~step i dseq in
+ let sa = Sigma.assume sigma p in
+ let sb = Sigma.assume sigma (p_not p) in
+ let a = letify_case sa ~target ~export a in
+ let b = letify_case sb ~target ~export b in
+ Branch(p,a,b)
| Either cases ->
- let (target,export) = locals sigma ~target ~required i dseq in
- Either (List.map (letify_case sigma ~target ~export) cases)
+ let (target,export) = locals sigma ~target ~required i dseq in
+ Either (List.map (letify_case sigma ~target ~export) cases)
in update_cond s cond
and letify_case sigma ~target ~export seq =
@@ -897,11 +897,11 @@ let apply_goal solvers p =
in
match F.p_expr p with
| Or ps ->
- let unmodified,qs = List.fold_left (fun (unmodified,qs) p ->
- let p' = stronger_and_then_assume p in
- (unmodified && (Lang.F.eqp p p')), (p'::qs))
- (true,[]) ps
- in if unmodified then p else p_disj qs
+ let unmodified,qs = List.fold_left (fun (unmodified,qs) p ->
+ let p' = stronger_and_then_assume p in
+ (unmodified && (Lang.F.eqp p p')), (p'::qs))
+ (true,[]) ps
+ in if unmodified then p else p_disj qs
| _ -> stronger_and_then_assume p
let apply_hyp modified solvers h =
@@ -912,11 +912,11 @@ let apply_hyp modified solvers h =
in
let weaken p = match F.p_expr p with
| And ps ->
- let unmodified,qs = List.fold_left (fun (unmodified,qs) p ->
- let p' = weaken_and_then_assume p in
- (unmodified && (Lang.F.eqp p p')), (p'::qs))
- (true,[]) ps
- in if unmodified then p else p_conj qs
+ let unmodified,qs = List.fold_left (fun (unmodified,qs) p ->
+ let p' = weaken_and_then_assume p in
+ (unmodified && (Lang.F.eqp p p')), (p'::qs))
+ (true,[]) ps
+ in if unmodified then p else p_conj qs
| _ -> weaken_and_then_assume p
in
match h.condition with
@@ -932,10 +932,10 @@ let apply_hyp modified solvers h =
let decide_branch modified solvers h =
match h.condition with
| Branch(p,a,b) ->
- let q = equivalent_branch solvers p in
- if q != p then
- ( modified := true ; update_cond h (Branch(q,a,b)) )
- else h
+ let q = equivalent_branch solvers p in
+ if q != p then
+ ( modified := true ; update_cond h (Branch(q,a,b)) )
+ else h
| _ -> h
let add_infer modified s hs =
@@ -1054,12 +1054,12 @@ struct
let rec is_cst s e = match F.repr e with
| True | False | Kint _ | Kreal _ -> true
| Fun(_,es) ->
- begin
- try Tmap.find e s.cst
- with Not_found ->
- let cst = List.for_all (is_cst s) es in
- s.cst <- Tmap.add e cst s.cst ; cst
- end
+ begin
+ try Tmap.find e s.cst
+ with Not_found ->
+ let cst = List.for_all (is_cst s) es in
+ s.cst <- Tmap.add e cst s.cst ; cst
+ end
| _ -> false
let set_def s p a e =
@@ -1069,7 +1069,7 @@ struct
| Logic.Yes -> ()
| Logic.No -> raise Contradiction
| Logic.Maybe ->
- if F.compare e e0 < 0 then s.def <- Tmap.add a e s.def
+ if F.compare e e0 < 0 then s.def <- Tmap.add a e s.def
with Not_found ->
begin
s.dom <- Vars.union (F.vars a) s.dom ;
@@ -1081,8 +1081,8 @@ struct
let collect_set_def s p = Lang.iter_consequence_literals
(fun literal -> match Lang.F.repr literal with
| Logic.Eq(a,b) ->
- if is_cst s a then set_def s literal b a ;
- if is_cst s b then set_def s literal a b ;
+ if is_cst s a then set_def s literal b a ;
+ if is_cst s b then set_def s literal a b ;
| _ -> ()) p
let collect s = function
@@ -1093,9 +1093,9 @@ struct
match s.cache with
| Some m -> m
| None ->
- let m = Lang.sigma () in
- F.Subst.add_fun m (fun e -> Tmap.find e s.def) ;
- s.cache <- Some m ; m
+ let m = Lang.sigma () in
+ F.Subst.add_fun m (fun e -> Tmap.find e s.def) ;
+ s.cache <- Some m ; m
let e_apply s e = F.e_subst (subst s) e
let p_apply s p = F.p_subst (subst s) p
@@ -1168,11 +1168,11 @@ let rec simplify ?(solvers=[]) ?(intros=10) (seq,p0) =
let sequent = sequence hs , p in
match introduction sequent with
| Some introduced ->
- if intros > 0 then
- simplify ~solvers ~intros:(pred intros) introduced
- else introduced
+ if intros > 0 then
+ simplify ~solvers ~intros:(pred intros) introduced
+ else introduced
| None ->
- sequent
+ sequent
(* -------------------------------------------------------------------------- *)
(* --- Pruning --- *)
@@ -1191,7 +1191,7 @@ let residual p = {
let rec add_case p = function
| ( { condition = (Type _) } as step ):: tail ->
- step :: add_case p tail
+ step :: add_case p tail
| hs -> residual p :: hs
let test_case p (s:hsp) =
@@ -1203,12 +1203,12 @@ let tc = ref 0
let rec test_cases (s : hsp) = function
| [] -> s
| (p,_) :: tail ->
- Db.yield () ;
- match test_case p s , test_case (p_not p) s with
- | None , None -> incr tc ; [],F.p_true
- | Some w , None -> incr tc ; test_cases w tail
- | None , Some w -> incr tc ; test_cases w tail
- | Some _ , Some _ -> test_cases s tail
+ Db.yield () ;
+ match test_case p s , test_case (p_not p) s with
+ | None , None -> incr tc ; [],F.p_true
+ | Some w , None -> incr tc ; test_cases w tail
+ | None , Some w -> incr tc ; test_cases w tail
+ | Some _ , Some _ -> test_cases s tail
let rec collect_cond m = function
| When _ | Have _ | Type _ | Init _ | Core _ | State _ -> ()
@@ -1276,12 +1276,12 @@ and clean_seq u s =
and clean_steps u = function
| [] -> []
| s :: seq ->
- let c = clean_cond u s.condition in
- let seq = clean_steps u seq in
- match catg_cond c with
- | EMPTY -> seq
- | FALSE -> [update_cond s c]
- | TRUE | MAYBE -> update_cond s c :: seq
+ let c = clean_cond u s.condition in
+ let seq = clean_steps u seq in
+ match catg_cond c with
+ | EMPTY -> seq
+ | FALSE -> [update_cond s c]
+ | TRUE | MAYBE -> update_cond s c :: seq
let clean (s,p) =
let u = Cleaning.create () in
@@ -1354,30 +1354,30 @@ struct
in
match F.repr t with
| Fun(f,[]) ->
- Gset.singleton f , Fset.empty
+ Gset.singleton f , Fset.empty
| Fun(f,_) when not deep || is_coloring_lfun f ->
- Gset.empty , fset_of_lfun ~deep m f
+ Gset.empty , fset_of_lfun ~deep m f
| Fun(f,_) ->
- collect_subterms (Gset.empty , fset_of_lfun ~deep m f)
+ collect_subterms (Gset.empty , fset_of_lfun ~deep m f)
| Rget(_,fd) ->
- Gset.empty , Fset.singleton fd
+ Gset.empty , Fset.singleton fd
| Rdef fts ->
- Gset.empty ,
- List.fold_left (fun fs (f,_) -> Fset.add f fs)
- Fset.empty fts
+ Gset.empty ,
+ List.fold_left (fun fs (f,_) -> Fset.add f fs)
+ Fset.empty fts
| _ ->
- collect_subterms FP.empty
+ collect_subterms FP.empty
and gvars_of_pred m p = gvars_of_term m (F.e_prop p)
and fset_of_tau (t : Lang.tau) =
match t with
| Qed.Logic.Array(ta,tb) ->
- Fset.union (fset_of_tau ta) (fset_of_tau tb)
+ Fset.union (fset_of_tau ta) (fset_of_tau tb)
| Qed.Logic.Record fts ->
- fsetmap (fun (f,t) -> Fset.add f (fset_of_tau t)) fts
+ fsetmap (fun (f,t) -> Fset.add f (fset_of_tau t)) fts
| Qed.Logic.Data(adt,ts) ->
- Fset.union (fsetmap fset_of_tau ts) (fset_of_adt adt)
+ Fset.union (fsetmap fset_of_tau ts) (fset_of_adt adt)
| _ -> Fset.empty
and fset_of_adt adt =
@@ -1432,36 +1432,36 @@ struct
match F.p_expr p with
| And ps -> F.p_all (filter_pred m) ps
| _ ->
- if Vars.subset (F.varsp p) m.xs then
- begin
- let gs = gvars_of_pred ~deep:false m p in
- if FP.subset gs m.gs then p else
- if FP.intersect gs m.gs then
- (m.fixpoint <- false ; m.gs <- FP.union gs m.gs ; p)
- else p_true
- end
- else p_true
+ if Vars.subset (F.varsp p) m.xs then
+ begin
+ let gs = gvars_of_pred ~deep:false m p in
+ if FP.subset gs m.gs then p else
+ if FP.intersect gs m.gs then
+ (m.fixpoint <- false ; m.gs <- FP.union gs m.gs ; p)
+ else p_true
+ end
+ else p_true
let rec filter_steplist m = function
| [] -> []
| s :: w ->
- match s.condition with
- | State _ | Have _ | When _ | Core _ | Branch _ | Either _ ->
- s :: filter_steplist m w
- | Type p ->
- let p = filter_pred m p in
- let w = filter_steplist m w in
- if p != F.p_true then
- let s = update_cond s (Type p) in
- s :: w
- else w
- | Init p ->
- let p = filter_pred m p in
- let w = filter_steplist m w in
- if p != F.p_true then
- let s = update_cond s (Init p) in
- s :: w
- else w
+ match s.condition with
+ | State _ | Have _ | When _ | Core _ | Branch _ | Either _ ->
+ s :: filter_steplist m w
+ | Type p ->
+ let p = filter_pred m p in
+ let w = filter_steplist m w in
+ if p != F.p_true then
+ let s = update_cond s (Type p) in
+ s :: w
+ else w
+ | Init p ->
+ let p = filter_pred m p in
+ let w = filter_steplist m w in
+ if p != F.p_true then
+ let s = update_cond s (Init p) in
+ s :: w
+ else w
let make (seq,g) =
let m = {
@@ -1558,10 +1558,10 @@ struct
let add_eq (w : domain) x y =
match kind x w , kind y w with
| None , None ->
- let cmp = F.Var.compare x y in
- if cmp > 0 then add_def w x (F.e_var y) else
- if cmp < 0 then add_def w y (F.e_var x) else
- w
+ let cmp = F.Var.compare x y in
+ if cmp > 0 then add_def w x (F.e_var y) else
+ if cmp < 0 then add_def w y (F.e_var x) else
+ w
| None , Some Used -> add_def w x (F.e_var y)
| Some Used , None -> add_def w y (F.e_var x)
| Some(Def e),(None | Some Used)
@@ -1569,8 +1569,8 @@ struct
-> add_usedvar x (add_usedvar y (add_used w (F.vars e)))
| Some Used,Some Used -> w
| Some(Def a),Some(Def b) ->
- let xs = Vars.union (F.vars a) (F.vars b) in
- add_usedvar x (add_usedvar y (add_used w xs))
+ let xs = Vars.union (F.vars a) (F.vars b) in
+ add_usedvar x (add_usedvar y (add_used w xs))
let branch p wa wb =
let pool = ref (F.varsp p) in
@@ -1580,7 +1580,7 @@ struct
| Used,Used -> Used
| Def a,Def b -> Def( F.e_if (F.e_prop p) a b )
| Def e,Used | Used,Def e ->
- pool := Vars.union !pool (F.vars e) ; Used
+ pool := Vars.union !pool (F.vars e) ; Used
) wa wb in
add_used w0 !pool
@@ -1588,12 +1588,12 @@ struct
match F.repr p with
| And ps -> List.fold_left usage w ps
| Eq(a,b) ->
- begin match F.repr a , F.repr b with
- | Fvar x , Fvar y -> add_eq w x y
- | Fvar x , _ -> add_def w x b
- | _ , Fvar y -> add_def w y a
- | _ -> add_used w (F.vars p)
- end
+ begin match F.repr a , F.repr b with
+ | Fvar x , Fvar y -> add_eq w x y
+ | Fvar x , _ -> add_def w x b
+ | _ , Fvar y -> add_def w y a
+ | _ -> add_used w (F.vars p)
+ end
| _ -> add_used w (F.vars p)
let rec collect_step w s =
@@ -1601,11 +1601,11 @@ struct
| Type _ | State _ -> w
| Have p | Core p | Init p | When p -> usage w (F.e_prop p)
| Branch(p,a,b) ->
- let wa = collect_seq w a in
- let wb = collect_seq w b in
- branch p wa wb
+ let wa = collect_seq w a in
+ let wb = collect_seq w b in
+ branch p wa wb
| Either ws ->
- List.fold_left collect_seq w ws
+ List.fold_left collect_seq w ws
and collect_seq w s = List.fold_left collect_step w s.seq_list
@@ -1746,25 +1746,25 @@ let index (seq,_) = ignore (steps seq)
let rec at_list k = function
| [] -> assert false
| s::w ->
- if k = 0 then s else
- let n = s.size in
- if k < n then at_step (k-1) s.condition else at_list (k - n) w
+ if k = 0 then s else
+ let n = s.size in
+ if k < n then at_step (k-1) s.condition else at_list (k - n) w
and at_step k = function
| Have _ | When _ | Type _ | Core _ | Init _ | State _ -> assert false
| Branch(_,a,b) ->
- let n = a.seq_size in
- if k < n then
- at_list k a.seq_list
- else
- at_list (k-n) b.seq_list
+ let n = a.seq_size in
+ if k < n then
+ at_list k a.seq_list
+ else
+ at_list (k-n) b.seq_list
| Either cs -> at_case k cs
and at_case k = function
| [] -> assert false
| c::cs ->
- let n = c.seq_size in
- if k < n then at_list k c.seq_list else at_case (k - n) cs
+ let n = c.seq_size in
+ if k < n then at_list k c.seq_list else at_case (k - n) cs
let step_at seq k =
if 0 <= k && k < seq.seq_size
@@ -1788,29 +1788,29 @@ let in_sequence_add_list ~replace =
match w with
| [] -> assert false
| s::w ->
- let n = s.size in
- if k < n then
- let cond = in_step (k-1) h s.condition in
- update_cond s cond :: w
- else s :: in_list (k-n) h w
+ let n = s.size in
+ if k < n then
+ let cond = in_step (k-1) h s.condition in
+ update_cond s cond :: w
+ else s :: in_list (k-n) h w
and in_step k h = function
| Have _ | When _ | Type _ | Core _ | Init _ | State _ -> assert false
| Branch(p,a,b) ->
- let n = a.seq_size in
- if k < n then
- Branch(p,in_sequence_add_list k h a,b)
- else
- Branch(p,a,in_sequence_add_list (k-n) h b)
+ let n = a.seq_size in
+ if k < n then
+ Branch(p,in_sequence_add_list k h a,b)
+ else
+ Branch(p,a,in_sequence_add_list (k-n) h b)
| Either cs -> Either (in_case k h cs)
and in_case k h = function
| [] -> assert false
| c::cs ->
- let n = c.seq_size in
- if k < n
- then in_sequence_add_list k h c :: cs
- else c :: in_case (k-n) h cs
+ let n = c.seq_size in
+ if k < n
+ then in_sequence_add_list k h c :: cs
+ else c :: in_case (k-n) h cs
and in_sequence_add_list k h s = sequence (in_list k h s.seq_list)
in in_sequence_add_list
diff --git a/src/plugins/wp/Cstring.ml b/src/plugins/wp/Cstring.ml
index c61a714a1297b48227d80514487246a51f880d35..1eef917472eb71f389bee93cbd2e2904fa044bfe 100644
--- a/src/plugins/wp/Cstring.ml
+++ b/src/plugins/wp/Cstring.ml
@@ -99,8 +99,8 @@ module LIT = WpContext.Generator(STR)
begin match s with
| C_str str -> export_literal prefix lfun str
| W_str _ ->
- Wp_parameters.warning ~current:false ~once:true
- "Content of wide string literals not exported."
+ Wp_parameters.warning ~current:false ~once:true
+ "Content of wide string literals not exported."
end ;
id , F.e_fun lfun []
diff --git a/src/plugins/wp/Cvalues.ml b/src/plugins/wp/Cvalues.ml
index 207ac81a387db1f63c5eff26e6a0e0d47d0d1ad9..f8a855ef773a028569ad95e1d6322a7c6bc97b1c 100644
--- a/src/plugins/wp/Cvalues.ml
+++ b/src/plugins/wp/Cvalues.ml
@@ -121,14 +121,14 @@ let rec init_value value obj =
| C_int _ | C_float _ | C_pointer _ -> value
| C_comp ci -> init_comp_value value ci
| C_array _ as arr ->
- Lang.F.e_const Lang.t_int
- (init_value value (object_of_array_elem arr))
+ Lang.F.e_const Lang.t_int
+ (init_value value (object_of_array_elem arr))
and init_comp_value value ci =
match ci.cfields with
| None -> initialized_value_opaque_comp value ci
| Some fields ->
- let make f = Cfield (f, KInit), init_value value (object_of f.ftype) in
- Lang.F.e_record (List.map make fields)
+ let make f = Cfield (f, KInit), init_value value (object_of f.ftype) in
+ Lang.F.e_record (List.map make fields)
let initialized_obj = init_value e_true
let uninitialized_obj = init_value e_false
@@ -217,11 +217,11 @@ struct
let pp_dim fmt d = if d > 1 then Format.fprintf fmt "_d%d" d in
match te with
| C_int i ->
- Format.asprintf "%sArray%a_%a" C.prefix pp_dim dim model_int i
+ Format.asprintf "%sArray%a_%a" C.prefix pp_dim dim model_int i
| C_comp c ->
- Format.asprintf "%sArray%a_%s" C.prefix pp_dim dim (Lang.comp_id c)
+ Format.asprintf "%sArray%a_%s" C.prefix pp_dim dim (Lang.comp_id c)
| C_float _ | C_pointer _ | C_array _ ->
- assert false
+ assert false
let rec is_obj obj t =
match obj with
@@ -229,13 +229,13 @@ struct
| C_float f -> C.is_float f t
| C_pointer _ty -> C.is_pointer t
| C_comp c ->
- if constrained_comp c then is_record c t else p_true
+ if constrained_comp c then is_record c t else p_true
| C_array a ->
- if constrained_elt a.arr_element
- then
- let te,ds = Ctypes.array_dimensions a in
- is_array te ds t
- else p_true
+ if constrained_elt a.arr_element
+ then
+ let te,ds = Ctypes.array_dimensions a in
+ is_array te ds t
+ else p_true
and is_typ typ t = is_obj (Ctypes.object_of typ) t
@@ -249,9 +249,9 @@ struct
match c.cfields with
| None -> Logic Lang.t_prop
| Some fields ->
- let value f = e_getfield (e_var s) (Lang.Cfield (f, KValue)) in
- let def = p_all (fun f -> is_typ f.ftype (value f)) fields in
- Predicate(Def,def)
+ let value f = e_getfield (e_var s) (Lang.Cfield (f, KValue)) in
+ let def = p_all (fun f -> is_typ f.ftype (value f)) fields in
+ Predicate(Def,def)
in {
d_lfun = lfun ; d_types = 0 ; d_params = [s] ;
d_cluster = Definitions.compinfo c ;
@@ -441,13 +441,13 @@ module EQCOMP = WpContext.Generator(Cil_datatype.Compinfo)
match c.cfields with
| None -> Logic Lang.t_prop
| Some fields ->
- let def = p_all
- (fun f ->
- let fd = Cfield (f, KValue) in
- !equal_rec (Ctypes.object_of f.ftype)
- (e_getfield ra fd) (e_getfield rb fd))
- fields
- in Predicate(Def, def)
+ let def = p_all
+ (fun f ->
+ let fd = Cfield (f, KValue) in
+ !equal_rec (Ctypes.object_of f.ftype)
+ (e_getfield ra fd) (e_getfield rb fd))
+ fields
+ in Predicate(Def, def)
in
(* Registration *)
Definitions.define_symbol {
@@ -529,19 +529,19 @@ let pp_logic pp fmt = function
let pp_rloc pp fmt = function
| Rloc(obj,l) ->
- Format.fprintf fmt "@[<hov 2>%a:@,%a@]" pp l Ctypes.pretty obj
+ Format.fprintf fmt "@[<hov 2>%a:@,%a@]" pp l Ctypes.pretty obj
| Rrange(l,obj,a,b) ->
- Format.fprintf fmt "@[<hov2>%a@,.(%a@,..%a):@,%a@]"
- pp l pp_bound a pp_bound b Ctypes.pretty obj
+ Format.fprintf fmt "@[<hov2>%a@,.(%a@,..%a):@,%a@]"
+ pp l pp_bound a pp_bound b Ctypes.pretty obj
let pp_sloc pp fmt = function
| Sloc l -> pp fmt l
| Sarray(l,_,n) ->
- Format.fprintf fmt "@[<hov2>%a@,.(..%d)@]" pp l (n-1)
+ Format.fprintf fmt "@[<hov2>%a@,.(..%d)@]" pp l (n-1)
| Srange(l,_,a,b) ->
- Format.fprintf fmt "@[<hov2>%a@,.(%a@,..%a)@]" pp l pp_bound a pp_bound b
+ Format.fprintf fmt "@[<hov2>%a@,.(%a@,..%a)@]" pp l pp_bound a pp_bound b
| Sdescr(xs,l,p) ->
- Format.fprintf fmt "@[<hov2>{ %a | %a }@]" pp l F.pp_pred (F.p_forall xs p)
+ Format.fprintf fmt "@[<hov2>{ %a | %a }@]" pp l F.pp_pred (F.p_forall xs p)
let pp_region pp fmt sloc =
List.iter (fun (_,s) -> Format.fprintf fmt "@ %a" (pp_sloc pp) s) sloc
@@ -607,21 +607,21 @@ struct
| Sloc l -> [],l,p_true
| Sdescr(xs,l,p) -> xs,l,p
| Sarray(l,obj,n) ->
- let x = Lang.freshvar ~basename:"k" Logic.Int in
- let k = e_var x in
- [x],M.shift l obj k,arange k n
+ let x = Lang.freshvar ~basename:"k" Logic.Int in
+ let k = e_var x in
+ [x],M.shift l obj k,arange k n
| Srange(l,obj,a,b) ->
- let x = Lang.freshvar ~basename:"k" Logic.Int in
- let k = e_var x in
- [x],M.shift l obj k,Vset.in_range k a b
+ let x = Lang.freshvar ~basename:"k" Logic.Int in
+ let k = e_var x in
+ [x],M.shift l obj k,Vset.in_range k a b
let vset_of_sloc sloc =
List.map
(function
| Sloc p -> Vset.Singleton (M.pointer_val p)
| u ->
- let xs,l,p = rdescr u in
- Vset.Descr( xs , M.pointer_val l , p )
+ let xs,l,p = rdescr u in
+ Vset.Descr( xs , M.pointer_val l , p )
) sloc
let sloc_of_vset phi vset =
@@ -629,8 +629,8 @@ struct
(function
| Vset.Singleton e -> phi (Sloc (M.pointer_loc e))
| w ->
- let xs,t,p = Vset.descr w in
- phi (Sdescr(xs,M.pointer_loc t,p))
+ let xs,t,p = Vset.descr w in
+ phi (Sdescr(xs,M.pointer_loc t,p))
) vset
let vset = function
@@ -709,17 +709,17 @@ struct
let restrict kset = function
| None -> kset
| Some s ->
- if Kernel.SafeArrays.get () then
- match kset with
- | Vset.Singleton _ | Vset.Set _ -> kset
- | Vset.Range(a,b) ->
- let cap l = function None -> Some l | u -> u in
- Vset.Range(cap e_zero a,cap (e_int (s-1)) b)
- | Vset.Descr(xs,k,p) ->
- let a = e_zero in
- let b = e_int s in
- Vset.Descr(xs,k,p_conj [p_leq a k;p_lt k b;p])
- else kset
+ if Kernel.SafeArrays.get () then
+ match kset with
+ | Vset.Singleton _ | Vset.Set _ -> kset
+ | Vset.Range(a,b) ->
+ let cap l = function None -> Some l | u -> u in
+ Vset.Range(cap e_zero a,cap (e_int (s-1)) b)
+ | Vset.Descr(xs,k,p) ->
+ let a = e_zero in
+ let b = e_int s in
+ Vset.Descr(xs,k,p_conj [p_leq a k;p_lt k b;p])
+ else kset
let is_ainf = function
| Some e -> e == e_zero
@@ -733,33 +733,33 @@ struct
match size with
| None -> Srange(loc,obj,a,b)
| Some n ->
- if is_ainf a && is_asup n b then
- Sarray(loc,obj,n)
- else
- Srange(loc,obj,a,b)
+ if is_ainf a && is_asup n b then
+ Sarray(loc,obj,n)
+ else
+ Srange(loc,obj,a,b)
let shift_set sloc obj (size : int option) kset =
match sloc , size , kset with
| Sloc l , Some n , Vset.Range(None,None) when Kernel.SafeArrays.get () ->
- Sarray(l,obj,n)
+ Sarray(l,obj,n)
| _ ->
- match sloc , restrict kset size with
- | Sloc l , Vset.Singleton k -> Sloc(M.shift l obj k)
- | Sloc l , Vset.Range(a,b) -> srange l obj size a b
- | Srange(l,obj0,a0,b0) , Vset.Singleton k
- when Ctypes.equal obj0 obj ->
- let a = Vset.bound_add a0 (Some k) in
- let b = Vset.bound_add b0 (Some k) in
- srange l obj0 size a b
- | Srange(l,obj0,a0,b0) , Vset.Range(a1,b1)
- when Ctypes.equal obj0 obj ->
- let a = Vset.bound_add a0 a1 in
- let b = Vset.bound_add b0 b1 in
- srange l obj0 size a b
- | _ ->
- let xs,l,p = rdescr sloc in
- let ys,k,q = Vset.descr kset in
- Sdescr( xs @ ys , M.shift l obj k , p_and p q )
+ match sloc , restrict kset size with
+ | Sloc l , Vset.Singleton k -> Sloc(M.shift l obj k)
+ | Sloc l , Vset.Range(a,b) -> srange l obj size a b
+ | Srange(l,obj0,a0,b0) , Vset.Singleton k
+ when Ctypes.equal obj0 obj ->
+ let a = Vset.bound_add a0 (Some k) in
+ let b = Vset.bound_add b0 (Some k) in
+ srange l obj0 size a b
+ | Srange(l,obj0,a0,b0) , Vset.Range(a1,b1)
+ when Ctypes.equal obj0 obj ->
+ let a = Vset.bound_add a0 a1 in
+ let b = Vset.bound_add b0 b1 in
+ srange l obj0 size a b
+ | _ ->
+ let xs,l,p = rdescr sloc in
+ let ys,k,q = Vset.descr kset in
+ Sdescr( xs @ ys , M.shift l obj k , p_and p q )
let shift lv obj ?size kv =
if is_single kv then
@@ -787,25 +787,25 @@ struct
| { vset=[] } -> Lset (List.rev a.sloc)
| { sloc=[] } -> Vset (List.rev a.vset)
| _ ->
- if prefer_loc then
- Lset (a.sloc @ sloc_of_vset (fun r -> r) a.vset)
- else
- Vset (vset_of_sloc a.sloc @ a.vset)
+ if prefer_loc then
+ Lset (a.sloc @ sloc_of_vset (fun r -> r) a.vset)
+ else
+ Vset (vset_of_sloc a.sloc @ a.vset)
let loadsloc a sigma obj = function
| Sloc l ->
- begin
- match M.load sigma obj l with
- | Val t -> a.vset <- Vset.Singleton t :: a.vset
- | Loc l -> a.sloc <- Sloc l :: a.sloc
- end
+ begin
+ match M.load sigma obj l with
+ | Val t -> a.vset <- Vset.Singleton t :: a.vset
+ | Loc l -> a.sloc <- Sloc l :: a.sloc
+ end
| (Sarray _ | Srange _ | Sdescr _) as s ->
- let xs , l , p = rdescr s in
- begin
- match M.load sigma obj l with
- | Val t -> a.vset <- Vset.Descr(xs,t,p) :: a.vset
- | Loc l -> a.sloc <- Sdescr(xs,l,p) :: a.sloc
- end
+ let xs , l , p = rdescr s in
+ begin
+ match M.load sigma obj l with
+ | Val t -> a.vset <- Vset.Descr(xs,t,p) :: a.vset
+ | Loc l -> a.sloc <- Sdescr(xs,l,p) :: a.sloc
+ end
let load sigma obj lv =
if is_single lv then
@@ -833,12 +833,12 @@ struct
let inter t vs =
match List.map (fun v -> Vset.concretize (vset v)) vs with
| [] ->
- if Logic_typing.is_pointer_type t
- then Lset [] else Vset []
+ if Logic_typing.is_pointer_type t
+ then Lset [] else Vset []
| v::vs ->
- let s = List.fold_left Vset.inter v vs in
- let t = Lang.tau_of_ltype t in
- Vset [Vset.Set(t,s)]
+ let s = List.fold_left Vset.inter v vs in
+ let t = Lang.tau_of_ltype t in
+ Vset [Vset.Set(t,s)]
(* -------------------------------------------------------------------------- *)
(* --- Sloc to Rloc --- *)
@@ -923,10 +923,10 @@ struct
| Vset a , Vset b -> Vset.subset a b
| Vloc _ , _ | _ , Vloc _
| Lset _ , _ | _ , Lset _ ->
- let ta = Ctypes.object_of_logic_pointed ta in
- let tb = Ctypes.object_of_logic_pointed tb in
- let ra = List.map (fun s -> ta,s) (sloc la) in
- let rb = List.map (fun s -> tb,s) (sloc lb) in
- p_all (fun s -> p_any (included s) rb) ra
+ let ta = Ctypes.object_of_logic_pointed ta in
+ let tb = Ctypes.object_of_logic_pointed tb in
+ let ra = List.map (fun s -> ta,s) (sloc la) in
+ let rb = List.map (fun s -> tb,s) (sloc lb) in
+ p_all (fun s -> p_any (included s) rb) ra
end
diff --git a/src/plugins/wp/Definitions.ml b/src/plugins/wp/Definitions.ml
index 57c44a2ff26ae2f58260256a85c5c249c0801f79..eaa124b574f2c07bcdd7c0b7fe36c196b0ceea44 100644
--- a/src/plugins/wp/Definitions.ml
+++ b/src/plugins/wp/Definitions.ml
@@ -87,12 +87,12 @@ struct
| Aget(a,k) -> TgGet(of_exp Cterm a,of_exp Cterm k)
| Aset(a,k,v) -> TgSet(of_exp Cterm a,of_exp Cterm k,of_exp Cterm v)
| Fun(f,ts) ->
- let ts = List.map (of_exp Cterm) ts in
- begin
- match mode with
- | Cterm -> TgFun(f,ts)
- | Cprop -> TgProp(f,ts)
- end
+ let ts = List.map (of_exp Cterm) ts in
+ begin
+ match mode with
+ | Cterm -> TgFun(f,ts)
+ | Cprop -> TgProp(f,ts)
+ end
| _ -> TgAny
let of_term t = of_exp Cterm t
@@ -227,9 +227,9 @@ let axiomatic ax =
let section = function
| Toplevel 0 -> cluster ~id:"Axiomatic" ~title:"Global Definitions" ()
| Toplevel n ->
- let id = "Axiomatic" ^ string_of_int n in
- let title = Printf.sprintf "Global Definitions (continued #%d)" n in
- cluster ~id ~title ()
+ let id = "Axiomatic" ^ string_of_int n in
+ let title = Printf.sprintf "Global Definitions (continued #%d)" n in
+ cluster ~id ~title ()
| Axiomatic ax -> axiomatic ax
let compinfo c =
@@ -319,12 +319,12 @@ class virtual visitor main =
| None -> Qed.Engine.Tabs
| Some (LTsyn lt) -> Qed.Engine.Tdef (self#vtau_of_ltype lt)
| Some (LTsum cs) ->
- let cases = List.map
- (fun c ->
- Lang.CTOR c ,
- List.map self#vtau_of_ltype c.ctor_params
- ) cs in
- Qed.Engine.Tsum cases
+ let cases = List.map
+ (fun c ->
+ Lang.CTOR c ,
+ List.map self#vtau_of_ltype c.ctor_params
+ ) cs in
+ Qed.Engine.Tsum cases
in self#on_type t def ;
end
end
@@ -402,7 +402,7 @@ class virtual visitor main =
| Acst _ -> self#on_library "const"
| Eq _ | Neq _ | Leq _ | Lt _
| And _ | Or _ | Not _ | Imply _ | If _ ->
- if bool then self#on_library "bool"
+ if bool then self#on_library "bool"
method vterm t =
if not (Tset.mem t terms) then
@@ -452,10 +452,10 @@ class virtual visitor main =
method private vlfun f =
match Symbol.find f with
| exception Not_found ->
- Wp_parameters.fatal "Undefined symbol '%a'" Fun.pretty f
+ Wp_parameters.fatal "Undefined symbol '%a'" Fun.pretty f
| d ->
- let c = d.d_cluster in
- if self#do_local c then self#vdfun d
+ let c = d.d_cluster in
+ if self#do_local c then self#vdfun d
method vsymbol f =
if not (DF.mem f symbols) then
@@ -471,19 +471,19 @@ class virtual visitor main =
| Qed.Engine.TgAny -> ()
| Qed.Engine.TgVar x -> self#vparam x
| Qed.Engine.TgGet(a,k) ->
- begin
- self#vtrigger a ;
- self#vtrigger k ;
- end
+ begin
+ self#vtrigger a ;
+ self#vtrigger k ;
+ end
| Qed.Engine.TgSet(a,k,v) ->
- begin
- self#vtrigger a ;
- self#vtrigger k ;
- self#vtrigger v ;
- end
+ begin
+ self#vtrigger a ;
+ self#vtrigger k ;
+ self#vtrigger v ;
+ end
| Qed.Engine.TgFun(f,tgs)
| Qed.Engine.TgProp(f,tgs) ->
- self#vsymbol f ; List.iter self#vtrigger tgs
+ self#vsymbol f ; List.iter self#vtrigger tgs
method private vdlemma a =
if not (DS.mem a.l_name dlemmas) then
@@ -529,20 +529,20 @@ class virtual visitor main =
method vgoal (axioms : axioms option) prop =
match axioms with
| None ->
- (* Visit a goal *)
- begin
- let hs = LogicUsage.proof_context () in
- List.iter self#vlemma hs ;
- self#vpred prop ;
- end
+ (* Visit a goal *)
+ begin
+ let hs = LogicUsage.proof_context () in
+ List.iter self#vlemma hs ;
+ self#vpred prop ;
+ end
| Some(cluster,hs) ->
- (* Visit the goal corresponding to a lemma *)
- begin
- self#section (cluster_title cluster) ;
- self#set_local cluster ;
- List.iter self#vlemma hs ;
- self#vpred prop ;
- end
+ (* Visit the goal corresponding to a lemma *)
+ begin
+ self#section (cluster_title cluster) ;
+ self#set_local cluster ;
+ List.iter self#vlemma hs ;
+ self#vpred prop ;
+ end
method vtypes = (* Visit the types *)
rev_iter self#vcomp main.c_records ;
diff --git a/src/plugins/wp/Factory.ml b/src/plugins/wp/Factory.ml
index 36fec2b95781966600bf4d0f6fe2fae24c306611..79e7002b3e39d6de6d3166bfb6d3b9be7906ef4b 100644
--- a/src/plugins/wp/Factory.ml
+++ b/src/plugins/wp/Factory.ml
@@ -186,20 +186,20 @@ let refusage_param ~byref ~context x =
| RefUsage.NoAccess -> MemoryContext.NotUsed
| RefUsage.ByAddr -> MemoryContext.ByAddr
| RefUsage.ByValue ->
- if context && is_formal_ptr x then MemoryContext.InContext (validity x)
- else if is_ptr x && not (is_fun_ptr x) then MemoryContext.ByShift
- else MemoryContext.ByValue
+ if context && is_formal_ptr x then MemoryContext.InContext (validity x)
+ else if is_ptr x && not (is_fun_ptr x) then MemoryContext.ByShift
+ else MemoryContext.ByValue
| RefUsage.ByRef ->
- if byref
- then
- if RefUsage.is_nullable x
- then MemoryContext.InContext Nullable
- else MemoryContext.ByRef
- else MemoryContext.ByValue
+ if byref
+ then
+ if RefUsage.is_nullable x
+ then MemoryContext.InContext Nullable
+ else MemoryContext.ByRef
+ else MemoryContext.ByValue
| RefUsage.ByArray ->
- if context && is_formal_ptr x
- then MemoryContext.InArray (validity x)
- else MemoryContext.ByShift
+ if context && is_formal_ptr x
+ then MemoryContext.InArray (validity x)
+ else MemoryContext.ByShift
let refusage_iter ?kf ~init f = RefUsage.iter ?kf ~init (fun x _usage -> f x)
@@ -281,13 +281,13 @@ let configure_mheap = function
| Region -> MemRegion.configure ()
| Eva -> MemVal.configure ()
| Typed p ->
- let rollback_memtyped = MemTyped.configure () in
- let orig_memtyped_pointer = Context.push MemTyped.pointer p in
- let rollback () =
- rollback_memtyped () ;
- Context.pop MemTyped.pointer orig_memtyped_pointer
- in
- rollback
+ let rollback_memtyped = MemTyped.configure () in
+ let orig_memtyped_pointer = Context.push MemTyped.pointer p in
+ let rollback () =
+ rollback_memtyped () ;
+ Context.pop MemTyped.pointer orig_memtyped_pointer
+ in
+ rollback
let configure_driver setup driver () =
let rollback_mheap = configure_mheap setup.mheap in
diff --git a/src/plugins/wp/Filtering.ml b/src/plugins/wp/Filtering.ml
index e9181a34ebebd43fd3914eb8edbdc4405ec0905f..1e2e46cf27506c86889aa8a1113481b8cf411c95 100644
--- a/src/plugins/wp/Filtering.ml
+++ b/src/plugins/wp/Filtering.ml
@@ -38,13 +38,13 @@ let rec filter ~polarity f p =
| Or ps when not polarity -> F.p_any (filter ~polarity f) ps
| Not p -> F.p_not (filter_inv ~polarity f p)
| Imply(hs,p) ->
- F.p_hyps
- (List.map (filter_inv ~polarity f) hs)
- (filter ~polarity f p)
+ F.p_hyps
+ (List.map (filter_inv ~polarity f) hs)
+ (filter ~polarity f p)
| _ ->
- (* polarity=true: FALSE -> p
- polarity=false: p -> TRUE *)
- if f p then p else if polarity then F.p_false else F.p_true
+ (* polarity=true: FALSE -> p
+ polarity=false: p -> TRUE *)
+ if f p then p else if polarity then F.p_false else F.p_true
and filter_inv ~polarity f p = filter ~polarity:(not polarity) f p
@@ -70,19 +70,19 @@ struct
| Bot -> Format.pp_print_string fmt "Bot"
| Array u -> Format.fprintf fmt "[%a]" pretty u
| Index m ->
- begin
- Format.fprintf fmt "@[<hov 2>[" ;
- Imap.iteri (fun k u -> Format.fprintf fmt "@ %d:%a" k pretty u) m ;
- Format.fprintf fmt " ]@]" ;
- end
+ begin
+ Format.fprintf fmt "@[<hov 2>[" ;
+ Imap.iteri (fun k u -> Format.fprintf fmt "@ %d:%a" k pretty u) m ;
+ Format.fprintf fmt " ]@]" ;
+ end
| Field m ->
- begin
- Format.fprintf fmt "@[<hov 2>{" ;
- Fmap.iter
- (fun fd u -> Format.fprintf fmt "@ %a:%a" Field.pretty fd pretty u)
- m ;
- Format.fprintf fmt " }@]" ;
- end
+ begin
+ Format.fprintf fmt "@[<hov 2>{" ;
+ Fmap.iter
+ (fun fd u -> Format.fprintf fmt "@ %a:%a" Field.pretty fd pretty u)
+ m ;
+ Format.fprintf fmt " }@]" ;
+ end
let rec join u v =
match u,v with
@@ -90,11 +90,11 @@ struct
| Bot , w | w , Bot -> w
| Array u , Array v -> Array(join u v)
| Index m , Array u | Array u , Index m ->
- Array(Imap.fold (fun u w -> join u w) m u)
+ Array(Imap.fold (fun u w -> join u w) m u)
| Index a , Index b ->
- Index(Imap.union (fun _ u v -> join u v) a b)
+ Index(Imap.union (fun _ u v -> join u v) a b)
| Field a , Field b ->
- Field(Fmap.union (fun _ u v -> join u v) a b)
+ Field(Fmap.union (fun _ u v -> join u v) a b)
| (Index _ | Array _) , Field _
| Field _ , (Index _ | Array _)
-> Top
@@ -110,11 +110,11 @@ struct
| Bot , _ | _ , Bot -> Bot
| Array u , Array v -> meet_array (meet u v)
| Index m , Array v | Array v , Index m ->
- meet_index (Imap.mapf (fun _ u -> meet_filter (meet u v)) m)
+ meet_index (Imap.mapf (fun _ u -> meet_filter (meet u v)) m)
| Index a , Index b ->
- meet_index (Imap.interf (fun _ u v -> meet_filter (meet u v)) a b)
+ meet_index (Imap.interf (fun _ u v -> meet_filter (meet u v)) a b)
| Field a , Field b ->
- meet_field (Fmap.interf (fun _ u v -> meet_filter (meet u v)) a b)
+ meet_field (Fmap.interf (fun _ u v -> meet_filter (meet u v)) a b)
| (Index _ | Array _) , Field _
| Field _ , (Index _ | Array _)
-> Bot
@@ -196,7 +196,7 @@ struct
let pretty fmt = function
| E -> Format.pp_print_string fmt "empty"
| X(x,ds) ->
- Format.fprintf fmt "%a(%a)@." F.pp_var x Usage.pretty (delta ds)
+ Format.fprintf fmt "%a(%a)@." F.pp_var x Usage.pretty (delta ds)
| D dom -> Domain.pretty fmt dom
[@@@ warning "+32"]
@@ -208,17 +208,17 @@ struct
let getindex ~mu v k = match v with
| X(x,ds) ->
- begin match F.repr k with
- | Kint z ->
- let d =
- try Dindex(Integer.to_int_exn z) with Z.Overflow -> Darray in
- X( x , ds @ [ d ] )
- | _ ->
- let ds = ds @ [ Darray ] in
- let dk = mu k in
- if Domain.is_empty dk then X(x,ds)
- else D (Domain.join (path x ds) dk)
- end
+ begin match F.repr k with
+ | Kint z ->
+ let d =
+ try Dindex(Integer.to_int_exn z) with Z.Overflow -> Darray in
+ X( x , ds @ [ d ] )
+ | _ ->
+ let ds = ds @ [ Darray ] in
+ let dk = mu k in
+ if Domain.is_empty dk then X(x,ds)
+ else D (Domain.join (path x ds) dk)
+ end
| D d -> D (Domain.join d (mu k))
| E -> D (mu k)
@@ -235,13 +235,13 @@ struct
match F.repr e with
| L.True | L.False | L.Kint _ | L.Kreal _ -> E
| _ ->
- let result = match F.repr e with
- | L.Rget( r , f ) -> getfield (compute env r) f
- | L.Aget( r , k ) -> getindex ~mu:(domain env) (compute env r) k
- | L.Fvar x -> X(x,[])
- | L.Fun(f,_) -> D (subterms env (symbol f) e)
- | _ -> D (subterms env Domain.empty e)
- in env.mvalue <- Tmap.add e result env.mvalue ; result
+ let result = match F.repr e with
+ | L.Rget( r , f ) -> getfield (compute env r) f
+ | L.Aget( r , k ) -> getindex ~mu:(domain env) (compute env r) k
+ | L.Fvar x -> X(x,[])
+ | L.Fun(f,_) -> D (subterms env (symbol f) e)
+ | _ -> D (subterms env Domain.empty e)
+ in env.mvalue <- Tmap.add e result env.mvalue ; result
and subterms env d0 e =
let pool = ref d0 in
@@ -255,8 +255,8 @@ struct
| E -> Domain.empty
| D dom -> dom
| X(x,ds) ->
- let dom = path x ds in
- env.mdomain <- Tmap.add e dom env.mdomain ; dom
+ let dom = path x ds in
+ env.mdomain <- Tmap.add e dom env.mdomain ; dom
end
@@ -276,13 +276,13 @@ struct
match F.p_expr p with
| And ps | Or ps -> List.iter (collect_hyp env) ps
| Imply(hs,p) ->
- List.iter (collect_hyp env) hs ;
- collect_hyp env p
+ List.iter (collect_hyp env) hs ;
+ collect_hyp env p
| _ ->
- let dp = Value.domain env.usage (F.e_prop p) in
- if not (Domain.separated dp env.target)
- then
- ( env.target <- Domain.join dp env.target )
+ let dp = Value.domain env.usage (F.e_prop p) in
+ if not (Domain.separated dp env.target)
+ then
+ ( env.target <- Domain.join dp env.target )
let rec collect_seq env s = Conditions.iter (collect_step env) s
and collect_step env s =
@@ -292,11 +292,11 @@ struct
| Core p | Have p | When p | Init p -> collect_hyp env p
| Either cs -> List.iter (collect_seq env) cs
| Branch(p,a,b) ->
- begin
- collect_hyp env p ;
- collect_seq env a ;
- collect_seq env b ;
- end
+ begin
+ collect_hyp env p ;
+ collect_seq env a ;
+ collect_seq env b ;
+ end
let rec fixpoint env sequence =
let d0 = env.target in
diff --git a/src/plugins/wp/Generator.ml b/src/plugins/wp/Generator.ml
index 0cf4ea60e130dfeb02a125c0dfcf7c77fb246285..af50076db5cde4c0ebdbf234c397959f4e5bb400 100644
--- a/src/plugins/wp/Generator.ml
+++ b/src/plugins/wp/Generator.ml
@@ -28,41 +28,41 @@ let user_setup () : Factory.setup =
begin
match Wp_parameters.Model.get () with
| ["Runtime"] ->
- Wp_parameters.abort
- "Model 'Runtime' is no more available.@\nIt will be reintroduced \
- in a future release."
+ Wp_parameters.abort
+ "Model 'Runtime' is no more available.@\nIt will be reintroduced \
+ in a future release."
| ["Logic"] ->
- Wp_parameters.warning ~once:true
- "Deprecated 'Logic' model.@\nUse 'Typed' with option '-wp-ref' \
- instead." ;
- {
- mheap = Factory.Typed MemTyped.Fits ;
- mvar = Factory.Ref ;
- cint = Cint.Natural ;
- cfloat = Cfloat.Real ;
- }
+ Wp_parameters.warning ~once:true
+ "Deprecated 'Logic' model.@\nUse 'Typed' with option '-wp-ref' \
+ instead." ;
+ {
+ mheap = Factory.Typed MemTyped.Fits ;
+ mvar = Factory.Ref ;
+ cint = Cint.Natural ;
+ cfloat = Cfloat.Real ;
+ }
| ["Store"] ->
- Wp_parameters.warning ~once:true
- "Deprecated 'Store' model.@\nUse 'Typed' instead." ;
- {
- mheap = Factory.Typed MemTyped.Fits ;
- mvar = Factory.Var ;
- cint = Cint.Natural ;
- cfloat = Cfloat.Real ;
- }
+ Wp_parameters.warning ~once:true
+ "Deprecated 'Store' model.@\nUse 'Typed' instead." ;
+ {
+ mheap = Factory.Typed MemTyped.Fits ;
+ mvar = Factory.Var ;
+ cint = Cint.Natural ;
+ cfloat = Cfloat.Real ;
+ }
| spec ->
- let setup = Factory.parse spec in
- let mref = match setup.mvar with
- | Caveat -> "caveat" | Ref -> "ref" | Raw | Var -> "" in
- if mref <> ""
- && RefUsage.has_nullable ()
- && not (Wp_parameters.RTE.is_set ())
- then
- Wp_parameters.warning ~current:false ~once:true
- "In %s model with nullable arguments, \
- -wp-(no)-rte shall be explicitly positioned."
- mref ;
- setup
+ let setup = Factory.parse spec in
+ let mref = match setup.mvar with
+ | Caveat -> "caveat" | Ref -> "ref" | Raw | Var -> "" in
+ if mref <> ""
+ && RefUsage.has_nullable ()
+ && not (Wp_parameters.RTE.is_set ())
+ then
+ Wp_parameters.warning ~current:false ~once:true
+ "In %s model with nullable arguments, \
+ -wp-(no)-rte shall be explicitly positioned."
+ mref ;
+ setup
end
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/GuiComposer.ml b/src/plugins/wp/GuiComposer.ml
index 69f26e46f87ebc74cf41b20ba1e004c129c15c28..86970e9033eb2fabbe80046409de166fe7dde7aa 100644
--- a/src/plugins/wp/GuiComposer.ml
+++ b/src/plugins/wp/GuiComposer.ml
@@ -30,8 +30,8 @@ let peek n s =
match s with
| [] -> raise Not_found
| e::s ->
- let es,s = prefix (pred n) s in
- e :: es , s
+ let es,s = prefix (pred n) s in
+ e :: es , s
in try Some(prefix n s) with Not_found -> None
class composer (focused : GuiSequent.focused) =
@@ -53,31 +53,31 @@ class composer (focused : GuiSequent.focused) =
let open Tactical in
match v with
| Compose(Code _) | Inside _ | Clause _ ->
- Format.fprintf fmt "@ @{<fg:grey>(%a)@}" self#pp_typeof v
+ Format.fprintf fmt "@ @{<fg:grey>(%a)@}" self#pp_typeof v
| _ -> ()
end
method private pp_select cc args ~quit fmt =
match args with
| e::_ when cc#is_valid e ->
- let callback () = cc#set_value e ; quit () in
- Format.fprintf fmt "%t @{<it>and quit composer@}@\n"
- (focused#button ~title:"Select A" ~callback)
+ let callback () = cc#set_value e ; quit () in
+ Format.fprintf fmt "%t @{<it>and quit composer@}@\n"
+ (focused#button ~title:"Select A" ~callback)
| _ -> ()
method private pp_range cc args ~quit fmt =
match args with
| a::b::_ when cc#ranged ->
- begin
- match Tactical.get_int a, Tactical.get_int b with
- | Some a,Some b when a <= b ->
- let callback () =
- cc#set_value (Tactical.range a b) ;
- quit () in
- Format.fprintf fmt "%t @{<it>for range selection@}@\n"
- (focused#button ~title:"Select A..B" ~callback)
- | _ -> ()
- end
+ begin
+ match Tactical.get_int a, Tactical.get_int b with
+ | Some a,Some b when a <= b ->
+ let callback () =
+ cc#set_value (Tactical.range a b) ;
+ quit () in
+ Format.fprintf fmt "%t @{<it>for range selection@}@\n"
+ (focused#button ~title:"Select A..B" ~callback)
+ | _ -> ()
+ end
| _ -> ()
@@ -91,34 +91,34 @@ class composer (focused : GuiSequent.focused) =
method private op1 title job args fmt = match args with
| a::w ->
- let callback () =
- stack <- job a w ; ignore focused#unselect ; update () in
- focused#button ~title ~callback fmt
+ let callback () =
+ stack <- job a w ; ignore focused#unselect ; update () in
+ focused#button ~title ~callback fmt
| _ -> ()
method private op2 title job args fmt = match args with
| a::b::w ->
- let callback () =
- stack <- job a b w ; ignore focused#unselect ; update () in
- focused#button ~title ~callback fmt
+ let callback () =
+ stack <- job a b w ; ignore focused#unselect ; update () in
+ focused#button ~title ~callback fmt
| _ -> ()
method private op3 title job args fmt = match args with
| a::b::c::w ->
- let callback () =
- stack <- job a b c w ; ignore focused#unselect ; update () in
- focused#button ~title ~callback fmt
+ let callback () =
+ stack <- job a b c w ; ignore focused#unselect ; update () in
+ focused#button ~title ~callback fmt
| _ -> ()
method private destruct args fmt = match args with
| a::w ->
- let ps = Tactical.destruct a in
- if ps <> [] then
- let callback () =
- stack <- ps @ w ; update () in
- Format.fprintf fmt
- "%t @{<it>Decompose into (selectable) sub-terms@}@\n"
- (focused#button ~title:"Destruct A" ~callback)
+ let ps = Tactical.destruct a in
+ if ps <> [] then
+ let callback () =
+ stack <- ps @ w ; update () in
+ Format.fprintf fmt
+ "%t @{<it>Decompose into (selectable) sub-terms@}@\n"
+ (focused#button ~title:"Destruct A" ~callback)
| _ -> ()
val mutable stacked = true
@@ -129,29 +129,29 @@ class composer (focused : GuiSequent.focused) =
match peek cc#arity args with
| None -> ()
| Some (es,tail) ->
- let vs = List.map Tactical.selected es in
- if cc#filter vs then
- begin
- let callback () =
- let s = Tactical.compose cc#id es in
- stack <- if es = [] then tail @ [s] else s :: tail ;
- ignore focused#unselect ;
- update () in
- let button = focused#button ~title:cc#title ~callback in
- let descr = cc#descr in
- if descr = "" then
- ( if not stacked && cc#group <> group then
- Format.pp_print_newline fmt () ;
- button fmt ;
- stacked <- false )
- else
- begin
- if not stacked then Format.pp_print_newline fmt () ;
- Format.fprintf fmt "%t @{<it>%s@}@\n" button descr ;
- stacked <- true
- end ;
- group <- cc#group
- end
+ let vs = List.map Tactical.selected es in
+ if cc#filter vs then
+ begin
+ let callback () =
+ let s = Tactical.compose cc#id es in
+ stack <- if es = [] then tail @ [s] else s :: tail ;
+ ignore focused#unselect ;
+ update () in
+ let button = focused#button ~title:cc#title ~callback in
+ let descr = cc#descr in
+ if descr = "" then
+ ( if not stacked && cc#group <> group then
+ Format.pp_print_newline fmt () ;
+ button fmt ;
+ stacked <- false )
+ else
+ begin
+ if not stacked then Format.pp_print_newline fmt () ;
+ Format.fprintf fmt "%t @{<it>%s@}@\n" button descr ;
+ stacked <- true
+ end ;
+ group <- cc#group
+ end
method private hrule fmt =
if not stacked then Format.pp_print_newline fmt () ;
@@ -194,7 +194,7 @@ class composer (focused : GuiSequent.focused) =
stack <-
begin match current with
| Tactical.Compose(Tactical.Range(a,b)) ->
- [ Tactical.int a ; Tactical.int b ]
+ [ Tactical.int a ; Tactical.int b ]
| _ -> [current] end ;
update () in
Format.fprintf fmt "Current: @[<hov 2>%a@]@."
diff --git a/src/plugins/wp/GuiGoal.ml b/src/plugins/wp/GuiGoal.ml
index c04201773562b945cbee00f0a703ec94995afe62..2bb79c67be70f5bf7de915916898a0eac3ceb83e 100644
--- a/src/plugins/wp/GuiGoal.ml
+++ b/src/plugins/wp/GuiGoal.ml
@@ -189,35 +189,35 @@ class pane (gprovers : GuiConfig.provers) =
method private compose cc =
match state with
| Proof proof ->
- composer#clear ;
- let tgt = printer#unselect in
- state <- Composer(proof,cc,tgt) ;
- self#update
+ composer#clear ;
+ let tgt = printer#unselect in
+ state <- Composer(proof,cc,tgt) ;
+ self#update
| _ -> ()
method private browse cc =
match state with
| Proof proof ->
- browser#clear ;
- let tgt = printer#unselect in
- state <- Browser(proof,cc,tgt) ;
- self#update
+ browser#clear ;
+ let tgt = printer#unselect in
+ state <- Browser(proof,cc,tgt) ;
+ self#update
| _ -> ()
method private interrupt cancel =
match state with
| Empty -> ()
| Proof proof | Composer(proof,_,_) | Browser(proof,_,_) ->
- cancel proof ;
- printer#reset ;
- self#update
+ cancel proof ;
+ printer#reset ;
+ self#update
| Forking (proof,_,pool) ->
- cancel proof ;
- Task.iter Task.cancel pool ;
- state <- Proof proof ;
- ProofEngine.forward proof ;
- printer#reset ;
- self#update
+ cancel proof ;
+ Task.iter Task.cancel pool ;
+ state <- Proof proof ;
+ ProofEngine.forward proof ;
+ printer#reset ;
+ self#update
method private forward =
match state with
@@ -233,41 +233,41 @@ class pane (gprovers : GuiConfig.provers) =
match state with
| Empty | Forking _ | Composer _ | Browser _ -> ()
| Proof p ->
- match ProofEngine.current p with
- | `Leaf (k,_) -> ProofEngine.goto p (`Leaf(f k)) ; self#update
- | `Main | `Internal _ -> ()
+ match ProofEngine.current p with
+ | `Leaf (k,_) -> ProofEngine.goto p (`Leaf(f k)) ; self#update
+ | `Main | `Internal _ -> ()
method private iformat f = printer#set_iformat f ; self#update
method private rformat f = printer#set_rformat f ; self#update
method private autofocus = function
| `Autofocus ->
- printer#set_focus_mode true ;
- printer#set_state_mode true ;
- self#update
+ printer#set_focus_mode true ;
+ printer#set_state_mode true ;
+ self#update
| `ViewRaw ->
- printer#set_focus_mode false ;
- printer#set_state_mode false ;
- self#update
+ printer#set_focus_mode false ;
+ printer#set_state_mode false ;
+ self#update
| `ViewModel ->
- printer#set_focus_mode true ;
- printer#set_state_mode false ;
- self#update
+ printer#set_focus_mode true ;
+ printer#set_state_mode false ;
+ self#update
| `ViewAll ->
- printer#set_focus_mode false ;
- printer#set_state_mode true ;
- self#update
+ printer#set_focus_mode false ;
+ printer#set_state_mode true ;
+ self#update
| `Refresh ->
- helpmode <- false ;
- printer#reset ;
- let mode =
- match printer#get_focus_mode , printer#get_state_mode with
- | true , true -> `Autofocus
- | false , false -> `ViewRaw
- | true , false -> `ViewModel
- | false , true -> `ViewAll
- in
- autofocus#set mode ; self#update
+ helpmode <- false ;
+ printer#reset ;
+ let mode =
+ match printer#get_focus_mode , printer#get_state_mode with
+ | true , true -> `Autofocus
+ | false , false -> `ViewRaw
+ | true , false -> `ViewModel
+ | false , true -> `ViewAll
+ in
+ autofocus#set mode ; self#update
method private provers =
(List.map (fun dp -> VCS.Why3 dp)
@@ -276,30 +276,30 @@ class pane (gprovers : GuiConfig.provers) =
method private play_script =
match state with
| Proof p ->
- ProofEngine.reset p ;
- ProverScript.spawn
- ~provers:self#provers
- ~result:
- (fun wpo prv res ->
- text#printf "[%a] %a : %a@."
- VCS.pp_prover prv Wpo.pp_title wpo VCS.pp_result res)
- ~success:
- (fun _ _ ->
- ProofEngine.forward p ;
- self#update)
- (ProofEngine.main p) ;
- let server = ProverTask.server () in
- Task.launch server
+ ProofEngine.reset p ;
+ ProverScript.spawn
+ ~provers:self#provers
+ ~result:
+ (fun wpo prv res ->
+ text#printf "[%a] %a : %a@."
+ VCS.pp_prover prv Wpo.pp_title wpo VCS.pp_result res)
+ ~success:
+ (fun _ _ ->
+ ProofEngine.forward p ;
+ self#update)
+ (ProofEngine.main p) ;
+ let server = ProverTask.server () in
+ Task.launch server
| Empty | Forking _ | Composer _ | Browser _ -> ()
method private save_script =
match state with
| Proof p ->
- let main = ProofEngine.main p in
- let json = ProofScript.encode (ProofEngine.script p) in
- ProofSession.save main json ;
- ProofEngine.set_saved p true ;
- self#update
+ let main = ProofEngine.main p in
+ let json = ProofScript.encode (ProofEngine.script p) in
+ ProofSession.save main json ;
+ ProofEngine.set_saved p true ;
+ self#update
(*
text#clear ;
text#printf "@{<bf>Session:@} '%a'@." ProofSession.pretty main ;
@@ -347,23 +347,23 @@ class pane (gprovers : GuiConfig.provers) =
method select = function
| None ->
- state <- Empty ; self#update
+ state <- Empty ; self#update
| Some w ->
- let pw = ProofEngine.proof ~main:w in
- let changed = match state with
- | Empty -> true
- | Proof p -> p != pw
- | Forking _ | Composer _ | Browser _ -> false
- in
- if changed then
- begin
- printer#reset ;
- self#update_provers None ;
- self#update_tactics None ;
- state <- Proof pw ;
- ProofEngine.forward pw ;
- self#update ;
- end
+ let pw = ProofEngine.proof ~main:w in
+ let changed = match state with
+ | Empty -> true
+ | Proof p -> p != pw
+ | Forking _ | Composer _ | Browser _ -> false
+ in
+ if changed then
+ begin
+ printer#reset ;
+ self#update_provers None ;
+ self#update_tactics None ;
+ state <- Proof pw ;
+ ProofEngine.forward pw ;
+ self#update ;
+ end
(* ---------------------------------------------------------------------- *)
(* --- Repaint --- *)
@@ -373,216 +373,216 @@ class pane (gprovers : GuiConfig.provers) =
method private update_provers = function
| None ->
- List.iter (fun prover -> prover#clear) provers
+ List.iter (fun prover -> prover#clear) provers
| Some wpo ->
- List.iter (fun prover -> prover#update wpo) provers
+ List.iter (fun prover -> prover#update wpo) provers
method private update_tactics = function
| None ->
- printer#set_target Tactical.Empty ;
- strategies#connect None ;
- List.iter (fun tactic -> tactic#clear) tactics
+ printer#set_target Tactical.Empty ;
+ strategies#connect None ;
+ List.iter (fun tactic -> tactic#clear) tactics
| Some(tree,sequent,sel) ->
- on_proof_context tree
- begin fun () ->
- strategies#connect (Some (self#strategies sequent)) ;
- let select (tactic : GuiTactic.tactic) =
- let process = self#apply in
- let composer = self#compose in
- let browser = self#browse in
- tactic#select ~process ~composer ~browser ~tree sel
- in
- List.iter select tactics ;
- let tgt =
- if List.exists (fun tactics -> tactics#targeted) tactics
- then sel else Tactical.Empty in
- printer#set_target tgt
- end ()
+ on_proof_context tree
+ begin fun () ->
+ strategies#connect (Some (self#strategies sequent)) ;
+ let select (tactic : GuiTactic.tactic) =
+ let process = self#apply in
+ let composer = self#compose in
+ let browser = self#browse in
+ tactic#select ~process ~composer ~browser ~tree sel
+ in
+ List.iter select tactics ;
+ let tgt =
+ if List.exists (fun tactics -> tactics#targeted) tactics
+ then sel else Tactical.Empty in
+ printer#set_target tgt
+ end ()
method private update_scriptbar =
match state with
| Empty | Forking _ ->
- begin
- save_script#set_enabled false ;
- play_script#set_enabled false ;
- end
+ begin
+ save_script#set_enabled false ;
+ play_script#set_enabled false ;
+ end
| Proof proof | Composer(proof,_,_) | Browser(proof,_,_) ->
- begin
- let main = ProofEngine.main proof in
- let play = ProofSession.exists main in
- let save = not (ProofEngine.saved proof) in
- play_script#set_enabled play ;
- save_script#set_enabled save ;
- end
+ begin
+ let main = ProofEngine.main proof in
+ let play = ProofSession.exists main in
+ let save = not (ProofEngine.saved proof) in
+ play_script#set_enabled play ;
+ save_script#set_enabled save ;
+ end
method private update_pending kind proof n =
match ProofEngine.current proof with
| `Main | `Internal _ ->
- next#set_enabled false ;
- prev#set_enabled false ;
- if n = 1 then
- Pretty_utils.ksfprintf status#set_text "One %s Goal" kind
- else
- Pretty_utils.ksfprintf status#set_text "%d %s Goals" n kind
+ next#set_enabled false ;
+ prev#set_enabled false ;
+ if n = 1 then
+ Pretty_utils.ksfprintf status#set_text "One %s Goal" kind
+ else
+ Pretty_utils.ksfprintf status#set_text "%d %s Goals" n kind
| `Leaf(k,_) ->
- prev#set_enabled (0 < k) ;
- next#set_enabled (k+1 < n) ;
- if k = 0 && n = 1 then
- Pretty_utils.ksfprintf status#set_text
- "Last %s Goal" kind
- else
- Pretty_utils.ksfprintf status#set_text
- "%s Goal #%d /%d" kind (succ k) n
+ prev#set_enabled (0 < k) ;
+ next#set_enabled (k+1 < n) ;
+ if k = 0 && n = 1 then
+ Pretty_utils.ksfprintf status#set_text
+ "Last %s Goal" kind
+ else
+ Pretty_utils.ksfprintf status#set_text
+ "%s Goal #%d /%d" kind (succ k) n
method private update_statusbar =
match state with
| Empty ->
- begin
- icon#set_icon GuiProver.no_status ;
+ begin
+ icon#set_icon GuiProver.no_status ;
+ next#set_enabled false ;
+ prev#set_enabled false ;
+ cancel#set_enabled false ;
+ delete#set_enabled false ;
+ forward#set_enabled false ;
+ status#set_text "No Status" ;
+ help#set_enabled false ;
+ end
+ | Proof proof | Forking(proof,_,_)
+ | Composer(proof,_,_) | Browser(proof,_,_) ->
+ begin
+ let nofork = match state with Forking _ -> false | _ -> true in
+ delete#set_enabled nofork ;
+ help#set_enabled
+ (match state with Proof _ -> not helpmode | _ -> false) ;
+ match ProofEngine.status proof with
+ | `Unproved ->
+ icon#set_icon GuiProver.ko_status ;
next#set_enabled false ;
prev#set_enabled false ;
cancel#set_enabled false ;
- delete#set_enabled false ;
forward#set_enabled false ;
- status#set_text "No Status" ;
- help#set_enabled false ;
- end
- | Proof proof | Forking(proof,_,_)
- | Composer(proof,_,_) | Browser(proof,_,_) ->
- begin
- let nofork = match state with Forking _ -> false | _ -> true in
- delete#set_enabled nofork ;
- help#set_enabled
- (match state with Proof _ -> not helpmode | _ -> false) ;
- match ProofEngine.status proof with
- | `Unproved ->
- icon#set_icon GuiProver.ko_status ;
- next#set_enabled false ;
- prev#set_enabled false ;
- cancel#set_enabled false ;
- forward#set_enabled false ;
- status#set_text "Non Proved Property" ;
- | `Invalid | `StillResist 0 ->
- icon#set_icon GuiProver.wg_status ;
- next#set_enabled false ;
- prev#set_enabled false ;
- cancel#set_enabled false ;
- forward#set_enabled false ;
- status#set_text "Invalid Smoke-test" ;
- | `Passed ->
- icon#set_icon GuiProver.smoke_status ;
- next#set_enabled false ;
- prev#set_enabled false ;
- cancel#set_enabled false ;
- forward#set_enabled false ;
- status#set_text "Passed Smoke Test" ;
- | `Proved ->
- icon#set_icon GuiProver.ok_status ;
- next#set_enabled false ;
- prev#set_enabled false ;
- cancel#set_enabled false ;
- forward#set_enabled false ;
- status#set_text "Proved Goal" ;
- | `Pending 0 ->
- icon#set_icon GuiProver.ok_status ;
- next#set_enabled false ;
- prev#set_enabled false ;
- forward#set_enabled false ;
- cancel#set_enabled nofork ;
- status#set_text "Proof Terminated" ;
- | `Pending n ->
- icon#set_icon GuiProver.ko_status ;
- forward#set_enabled nofork ;
- cancel#set_enabled nofork ;
- self#update_pending "Pending" proof n ;
- | `StillResist n ->
- icon#set_icon GuiProver.smoke_status ;
- forward#set_enabled nofork ;
- cancel#set_enabled nofork ;
- self#update_pending "Smoking" proof n ;
- end
+ status#set_text "Non Proved Property" ;
+ | `Invalid | `StillResist 0 ->
+ icon#set_icon GuiProver.wg_status ;
+ next#set_enabled false ;
+ prev#set_enabled false ;
+ cancel#set_enabled false ;
+ forward#set_enabled false ;
+ status#set_text "Invalid Smoke-test" ;
+ | `Passed ->
+ icon#set_icon GuiProver.smoke_status ;
+ next#set_enabled false ;
+ prev#set_enabled false ;
+ cancel#set_enabled false ;
+ forward#set_enabled false ;
+ status#set_text "Passed Smoke Test" ;
+ | `Proved ->
+ icon#set_icon GuiProver.ok_status ;
+ next#set_enabled false ;
+ prev#set_enabled false ;
+ cancel#set_enabled false ;
+ forward#set_enabled false ;
+ status#set_text "Proved Goal" ;
+ | `Pending 0 ->
+ icon#set_icon GuiProver.ok_status ;
+ next#set_enabled false ;
+ prev#set_enabled false ;
+ forward#set_enabled false ;
+ cancel#set_enabled nofork ;
+ status#set_text "Proof Terminated" ;
+ | `Pending n ->
+ icon#set_icon GuiProver.ko_status ;
+ forward#set_enabled nofork ;
+ cancel#set_enabled nofork ;
+ self#update_pending "Pending" proof n ;
+ | `StillResist n ->
+ icon#set_icon GuiProver.smoke_status ;
+ forward#set_enabled nofork ;
+ cancel#set_enabled nofork ;
+ self#update_pending "Smoking" proof n ;
+ end
method private update_tacticbar =
match state with
| Empty | Forking _ ->
- self#update_provers None ;
- self#update_tactics None ;
+ self#update_provers None ;
+ self#update_tactics None ;
| Proof proof ->
- let wpo = ProofEngine.head proof in
- begin
- self#update_provers (Some wpo) ;
- let sequent = printer#sequent in
- let select = printer#selection in
- self#update_tactics (Some(proof,sequent,select)) ;
- end
+ let wpo = ProofEngine.head proof in
+ begin
+ self#update_provers (Some wpo) ;
+ let sequent = printer#sequent in
+ let select = printer#selection in
+ self#update_tactics (Some(proof,sequent,select)) ;
+ end
| Composer _ | Browser _ -> ()
method private update_proofview =
match state with
| Empty -> text#clear
| Proof _ when helpmode ->
- begin
+ begin
+ text#clear ;
+ let callback () = self#quit_help in
+ text#printf "@\n@{<bf>Available Tactics:@} %t@\n@\n"
+ (printer#button ~title:"Close" ~callback) ;
+ text#hrule ;
+ let pp_item pp fmt tac =
+ Format.fprintf fmt "[ @{<bf>%a@} ] @{<it>%s@}@\n"
+ pp tac#title tac#descr in
+ Pretty_utils.pp_items
+ ~title:(fun tac -> tac#title)
+ ~iter:Tactical.iter
+ ~pp_item text#fmt ;
+ text#hrule ;
+ end
+ | Proof proof ->
+ on_proof_context proof
+ begin fun () ->
text#clear ;
- let callback () = self#quit_help in
- text#printf "@\n@{<bf>Available Tactics:@} %t@\n@\n"
- (printer#button ~title:"Close" ~callback) ;
+ let main = ProofEngine.main proof in
+ if ProofSession.exists main then
+ text#printf
+ (if ProofEngine.saved proof
+ then "%a (@{<green>saved@})@."
+ else "%a (@{<orange>modified@})@.")
+ ProofSession.pp_script_for main
+ else
+ text#printf "%a (@{<blue>not created@})@."
+ ProofSession.pp_script_for main ;
text#hrule ;
- let pp_item pp fmt tac =
- Format.fprintf fmt "[ @{<bf>%a@} ] @{<it>%s@}@\n"
- pp tac#title tac#descr in
- Pretty_utils.pp_items
- ~title:(fun tac -> tac#title)
- ~iter:Tactical.iter
- ~pp_item text#fmt ;
+ scripter#tree proof ;
text#hrule ;
- end
- | Proof proof ->
- on_proof_context proof
- begin fun () ->
- text#clear ;
- let main = ProofEngine.main proof in
- if ProofSession.exists main then
- text#printf
- (if ProofEngine.saved proof
- then "%a (@{<green>saved@})@."
- else "%a (@{<orange>modified@})@.")
- ProofSession.pp_script_for main
- else
- text#printf "%a (@{<blue>not created@})@."
- ProofSession.pp_script_for main ;
- text#hrule ;
- scripter#tree proof ;
- text#hrule ;
- text#printf "%t@." (printer#goal (ProofEngine.head proof)) ;
- text#printf "@{<bf>Goal id:@} %s@." main.po_gid ;
- text#printf "@{<bf>Short id:@} %s@." main.po_sid ;
- text#hrule ;
- scripter#status proof ;
- end ()
+ text#printf "%t@." (printer#goal (ProofEngine.head proof)) ;
+ text#printf "@{<bf>Goal id:@} %s@." main.po_gid ;
+ text#printf "@{<bf>Short id:@} %s@." main.po_sid ;
+ text#hrule ;
+ scripter#status proof ;
+ end ()
| Composer(proof,cc,tgt) ->
- on_proof_context proof
- begin fun () ->
- text#clear ;
- let quit () =
- state <- Proof proof ;
- printer#restore tgt ;
- self#update in
- text#printf "%t@." (composer#print cc ~quit) ;
- text#hrule ;
- text#printf "%t@." (printer#goal (ProofEngine.head proof)) ;
- end ()
+ on_proof_context proof
+ begin fun () ->
+ text#clear ;
+ let quit () =
+ state <- Proof proof ;
+ printer#restore tgt ;
+ self#update in
+ text#printf "%t@." (composer#print cc ~quit) ;
+ text#hrule ;
+ text#printf "%t@." (printer#goal (ProofEngine.head proof)) ;
+ end ()
| Browser(proof,cc,tgt) ->
- on_proof_context proof
- begin fun () ->
- text#clear ;
- let quit () =
- state <- Proof proof ;
- printer#restore tgt ;
- self#update in
- text#printf "%t@." (browser#print cc ~quit) ;
- text#hrule ;
- text#printf "%t@." (printer#goal (ProofEngine.head proof)) ;
- end ()
+ on_proof_context proof
+ begin fun () ->
+ text#clear ;
+ let quit () =
+ state <- Proof proof ;
+ printer#restore tgt ;
+ self#update in
+ text#printf "%t@." (browser#print cc ~quit) ;
+ text#hrule ;
+ text#printf "%t@." (printer#goal (ProofEngine.head proof)) ;
+ end ()
| Forking _ -> ()
method update =
@@ -601,18 +601,18 @@ class pane (gprovers : GuiConfig.provers) =
match state with
| Empty | Proof _ | Composer _ | Browser _ -> ()
| Forking(proof,fork,pool) ->
- let n = Task.size pool in
- if n = 0 then
- begin
- ignore (ProofEngine.commit fork) ;
- ProofEngine.validate proof ;
- ProofEngine.forward proof ;
- state <- Proof proof ;
- printer#reset ;
- self#update ;
- end
- else
- Wutil.later self#commit
+ let n = Task.size pool in
+ if n = 0 then
+ begin
+ ignore (ProofEngine.commit fork) ;
+ ProofEngine.validate proof ;
+ ProofEngine.forward proof ;
+ state <- Proof proof ;
+ printer#reset ;
+ self#update ;
+ end
+ else
+ Wutil.later self#commit
method private schedule pool provers goal =
Prover.spawn goal
@@ -646,16 +646,16 @@ class pane (gprovers : GuiConfig.provers) =
match state with
| Empty | Forking _ | Composer _ | Browser _ -> ()
| Proof proof ->
- Wutil.later
- begin fun () ->
- let title = tactic#title in
- try
- let tactic = ProofScript.jtactic ~title tactic selection in
- let anchor = ProofEngine.anchor proof () in
- self#fork proof (ProofEngine.fork proof ~anchor tactic process)
- with Exit | Not_found | Invalid_argument _ ->
- text#printf "Application of tactic '%s' failed." title
- end
+ Wutil.later
+ begin fun () ->
+ let title = tactic#title in
+ try
+ let tactic = ProofScript.jtactic ~title tactic selection in
+ let anchor = ProofEngine.anchor proof () in
+ self#fork proof (ProofEngine.fork proof ~anchor tactic process)
+ with Exit | Not_found | Invalid_argument _ ->
+ text#printf "Application of tactic '%s' failed." title
+ end
method private search proof = function
| None -> text#printf "No tactic found.@\n"
@@ -665,43 +665,43 @@ class pane (gprovers : GuiConfig.provers) =
match state with
| Empty | Forking _ | Composer _ | Browser _ -> ()
| Proof proof ->
- Wutil.later
- begin fun () ->
- if depth <= 1 then
- let fork = ProverSearch.search proof ~sequent auto in
- self#search proof fork
- else
- begin
- let provers = List.map (fun e -> e#prover) provers in
- ProverScript.search
- ~depth ~width ~auto
- ~provers
- ~result:
- (fun wpo prv res ->
- text#printf "[%a] %a : %a@."
- VCS.pp_prover prv
- Wpo.pp_title wpo
- VCS.pp_result res)
- ~success:
- (fun _ _ ->
- ProofEngine.forward proof ;
- self#update ;
- text#printf "Strategies Applied." )
- proof (ProofEngine.anchor proof ()) ;
- let server = ProverTask.server () in
- Task.launch server
- end
- end
+ Wutil.later
+ begin fun () ->
+ if depth <= 1 then
+ let fork = ProverSearch.search proof ~sequent auto in
+ self#search proof fork
+ else
+ begin
+ let provers = List.map (fun e -> e#prover) provers in
+ ProverScript.search
+ ~depth ~width ~auto
+ ~provers
+ ~result:
+ (fun wpo prv res ->
+ text#printf "[%a] %a : %a@."
+ VCS.pp_prover prv
+ Wpo.pp_title wpo
+ VCS.pp_result res)
+ ~success:
+ (fun _ _ ->
+ ProofEngine.forward proof ;
+ self#update ;
+ text#printf "Strategies Applied." )
+ proof (ProofEngine.anchor proof ()) ;
+ let server = ProverTask.server () in
+ Task.launch server
+ end
+ end
method private backtrack node =
match state with
| Empty | Forking _ | Composer _ | Browser _ -> ()
| Proof proof ->
- begin
- ProofEngine.goto proof (`Node node) ;
- let fork =
- ProverSearch.backtrack proof ~anchor:node ~loop:true () in
- self#search proof fork
- end
+ begin
+ ProofEngine.goto proof (`Node node) ;
+ let fork =
+ ProverSearch.backtrack proof ~anchor:node ~loop:true () in
+ self#search proof fork
+ end
end
diff --git a/src/plugins/wp/GuiList.ml b/src/plugins/wp/GuiList.ml
index 5db3d2b3246d8776a21304559f7179cd4032057b..dd89570668a3baa0e6533295d8379d90ce390117 100644
--- a/src/plugins/wp/GuiList.ml
+++ b/src/plugins/wp/GuiList.ml
@@ -63,16 +63,16 @@ let render_prover_result p =
match Wpo.get_result w p , p with
| { verdict=NoResult } , Qed -> icn_na
| { verdict=NoResult } , Tactical ->
- begin
- match ProverScript.get w with
- | `None -> icn_na
- | `Script -> icn_stock "gtk-media-play"
- | `Proof -> icn_stock "gtk-edit"
- | `Saved -> icn_stock "gtk-file"
- end
+ begin
+ match ProverScript.get w with
+ | `None -> icn_na
+ | `Script -> icn_stock "gtk-media-play"
+ | `Proof -> icn_stock "gtk-edit"
+ | `Saved -> icn_stock "gtk-file"
+ end
| result , _ ->
- let smoke = Wpo.is_smoke_test w in
- icon_of_verdict (VCS.verdict ~smoke result)
+ let smoke = Wpo.is_smoke_test w in
+ icon_of_verdict (VCS.verdict ~smoke result)
class pane (gprovers:GuiConfig.provers) =
let model = new model in
@@ -124,8 +124,8 @@ class pane (gprovers:GuiConfig.provers) =
(fun (vcs,column) ->
match vcs with
| VCS.Why3 p ->
- column#set_visible (Why3.Whyconf.Sprover.mem p dps) ;
- (* ignore (list#view#remove_column column) *)
+ column#set_visible (Why3.Whyconf.Sprover.mem p dps) ;
+ (* ignore (list#view#remove_column column) *)
| _ -> ()
) provers ;
(* Installing Missing Columns *)
diff --git a/src/plugins/wp/GuiNavigator.ml b/src/plugins/wp/GuiNavigator.ml
index d92911dc44128a9145abc4e61097cc1aa67aeb5e..904cd50d6b1bf71c546cf740836ac110d1692524 100644
--- a/src/plugins/wp/GuiNavigator.ml
+++ b/src/plugins/wp/GuiNavigator.ml
@@ -57,11 +57,11 @@ let focus_of_selection selection scope =
| S_prop (IPAxiomatic {iax_name=name}) , _ -> `Index(Wpo.Axiomatic (Some name))
| S_prop ip , `Select -> `Property ip
| S_prop ip , `Module ->
- begin
- match Property.get_kf ip with
- | None -> `All
- | Some kf -> `Index(Wpo.Function(kf,None))
- end
+ begin
+ match Property.get_kf ip with
+ | None -> `All
+ | Some kf -> `Index(Wpo.Function(kf,None))
+ end
exception FIRST of Wpo.t
@@ -153,8 +153,8 @@ class behavior
let k = match currentgoal with
| None -> (-1)
| Some w ->
- try list#index w
- with Not_found -> (-1)
+ try list#index w
+ with Not_found -> (-1)
in
index#set_enabled (n>0) ;
if n=0 then card#set `List ;
@@ -191,24 +191,24 @@ class behavior
method private navigator src = function
| None ->
- begin
- currentgoal <- None ;
- next#set_enabled false ;
- prev#set_enabled false ;
- source#set None ;
- self#details ;
- end
+ begin
+ currentgoal <- None ;
+ next#set_enabled false ;
+ prev#set_enabled false ;
+ source#set None ;
+ self#details ;
+ end
| (Some w) as sw ->
- try
- currentgoal <- sw ;
- let n = list#size in
- let k = list#index w in
- prev#set_enabled (k > 0) ;
- next#set_enabled (succ k < n) ;
- source#set (if src then sw else None) ;
- self#details ;
- with Not_found ->
- self#navigator false None
+ try
+ currentgoal <- sw ;
+ let n = list#size in
+ let k = list#index w in
+ prev#set_enabled (k > 0) ;
+ next#set_enabled (succ k < n) ;
+ source#set (if src then sw else None) ;
+ self#details ;
+ with Not_found ->
+ self#navigator false None
method private next () = self#move succ
method private prev () = self#move pred
@@ -217,12 +217,12 @@ class behavior
match currentgoal with
| None -> ()
| Some w ->
- begin
- self#navigator true None ;
- let k = list#index w in
- let w = list#get (dir k) in
- self#navigator true (Some w) ;
- end
+ begin
+ self#navigator true None ;
+ let k = list#index w in
+ let w = list#get (dir k) in
+ self#navigator true (Some w) ;
+ end
with Not_found ->
self#navigator true None
@@ -249,21 +249,21 @@ class behavior
then
match prover with
| VCS.Tactical ->
- begin
- match mode , ProverScript.get w with
- | (None | Some VCS.Batch) , `Script ->
- schedule (ProverScript.prove ~success w)
- | _ ->
- card#set `Goal ;
- clear#set_enabled false ;
- self#navigator true (Some w) ;
- end
+ begin
+ match mode , ProverScript.get w with
+ | (None | Some VCS.Batch) , `Script ->
+ schedule (ProverScript.prove ~success w)
+ | _ ->
+ card#set `Goal ;
+ clear#set_enabled false ;
+ self#navigator true (Some w) ;
+ end
| _ ->
- let mode = match mode , prover with
- | Some m , _ -> m
- | _ -> if VCS.is_auto prover then VCS.Batch else VCS.Fix in
- schedule (Prover.prove w ~mode ~result prover) ;
- refresh w
+ let mode = match mode , prover with
+ | Some m , _ -> m
+ | _ -> if VCS.is_auto prover then VCS.Batch else VCS.Fix in
+ schedule (Prover.prove w ~mode ~result prover) ;
+ refresh w
end
method private clear () =
@@ -338,25 +338,25 @@ class behavior
| None | Some Tactical -> popup_tip#run ()
| Some Qed -> popup_qed#run ()
| Some (Why3 _ as p) ->
- if VCS.is_auto p
- then popup_why3_auto#run ()
- else popup_why3_inter#run ()
+ if VCS.is_auto p
+ then popup_why3_auto#run ()
+ else popup_why3_inter#run ()
end
method private action w p =
match p with
| None ->
- begin
- card#set `Goal ;
- clear#set_enabled false ;
- self#navigator true (Some w) ;
- end
+ begin
+ card#set `Goal ;
+ clear#set_enabled false ;
+ self#navigator true (Some w) ;
+ end
| Some p ->
- begin
- self#navigator true (Some w) ;
- self#prove w p ;
- list#update w ;
- end
+ begin
+ self#navigator true (Some w) ;
+ self#prove w p ;
+ list#update w ;
+ end
(* -------------------------------------------------------------------------- *)
(* --- Popup on Goals --- *)
@@ -403,21 +403,21 @@ let model_varinfo :
| PLval(Some kf, _ , (Var x,NoOffset))
| PTermLval(Some kf, _, _, (TVar {lv_origin=Some x},TNoOffset))
when button=1 && RefUsage.is_computed () ->
- begin
- let init = Globals.is_entry_point ~when_lib_entry:false kf in
- let acc = RefUsage.get ~kf ~init x in
- let model = match acc with
- | RefUsage.NoAccess -> "any"
- | RefUsage.ByValue -> "'var'"
- | RefUsage.ByRef -> "'ref'"
- | RefUsage.ByArray when x.vformal && Cil.isPointerType x.vtype
- -> "'caveat'"
- | _ -> "'typed'"
- in
- main#pretty_information
- "Is is accessed as %t and fits in %s wp-model@."
- (RefUsage.print x acc) model ;
- end
+ begin
+ let init = Globals.is_entry_point ~when_lib_entry:false kf in
+ let acc = RefUsage.get ~kf ~init x in
+ let model = match acc with
+ | RefUsage.NoAccess -> "any"
+ | RefUsage.ByValue -> "'var'"
+ | RefUsage.ByRef -> "'ref'"
+ | RefUsage.ByArray when x.vformal && Cil.isPointerType x.vtype
+ -> "'caveat'"
+ | _ -> "'typed'"
+ in
+ main#pretty_information
+ "Is is accessed as %t and fits in %s wp-model@."
+ (RefUsage.print x acc) model ;
+ end
| _ -> ()
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/GuiPanel.ml b/src/plugins/wp/GuiPanel.ml
index 8a0983e0ea936065024d4df7c5acb185158fc92e..361c2c6a9cf7e71aa20da8b66e4d846b4d369143 100644
--- a/src/plugins/wp/GuiPanel.ml
+++ b/src/plugins/wp/GuiPanel.ml
@@ -56,12 +56,12 @@ let wp_rte_generated s =
match kf_of_selection s with
| None -> false
| Some kf ->
- if Wp_parameters.RTE.get () then
- let mem = Wp_rte_generated.mem kf in
- if not mem then
- Wp_rte_generated.add kf () ;
- not mem
- else false
+ if Wp_parameters.RTE.get () then
+ let mem = Wp_rte_generated.mem kf in
+ if not mem then
+ Wp_rte_generated.add kf () ;
+ not mem
+ else false
let with_model action kf =
let setup = Factory.parse (Wp_parameters.Model.get ()) in
diff --git a/src/plugins/wp/GuiProof.ml b/src/plugins/wp/GuiProof.ml
index 70314a4e68e2d656bfc01ba45362f1de042456ee..887052c1a86e8b4232689726cbb95153ace5bac8 100644
--- a/src/plugins/wp/GuiProof.ml
+++ b/src/plugins/wp/GuiProof.ml
@@ -68,17 +68,17 @@ class printer (text : Wtext.text) =
text#printf "@{<bf>Tactical@}@} %s:" header ;
match ProofEngine.children node with
| [] ->
- text#printf "@{<green>proved@} (Qed).@\n"
+ text#printf "@{<green>proved@} (Qed).@\n"
| [_,child] ->
- text#printf "%a (%a).@\n" pp_status child self#pp_node child
+ text#printf "%a (%a).@\n" pp_status child self#pp_node child
| children ->
- begin
- text#printf " (%a)@\n@{<bf>Sub Goals:@}" pp_status node ;
- List.iter
- (fun (part,child) -> text#printf "@\n - %s : %a" part pp_status child)
- children ;
- text#printf "@." ;
- end
+ begin
+ text#printf " (%a)@\n@{<bf>Sub Goals:@}" pp_status node ;
+ List.iter
+ (fun (part,child) -> text#printf "@\n - %s : %a" part pp_status child)
+ children ;
+ text#printf "@." ;
+ end
method private alternative g a =
let open ProofScript in match a with
@@ -86,9 +86,9 @@ class printer (text : Wtext.text) =
| Tactic(n,{ header },_) -> text#printf "@{<bf>Script@} %s: pending %d.@\n" header n
| Error(msg,_) -> text#printf "@{<bf>Script@} Error (%S).@\n" msg
| Prover(p,r) ->
- if not (Wpo.has_verdict g p) then
- text#printf "@{<bf>Script@} %a: %a.@\n"
- VCS.pp_prover p VCS.pp_result r
+ if not (Wpo.has_verdict g p) then
+ text#printf "@{<bf>Script@} %a: %a.@\n"
+ VCS.pp_prover p VCS.pp_result r
method private strategy index i h =
text#printf "@{<bf>Strategy@} %s"
@@ -104,10 +104,10 @@ class printer (text : Wtext.text) =
match ProofEngine.tactical node with
| None -> List.iter (self#alternative g) (ProofEngine.bound node)
| Some { ProofScript.header } ->
- self#tactic header node ;
- let index,hs = ProofEngine.get_strategies node in
- if Array.length hs > 0 then
- ( text#hrule ; Array.iteri (self#strategy index) hs )
+ self#tactic header node ;
+ let index,hs = ProofEngine.get_strategies node in
+ if Array.length hs > 0 then
+ ( text#hrule ; Array.iteri (self#strategy index) hs )
end
method status tree =
@@ -148,54 +148,54 @@ class printer (text : Wtext.text) =
self#pp_step ~prefix ~here fmt node ;
match ProofEngine.tactical node with
| None ->
- Format.fprintf fmt " (%a)" pp_status node
+ Format.fprintf fmt " (%a)" pp_status node
| Some tactic ->
- Format.fprintf fmt " (%s" tactic.ProofScript.header ;
- match ProofEngine.children node with
-
- | [] ->
- Format.fprintf fmt ": @{<green>qed@})"
-
- | _::_ when not (List.mem node path) ->
- Format.fprintf fmt ": %a)%a" pp_status node self#backtrack node
-
- | [_,child] ->
- Format.fprintf fmt ")%a" self#backtrack node ;
- self#proofstep ~prefix:direct ~direct ~path ~here fmt child
-
- | children ->
- Format.fprintf fmt ": %a)%a" pp_status node self#backtrack node ;
- let prefix = direct ^ " + " in
- let direct = direct ^ " " in
- List.iter
- (fun (_,node) ->
- self#proofstep ~prefix ~direct ~path ~here fmt node)
- children
+ Format.fprintf fmt " (%s" tactic.ProofScript.header ;
+ match ProofEngine.children node with
+
+ | [] ->
+ Format.fprintf fmt ": @{<green>qed@})"
+
+ | _::_ when not (List.mem node path) ->
+ Format.fprintf fmt ": %a)%a" pp_status node self#backtrack node
+
+ | [_,child] ->
+ Format.fprintf fmt ")%a" self#backtrack node ;
+ self#proofstep ~prefix:direct ~direct ~path ~here fmt child
+
+ | children ->
+ Format.fprintf fmt ": %a)%a" pp_status node self#backtrack node ;
+ let prefix = direct ^ " + " in
+ let direct = direct ^ " " in
+ List.iter
+ (fun (_,node) ->
+ self#proofstep ~prefix ~direct ~path ~here fmt node)
+ children
end
method tree tree =
match ProofEngine.current tree with
| `Main ->
- begin
- let wpo = ProofEngine.main tree in
- match ProofEngine.get wpo with
- | `Proof ->
- text#printf "@{<it>Existing Script (navigate to explore)@}@."
- | `Script ->
- text#printf "[%a]@." ProofSession.pp_script_for wpo ;
- text#printf "@{<it>Existing Script (replay to explore)@}@."
- | `Saved ->
- text#printf "[%a]@." ProofSession.pp_script_for wpo ;
- text#printf "@{<it>Saved Script (replay to load)@}@."
- | `None ->
- text#printf "@{<it>No Script@}@."
- end
+ begin
+ let wpo = ProofEngine.main tree in
+ match ProofEngine.get wpo with
+ | `Proof ->
+ text#printf "@{<it>Existing Script (navigate to explore)@}@."
+ | `Script ->
+ text#printf "[%a]@." ProofSession.pp_script_for wpo ;
+ text#printf "@{<it>Existing Script (replay to explore)@}@."
+ | `Saved ->
+ text#printf "[%a]@." ProofSession.pp_script_for wpo ;
+ text#printf "@{<it>Saved Script (replay to load)@}@."
+ | `None ->
+ text#printf "@{<it>No Script@}@."
+ end
| `Internal here | `Leaf(_,here) ->
- begin
- let root,path = rootchain here [here] in
- let qed = if Wpo.is_proved (ProofEngine.main tree) then "Qed" else "End"
- in text#printf "@[<hv 0>@{<bf>Proof@}:%a@\n@{<bf>%s@}.@]@."
- (self#proofstep ~prefix:" " ~direct:" " ~path ~here) root qed ;
- end
+ begin
+ let root,path = rootchain here [here] in
+ let qed = if Wpo.is_proved (ProofEngine.main tree) then "Qed" else "End"
+ in text#printf "@[<hv 0>@{<bf>Proof@}:%a@\n@{<bf>%s@}.@]@."
+ (self#proofstep ~prefix:" " ~direct:" " ~path ~here) root qed ;
+ end
end
diff --git a/src/plugins/wp/GuiProver.ml b/src/plugins/wp/GuiProver.ml
index 2ff42a0eb2c54072ddc1ad675415a0d51e147003..3189a4a43131790032ccadf46f23ef0819d22be4 100644
--- a/src/plugins/wp/GuiProver.ml
+++ b/src/plugins/wp/GuiProver.ml
@@ -36,20 +36,20 @@ let filter = function
let timeout_for = function
| VCS.Why3 _ ->
- let value = Wp_parameters.Timeout.get () in
- let spin = new Widget.spinner
- ~tooltip:"Prover Timeout (0 for none)"
- ~min:0 ~step:5 ~value () in
- Some spin
+ let value = Wp_parameters.Timeout.get () in
+ let spin = new Widget.spinner
+ ~tooltip:"Prover Timeout (0 for none)"
+ ~min:0 ~step:5 ~value () in
+ Some spin
| _ -> None
let stepout_for = function
| VCS.Why3 _ ->
- let value = Wp_parameters.Steps.get () in
- let spin = new Widget.spinner
- ~tooltip:"Prover Step Limit (0 for none)"
- ~min:0 ~step:100 ~value () in
- Some spin
+ let value = Wp_parameters.Steps.get () in
+ let spin = new Widget.spinner
+ ~tooltip:"Prover Step Limit (0 for none)"
+ ~min:0 ~step:100 ~value () in
+ Some spin
| _ -> None
class prover ~(console:Wtext.text) ~prover =
@@ -119,29 +119,29 @@ class prover ~(console:Wtext.text) ~prover =
result#set_text (Pretty_utils.to_string VCS.pp_result res) ;
match res.VCS.verdict with
| VCS.NoResult ->
- let callback () = self#run wpo in
- self#set_status no_status ;
- self#set_action ~icon:`MEDIA_PLAY ~tooltip:"Run Prover" ~callback () ;
+ let callback () = self#run wpo in
+ self#set_status no_status ;
+ self#set_action ~icon:`MEDIA_PLAY ~tooltip:"Run Prover" ~callback () ;
| VCS.Computing callback ->
- self#set_status `EXECUTE ;
- self#set_action ~tooltip:"Interrrupt Prover" ~icon:`STOP ~callback () ;
- Pretty_utils.ksfprintf self#set_label "%a (...)" VCS.pp_prover prover ;
+ self#set_status `EXECUTE ;
+ self#set_action ~tooltip:"Interrrupt Prover" ~icon:`STOP ~callback () ;
+ Pretty_utils.ksfprintf self#set_label "%a (...)" VCS.pp_prover prover ;
| VCS.Valid ->
- let callback () = self#run wpo in
- self#set_status ok_status ;
- self#set_action ~tooltip:"Run Prover" ~icon:`MEDIA_PLAY ~callback () ;
- Pretty_utils.ksfprintf self#set_label "%a (%a)" VCS.pp_prover prover
- Rformat.pp_time res.VCS.prover_time ;
+ let callback () = self#run wpo in
+ self#set_status ok_status ;
+ self#set_action ~tooltip:"Run Prover" ~icon:`MEDIA_PLAY ~callback () ;
+ Pretty_utils.ksfprintf self#set_label "%a (%a)" VCS.pp_prover prover
+ Rformat.pp_time res.VCS.prover_time ;
| VCS.Invalid | VCS.Unknown | VCS.Timeout | VCS.Stepout ->
- let callback () = self#run wpo in
- self#set_status ko_status ;
- self#set_action ~tooltip:"Run Prover" ~icon:`MEDIA_PLAY ~callback () ;
- Pretty_utils.ksfprintf self#set_label "%a (?)" VCS.pp_prover prover ;
+ let callback () = self#run wpo in
+ self#set_status ko_status ;
+ self#set_action ~tooltip:"Run Prover" ~icon:`MEDIA_PLAY ~callback () ;
+ Pretty_utils.ksfprintf self#set_label "%a (?)" VCS.pp_prover prover ;
| VCS.Failed ->
- let callback () = self#log wpo res in
- self#set_status `DIALOG_WARNING ;
- self#set_action ~tooltip:"Dump Logs" ~icon:`FILE ~callback () ;
- Pretty_utils.ksfprintf self#set_label "%a (failed)" VCS.pp_prover prover ;
+ let callback () = self#log wpo res in
+ self#set_status `DIALOG_WARNING ;
+ self#set_action ~tooltip:"Dump Logs" ~icon:`FILE ~callback () ;
+ Pretty_utils.ksfprintf self#set_label "%a (failed)" VCS.pp_prover prover ;
end
end
diff --git a/src/plugins/wp/GuiSequent.ml b/src/plugins/wp/GuiSequent.ml
index aaf112abc48264d254f3062d2d58f0d3291732d8..c4153e310d6ea23b2c50e54389382dff717cee3e 100644
--- a/src/plugins/wp/GuiSequent.ml
+++ b/src/plugins/wp/GuiSequent.ml
@@ -110,11 +110,11 @@ class autofocus =
| `Hidden -> Env.define env "..." t
| `Visible -> Env.unfold env t
| `Shared ->
- let base = F.basename t in
- let sanitizer = Plang.sanitizer in
- Env.define env (Env.fresh env ~sanitizer base) t
+ let base = F.basename t in
+ let sanitizer = Plang.sanitizer in
+ Env.define env (Env.fresh env ~sanitizer base) t
| `Name x ->
- Env.define env x t)
+ Env.define env x t)
vterm ; env
(* --- Term Occurrence --- *)
@@ -153,27 +153,27 @@ class autofocus =
| When _ -> true
| State s -> self#occurs_state s
| Init p | Have p | Type p | Core p ->
- self#occurs_term (F.e_prop p)
+ self#occurs_term (F.e_prop p)
| Branch(p,sa,sb) ->
- self#occurs_term (F.e_prop p)
- || self#occurs_seq sa
- || self#occurs_seq sb
+ self#occurs_term (F.e_prop p)
+ || self#occurs_seq sa
+ || self#occurs_seq sb
| Either cs ->
- List.exists self#occurs_seq cs
+ List.exists self#occurs_seq cs
in occurs_step <- Imap.add step.id occurs occurs_step ; occurs
(* --- Term Visibility --- *)
method set_term t = function
| `Auto ->
- if Tmap.mem t vterm then
- (vterm <- Tmap.remove t vterm ; self#clear_cache)
+ if Tmap.mem t vterm then
+ (vterm <- Tmap.remove t vterm ; self#clear_cache)
| v ->
- let same =
- try v = Tmap.find t vterm
- with Not_found -> false in
- if not same then
- (vterm <- Tmap.add t v vterm ; self#clear_cache)
+ let same =
+ try v = Tmap.find t vterm
+ with Not_found -> false in
+ if not same then
+ (vterm <- Tmap.add t v vterm ; self#clear_cache)
method get_term t = try Tmap.find t vterm with Not_found -> `Auto
@@ -220,14 +220,14 @@ class autofocus =
method set_step s = function
| `Auto ->
- if Imap.mem s.id vstep then
- (vstep <- Imap.remove s.id vstep ; self#clear_steps)
+ if Imap.mem s.id vstep then
+ (vstep <- Imap.remove s.id vstep ; self#clear_steps)
| v ->
- let same =
- try v = Imap.find s.id vstep
- with Not_found -> false in
- if not same then
- (vstep <- Imap.add s.id v vstep ; self#clear_steps)
+ let same =
+ try v = Imap.find s.id vstep
+ with Not_found -> false in
+ if not same then
+ (vstep <- Imap.add s.id v vstep ; self#clear_steps)
method get_step s =
try Imap.find s.id vstep
@@ -243,27 +243,27 @@ class autofocus =
match sequent with
| None -> Tactical.Empty
| Some (hs,goal) ->
- if F.is_subterm a (F.e_prop goal)
- then Tactical.(Inside(Goal goal,a))
- else
- let pool = ref Tactical.Empty in
- let rec lookup_sequence a hs =
- Conditions.iter
- (fun step ->
- match step.condition with
- | (Have p | When p | Branch(p,_,_))
- when F.is_subterm a (F.e_prop p) ->
- pool := Tactical.(Inside(Step step,a)) ;
- raise Exit
- | Branch(_,sa,sb) ->
- lookup_sequence a sa ;
- lookup_sequence a sb ;
- | Either cs ->
- List.iter (lookup_sequence a) cs
- | State _ | Type _ | Init _ | Have _ | When _ | Core _ -> ()
- ) hs in
- (try lookup_sequence a hs with Exit -> ()) ;
- !pool
+ if F.is_subterm a (F.e_prop goal)
+ then Tactical.(Inside(Goal goal,a))
+ else
+ let pool = ref Tactical.Empty in
+ let rec lookup_sequence a hs =
+ Conditions.iter
+ (fun step ->
+ match step.condition with
+ | (Have p | When p | Branch(p,_,_))
+ when F.is_subterm a (F.e_prop p) ->
+ pool := Tactical.(Inside(Step step,a)) ;
+ raise Exit
+ | Branch(_,sa,sb) ->
+ lookup_sequence a sa ;
+ lookup_sequence a sb ;
+ | Either cs ->
+ List.iter (lookup_sequence a) cs
+ | State _ | Type _ | Init _ | Have _ | When _ | Core _ -> ()
+ ) hs in
+ (try lookup_sequence a hs with Exit -> ()) ;
+ !pool
(* ---- Global ----- *)
@@ -380,10 +380,10 @@ class pcond
match step.condition with
| State _ -> ()
| Have p | Init p | Core p | When p | Type p ->
- domain <- Vars.union (F.varsp p) domain
+ domain <- Vars.union (F.varsp p) domain
| Branch(p,a,b) ->
- domain <- Vars.union (F.varsp p) domain ;
- self#domain a ; self#domain b
+ domain <- Vars.union (F.varsp p) domain ;
+ self#domain a ; self#domain b
| Either cs -> List.iter self#domain cs
end
) seq
@@ -398,9 +398,9 @@ class pcond
match tgt with
| Step { condition = State _ } -> super#pp_step fmt step
| Step s when s == step ->
- target#mark (Step step) super#pp_step fmt step
+ target#mark (Step step) super#pp_step fmt step
| _ ->
- part#mark (Step step) super#pp_step fmt step
+ part#mark (Step step) super#pp_step fmt step
end
else
( if not ellipsed then Format.fprintf fmt "@ [...]" ; ellipsed <- true )
@@ -408,9 +408,9 @@ class pcond
method! pp_goal fmt goal =
match tgt with
| Goal ->
- target#mark Goal super#pp_goal fmt goal
+ target#mark Goal super#pp_goal fmt goal
| _ ->
- part#mark Goal super#pp_goal fmt goal
+ part#mark Goal super#pp_goal fmt goal
method! pp_block ~clause fmt seq =
try
@@ -551,34 +551,34 @@ class focused (wtext : Wtext.text) =
method private popup_term e =
match autofocus#get_term e with
| `Auto ->
- begin
- if autofocus#is_focused e then
- self#item ~label:"Un-focus Term"
- ~callback:(fun () -> autofocus#unfocus e) ;
- self#item ~label:"Hide Term"
- ~callback:(fun () -> autofocus#set_term e `Hidden) ;
- self#item ~label:"Don't Share"
- ~callback:(fun () -> autofocus#set_term e `Visible) ;
- end
+ begin
+ if autofocus#is_focused e then
+ self#item ~label:"Un-focus Term"
+ ~callback:(fun () -> autofocus#unfocus e) ;
+ self#item ~label:"Hide Term"
+ ~callback:(fun () -> autofocus#set_term e `Hidden) ;
+ self#item ~label:"Don't Share"
+ ~callback:(fun () -> autofocus#set_term e `Visible) ;
+ end
| `Hidden ->
- self#item ~label:"Show Term"
- ~callback:(fun () -> autofocus#set_term e `Auto)
+ self#item ~label:"Show Term"
+ ~callback:(fun () -> autofocus#set_term e `Auto)
| `Visible | `Name _ | `Shared ->
- self#item ~label:"Autofocus"
- ~callback:(fun () -> autofocus#set_term e `Auto)
+ self#item ~label:"Autofocus"
+ ~callback:(fun () -> autofocus#set_term e `Auto)
method private popup_part = function
| Goal | Term ->
- self#item
- ~label:"Reset Autofocus"
- ~callback:(fun () -> autofocus#reset)
+ self#item
+ ~label:"Reset Autofocus"
+ ~callback:(fun () -> autofocus#reset)
| Step step ->
- if autofocus#is_visible_step step then
- self#item ~label:"Hide Clause"
- ~callback:(fun () -> autofocus#set_step step `Hidden)
- else
- self#item ~label:"Show Clause"
- ~callback:(fun () -> autofocus#set_step step `Visible)
+ if autofocus#is_visible_step step then
+ self#item ~label:"Hide Clause"
+ ~callback:(fun () -> autofocus#set_step step `Hidden)
+ else
+ self#item ~label:"Show Clause"
+ ~callback:(fun () -> autofocus#set_step step `Visible)
method popup =
begin
@@ -624,29 +624,29 @@ class focused (wtext : Wtext.text) =
method set_target tgt =
match tgt with
| Tactical.Empty | Tactical.Compose _ | Tactical.Multi _ ->
- begin
- pcond#set_target Term ;
- plang#clear_target ;
- autofocus#clear_target ;
- end
+ begin
+ pcond#set_target Term ;
+ plang#clear_target ;
+ autofocus#clear_target ;
+ end
| Tactical.Inside (_,t) ->
- begin
- pcond#set_target Term ;
- plang#set_target t ;
- autofocus#set_target t ;
- end
+ begin
+ pcond#set_target Term ;
+ plang#set_target t ;
+ autofocus#set_target t ;
+ end
| Tactical.Clause (Tactical.Goal _) ->
- begin
- pcond#set_target Goal ;
- plang#clear_target ;
- autofocus#clear_target ;
- end
+ begin
+ pcond#set_target Goal ;
+ plang#clear_target ;
+ autofocus#clear_target ;
+ end
| Tactical.Clause (Tactical.Step s) ->
- begin
- pcond#set_target (Step s) ;
- plang#clear_target ;
- autofocus#clear_target ;
- end
+ begin
+ pcond#set_target (Step s) ;
+ plang#clear_target ;
+ autofocus#clear_target ;
+ end
method private on_term ~extend (p,q,e) =
if F.lc_closed e then (* defensive *)
@@ -694,7 +694,7 @@ class focused (wtext : Wtext.text) =
method pp_selection fmt = function
| Tactical.Empty -> Format.fprintf fmt " - "
| Tactical.Compose(Tactical.Range(a,b)) ->
- Format.fprintf fmt "%d..%d" a b
+ Format.fprintf fmt "%d..%d" a b
| sel -> self#pp_term fmt (Tactical.selected sel)
method sequent = sequent
@@ -718,13 +718,13 @@ class focused (wtext : Wtext.text) =
let open Wpo in
match w.po_formula with
| GoalLemma _ ->
- Format.fprintf fmt "@\n@{<wp:clause>Lemma@} %a:@\n" Wpo.pp_title w ;
- let _,sequent = Wpo.compute w in
- self#pp_sequent sequent fmt
+ Format.fprintf fmt "@\n@{<wp:clause>Lemma@} %a:@\n" Wpo.pp_title w ;
+ let _,sequent = Wpo.compute w in
+ self#pp_sequent sequent fmt
| GoalAnnot _ ->
- Format.fprintf fmt "@\n@{<wp:clause>Goal@} %a:@\n" Wpo.pp_title w ;
- let _,sequent = Wpo.compute w in
- self#pp_sequent sequent fmt
+ Format.fprintf fmt "@\n@{<wp:clause>Goal@} %a:@\n" Wpo.pp_title w ;
+ let _,sequent = Wpo.compute w in
+ self#pp_sequent sequent fmt
method button ~title ~callback fmt =
let pp_title fmt title = Format.fprintf fmt " %s " title in
diff --git a/src/plugins/wp/GuiSource.ml b/src/plugins/wp/GuiSource.ml
index 93478aa47612a66c288aaf0fe89f1f56de2d358c..e97a1a1660b135f20d173ca36859a45b86daa6d1 100644
--- a/src/plugins/wp/GuiSource.ml
+++ b/src/plugins/wp/GuiSource.ml
@@ -45,27 +45,27 @@ let selection_of_localizable = function
| PStmt( kf , stmt ) | PStmtStart( kf , stmt )
| PLval( Some kf , Kstmt stmt , _ )
| PTermLval( Some kf , Kstmt stmt , _, _ ) ->
- begin
- match stmt with
- | { skind=Instr(Call(_,e,_,_)) } ->
- begin
- match Kernel_function.get_called e with
- | None -> S_none
- | Some called ->
- S_call {
- s_called = called ;
- s_caller = kf ;
- s_stmt = stmt ;
- }
- end
- | { skind=Instr(Local_init(_,ConsInit (vi, _, _),_)) } ->
+ begin
+ match stmt with
+ | { skind=Instr(Call(_,e,_,_)) } ->
+ begin
+ match Kernel_function.get_called e with
+ | None -> S_none
+ | Some called ->
S_call {
- s_called = Globals.Functions.get vi ;
+ s_called = called ;
s_caller = kf ;
s_stmt = stmt ;
}
- | _ -> S_none
- end
+ end
+ | { skind=Instr(Local_init(_,ConsInit (vi, _, _),_)) } ->
+ S_call {
+ s_called = Globals.Functions.get vi ;
+ s_caller = kf ;
+ s_stmt = stmt ;
+ }
+ | _ -> S_none
+ end
| PVDecl (Some kf,_,{vglob=true}) -> S_fun kf
| PIP ip -> S_prop ip
| PVDecl _ | PLval _ | PExp _ | PTermLval _ | PGlobal _ -> S_none
@@ -74,7 +74,7 @@ let kind_of_property = function
| Property.IPLemma _ -> "lemma"
| Property.IPCodeAnnot _ -> "annotation"
| Property.(IPPredicate {ip_kind=PKRequires _;ip_kinstr = Kglobal}) ->
- "precondition for callers"
+ "precondition for callers"
| _ -> "property"
(* -------------------------------------------------------------------------- *)
@@ -108,22 +108,22 @@ class popup () =
method private rte_popup menu main loc =
match loc with
| PVDecl (Some kf,_,{vglob=true}) ->
- if not (is_rte_generated kf) then
- self#rte_option menu main "Insert wp-rte guards"
- self#rte_generate kf ;
+ if not (is_rte_generated kf) then
+ self#rte_option menu main "Insert wp-rte guards"
+ self#rte_generate kf ;
| _ -> ()
method private wp_popup (menu : GMenu.menu GMenu.factory) = function
| S_none -> ()
| s ->
- let target = match s with
- | S_none -> "none"
- | S_prop ip -> kind_of_property ip
- | S_call _ -> "call preconditions"
- | S_fun _ -> "function annotations"
- in
- let title = Printf.sprintf "Prove %s by WP" target in
- ignore (menu#add_item title ~callback:(fun () -> prove s))
+ let target = match s with
+ | S_none -> "none"
+ | S_prop ip -> kind_of_property ip
+ | S_call _ -> "call preconditions"
+ | S_fun _ -> "function annotations"
+ in
+ let title = Printf.sprintf "Prove %s by WP" target in
+ ignore (menu#add_item title ~callback:(fun () -> prove s))
method register
(menu : GMenu.menu GMenu.factory)
@@ -131,16 +131,16 @@ class popup () =
~(button:int) (loc:Pretty_source.localizable) =
begin match button with
| 1 ->
- begin
- match selection_of_localizable loc with
- | S_none -> ()
- | s -> click s
- end
+ begin
+ match selection_of_localizable loc with
+ | S_none -> ()
+ | s -> click s
+ end
| 3 ->
- begin
- self#wp_popup menu (selection_of_localizable loc) ;
- self#rte_popup menu main loc ;
- end
+ begin
+ self#wp_popup menu (selection_of_localizable loc) ;
+ self#rte_popup menu main loc ;
+ end
| _ -> ()
end
@@ -207,20 +207,20 @@ class highlighter (main:Design.main_window_extension_points) =
match s with
| None -> Wutil.later main#rehighlight ;
| Some { Wpo.po_pid = pid ; Wpo.po_formula = f } ->
- begin
- match f with
- | GoalLemma l ->
- deps <- lemmas l.VC_Lemma.depends
- | GoalAnnot a ->
- effect <- a.VC_Annot.effect ;
- path <- instructions a.VC_Annot.path ;
- deps <- a.VC_Annot.deps ;
- end ;
- if not (WpPropId.is_check pid || WpPropId.is_tactic pid)
- then
- ( let ip = WpPropId.property_of_id pid in
- goal <- Some ip ) ;
- Wutil.later self#scroll ;
+ begin
+ match f with
+ | GoalLemma l ->
+ deps <- lemmas l.VC_Lemma.depends
+ | GoalAnnot a ->
+ effect <- a.VC_Annot.effect ;
+ path <- instructions a.VC_Annot.path ;
+ deps <- a.VC_Annot.deps ;
+ end ;
+ if not (WpPropId.is_check pid || WpPropId.is_tactic pid)
+ then
+ ( let ip = WpPropId.property_of_id pid in
+ goal <- Some ip ) ;
+ Wutil.later self#scroll ;
end
method update = main#rehighlight ()
@@ -232,23 +232,23 @@ class highlighter (main:Design.main_window_extension_points) =
let buffer = buffer#buffer in
begin match loc with
| PStmt( _ , stmt ) | PStmtStart( _ , stmt ) ->
- begin
- match effect with
- | Some(s,_) when Stmt.equal stmt s ->
- apply_effect buffer start stop
- | _ ->
- if PATH.mem stmt path then
- apply_path buffer start stop
- end
+ begin
+ match effect with
+ | Some(s,_) when Stmt.equal stmt s ->
+ apply_effect buffer start stop
+ | _ ->
+ if PATH.mem stmt path then
+ apply_path buffer start stop
+ end
| PIP ip ->
- begin
- match goal with
- | Some g when Property.equal g ip ->
- apply_goal buffer start stop
- | _ ->
- if DEPS.mem ip deps then
- apply_depend buffer start stop
- end
+ begin
+ match goal with
+ | Some g when Property.equal g ip ->
+ apply_goal buffer start stop
+ | _ ->
+ if DEPS.mem ip deps then
+ apply_depend buffer start stop
+ end
| PGlobal _
| PVDecl _ | PTermLval _ | PLval _ | PExp _ -> ()
end
diff --git a/src/plugins/wp/GuiTactic.ml b/src/plugins/wp/GuiTactic.ml
index 8484deedffa91668367340b37887826381e581a7..4cfcdcef5d80fc894fb0a9fe926c4e8f988b55c0 100644
--- a/src/plugins/wp/GuiTactic.ml
+++ b/src/plugins/wp/GuiTactic.ml
@@ -155,14 +155,14 @@ class mkcomposer
method private updated =
match tac#get_field field with
| Empty ->
- Pretty_utils.ksfprintf head#set_text "%s: -" wtitle
+ Pretty_utils.ksfprintf head#set_text "%s: -" wtitle
| value ->
- let text =
- Pretty_utils.sfprintf "@[<hov 2>%s: %a@]" wtitle pp value in
- let msg =
- if String.length text <= 20 then text else
- String.sub text 0 17 ^ "..." in
- head#set_text msg
+ let text =
+ Pretty_utils.sfprintf "@[<hov 2>%s: %a@]" wtitle pp value in
+ let msg =
+ if String.length text <= 20 then text else
+ String.sub text 0 17 ^ "..." in
+ head#set_text msg
(* --- Composer API ---- *)
method composer = (self :> composer)
@@ -173,8 +173,8 @@ class mkcomposer
| Empty -> false
| Compose(Range(a,b)) -> ranged && (a <= b)
| _ as s ->
- try wvalid (Tactical.selected s)
- with _ -> false
+ try wvalid (Tactical.selected s)
+ with _ -> false
method get_value = tac#get_field field
method set_value v =
tac#set_field field v ;
@@ -226,16 +226,16 @@ class ['a] mksearch
method private updated =
match tac#get_field field with
| None ->
- Pretty_utils.ksfprintf head#set_text "%s: -" wtitle
+ Pretty_utils.ksfprintf head#set_text "%s: -" wtitle
| Some item ->
- begin
- let text = item.title in
- let msg =
- if String.length text <= 20 then text else
- String.sub text 0 17 ^ "..." in
- head#set_text msg ;
- head#set_tooltip item.descr ;
- end
+ begin
+ let text = item.title in
+ let msg =
+ if String.length text <= 20 then text else
+ String.sub text 0 17 ^ "..." in
+ head#set_text msg ;
+ head#set_tooltip item.descr ;
+ end
(* --- Browser API --- *)
method browser = (self :> browser)
@@ -243,8 +243,8 @@ class ['a] mksearch
method choose item =
let value = match item with
| Some id ->
- (try Some(Hashtbl.find items id)
- with Not_found -> None)
+ (try Some(Hashtbl.find items id)
+ with Not_found -> None)
| None -> None in
tac#set_field field value ;
self#updated ;
@@ -444,7 +444,7 @@ class tactic
match edited with
| None -> ()
| Some { process ; composer ; browser ; target ; tree } ->
- self#select ~process ~composer ~browser ~tree target
+ self#select ~process ~composer ~browser ~tree target
method clear =
begin
@@ -469,18 +469,18 @@ class tactic
let status = self#status target in
match status , error with
| Not_applicable , _ ->
- self#set_visible false ;
- self#set_status `FIND ;
- self#set_action () ;
+ self#set_visible false ;
+ self#set_status `FIND ;
+ self#set_action () ;
| Not_configured , _ | Applicable _ , true ->
- self#set_visible true ;
- self#set_status `DIALOG_WARNING ;
- self#set_action () ;
+ self#set_visible true ;
+ self#set_status `DIALOG_WARNING ;
+ self#set_action () ;
| Applicable proc , false ->
- self#set_visible true ;
- self#set_status `APPLY ;
- let callback () = process tac target proc in
- self#set_action ~callback () ;
+ self#set_visible true ;
+ self#set_status `APPLY ;
+ let callback () = process tac target proc in
+ self#set_action ~callback () ;
end
end
@@ -539,28 +539,28 @@ class strategies () =
method private update () =
match demon with
| None ->
- self#set_visible false
+ self#set_visible false
| Some _ ->
- self#set_visible true ;
- if List.exists (fun h -> h.widget#get) hforms then
- begin
- self#set_status `APPLY ;
- self#set_action ~callback:self#callback () ;
- end
- else
- begin
- self#set_status `INDEX ;
- self#set_action ()
- end
+ self#set_visible true ;
+ if List.exists (fun h -> h.widget#get) hforms then
+ begin
+ self#set_status `APPLY ;
+ self#set_action ~callback:self#callback () ;
+ end
+ else
+ begin
+ self#set_status `INDEX ;
+ self#set_action ()
+ end
method private callback () =
match demon with
| Some f ->
- let hs =
- List.fold_right
- (fun h hs -> if h.widget#get then h.search :: hs else hs)
- hforms [] in
- f ~depth:depth#get ~width:width#get hs
+ let hs =
+ List.fold_right
+ (fun h hs -> if h.widget#get then h.search :: hs else hs)
+ hforms [] in
+ f ~depth:depth#get ~width:width#get hs
| None -> ()
method connect f = demon <- f ; self#update ()
diff --git a/src/plugins/wp/Lang.ml b/src/plugins/wp/Lang.ml
index 4a3f934474aa58370c7287b07ce8816cca658362..8d9a4424d20095c34238738b317c36068c2e44c1 100644
--- a/src/plugins/wp/Lang.ml
+++ b/src/plugins/wp/Lang.ml
@@ -218,8 +218,8 @@ let rec tau_of_ltype t =
| Ctype typ -> tau_of_ctype typ
| Lvar x -> Logic.Tvar (varpoly 1 x (Context.get poly))
| Larrow _ ->
- Warning.error "array type non-supported(%a)"
- Printer.pp_logic_type t
+ Warning.error "array type non-supported(%a)"
+ Printer.pp_logic_type t
| Ltype _ as b when Logic_const.is_boolean_type b -> Logic.Bool
| Ltype(lt,lts) -> atype lt (List.map tau_of_ltype lts)
@@ -297,12 +297,12 @@ let is_builtin lt = mem_builtin_type lt.lt_name
let is_builtin_type ~name = function
| Data(Mtype m,_) ->
- begin
- try match find_builtin name with
- | E_mdt m0 -> m == m0
- | _ -> false
- with Not_found -> false
- end
+ begin
+ try match find_builtin name with
+ | E_mdt m0 -> m == m0
+ | _ -> false
+ with Not_found -> false
+ end
| _ -> false
let datatype ~library name =
@@ -318,10 +318,10 @@ let record ~link ~library fts =
let field t f =
match t with
| Mrecord(_,r) ->
- begin
- try List.find (function Mfield(_,_,g,_) -> f = g | _ -> false) r.fields
- with Not_found -> Wp_parameters.fatal "No field <%s> in record" f
- end
+ begin
+ try List.find (function Mfield(_,_,g,_) -> f = g | _ -> false) r.fields
+ with Not_found -> Wp_parameters.fatal "No field <%s> in record" f
+ end
| _ -> Wp_parameters.fatal "No field <%s> in type '%a'" f ADT.pretty t
let comp c = Comp (c, KValue)
@@ -330,7 +330,7 @@ let comp_init c = Comp (c, KInit)
let fields_of_adt = function
| Mrecord(_,r) -> r.fields
| Comp (c, k) ->
- List.map (fun f -> Cfield (f, k)) (Option.value ~default:[] c.cfields)
+ List.map (fun f -> Cfield (f, k)) (Option.value ~default:[] c.cfields)
| _ -> []
let fields_of_tau = function
@@ -341,7 +341,7 @@ let fields_of_tau = function
let fields_of_field = function
| Mfield(_,r,_,_) -> r.fields
| Cfield(f, k) ->
- List.map (fun f -> Cfield (f, k)) (Option.value ~default:[] f.fcomp.cfields)
+ List.map (fun f -> Cfield (f, k)) (Option.value ~default:[] f.fcomp.cfields)
let tau_of_field = function
| Mfield(_,_,_,t) -> t
@@ -376,7 +376,7 @@ struct
| Cfield _ , Mfield _ -> 1
| Cfield(f, KValue) , Cfield(g, KValue)
| Cfield(f, KInit) , Cfield(g, KInit) ->
- Fieldinfo.compare f g
+ Fieldinfo.compare f g
| Cfield(_, KInit), Cfield(_, KValue) -> (-1)
| Cfield(_, KValue), Cfield(_, KInit) -> 1
@@ -420,8 +420,8 @@ let tau_of_lfun phi ts =
match phi with
| ACSL f -> tau_of_return f
| CTOR c ->
- if c.ctor_type.lt_params = [] then Logic.Data(Atype c.ctor_type,[])
- else raise Not_found
+ if c.ctor_type.lt_params = [] then Logic.Data(Atype c.ctor_type,[])
+ else raise Not_found
| Model m -> match m.m_result with
| Sint -> Int
| Sreal -> Real
@@ -461,19 +461,19 @@ let symbolf
let name = Buffer.contents buffer in
let source = match library with
| None ->
- assert (link = None);
- generated ?context name
+ assert (link = None);
+ generated ?context name
| Some th ->
- let conv n = function
- | Nary -> Engine.F_call n
- | Left -> Engine.F_left n
- | Right -> Engine.F_right n
- in
- let link = match link with
- | None -> conv name balance
- | Some info -> info
- in
- Extern (new_extern ~library:th ~link ~debug:name) in
+ let conv n = function
+ | Nary -> Engine.F_call n
+ | Left -> Engine.F_left n
+ | Right -> Engine.F_right n
+ in
+ let link = match link with
+ | None -> conv name balance
+ | Some info -> info
+ in
+ Extern (new_extern ~library:th ~link ~debug:name) in
let typeof =
match typecheck with Some phi -> phi | None ->
match result with Some t -> fun _ -> t | None -> not_found in
@@ -575,10 +575,10 @@ struct
let compare_source s1 s2 =
match s1 , s2 with
| Generated(m1,f1), Generated(m2,f2) ->
- let cmp = String.compare f1 f2 in
- if cmp<>0 then cmp else compare_context m1 m2
+ let cmp = String.compare f1 f2 in
+ if cmp<>0 then cmp else compare_context m1 m2
| Extern f , Extern g ->
- ext_compare f g
+ ext_compare f g
| Generated _ , Extern _ -> (-1)
| Extern _ , Generated _ -> 1
@@ -842,8 +842,8 @@ struct
match Context.get_opt context_pp with
| Some env -> Pretty.pp_term_env env fmt e
| None ->
- let env = Pretty.known Pretty.empty (QED.vars e) in
- Pretty.pp_term env fmt e
+ let env = Pretty.known Pretty.empty (QED.vars e) in
+ Pretty.pp_term env fmt e
let pp_pred = pp_term
let pp_var fmt x = pp_term fmt (e_var x)
let pp_vars fmt xs =
@@ -1030,10 +1030,10 @@ module For_export = struct
let get_state () =
match !state with
| None ->
- let st = QZERO.create () in
- QZERO.in_state st !init ();
- state := Some st;
- st
+ let st = QZERO.create () in
+ QZERO.in_state st !init ();
+ state := Some st;
+ st
| Some st -> st
let rebuild ?cache t = QZERO.rebuild_in_state (get_state ()) ?cache t
diff --git a/src/plugins/wp/Layout.ml b/src/plugins/wp/Layout.ml
index 004028084d65997cfbce96a8ecee066cb7415a5e..e42fe2038aed0d4923defd58646f2a2516f84825 100644
--- a/src/plugins/wp/Layout.ml
+++ b/src/plugins/wp/Layout.ml
@@ -51,8 +51,8 @@ struct
| Field _ , _ -> (-1)
| _ , Field _ -> 1
| Index(ta,n) , Index(tb,m) ->
- let cmp = Typ.compare ta tb in
- if cmp <> 0 then cmp else Stdlib.compare n m
+ let cmp = Typ.compare ta tb in
+ if cmp <> 0 then cmp else Stdlib.compare n m
let equal a b = (compare a b = 0)
@@ -69,11 +69,11 @@ struct
let index ty =
match Cil.unrollType ty with
| TArray(te,n,_) ->
- begin
- match Option.bind n Ctypes.get_int with
- | None -> failwith "Wp.Layout: unkown array size"
- | Some n -> Index(te,n)
- end
+ begin
+ match Option.bind n Ctypes.get_int with
+ | None -> failwith "Wp.Layout: unkown array size"
+ | Some n -> Index(te,n)
+ end
| _ -> failwith "Wp.Layout: not an array-type"
let rec typeof_chain ty = function [] -> ty | _::ds -> typeof_chain ty ds
@@ -81,13 +81,13 @@ struct
let rec pp_chain ty fmt = function
| [] -> ()
| d::ds ->
- let next =
- Format.pp_print_cut fmt () ;
- match d with
- | Index(t,n) when Typ.equal t ty ->
- Format.fprintf fmt "[%d]" n ; t
- | d -> Format.fprintf fmt "%a" pretty d ; typeof d
- in pp_chain next fmt ds
+ let next =
+ Format.pp_print_cut fmt () ;
+ match d with
+ | Index(t,n) when Typ.equal t ty ->
+ Format.fprintf fmt "[%d]" n ; t
+ | d -> Format.fprintf fmt "%a" pretty d ; typeof d
+ in pp_chain next fmt ds
module H = Compinfo.Hashtbl
@@ -286,9 +286,9 @@ struct
let pretty fmt = function
| [] -> ()
| d::ds ->
- Format.fprintf fmt "@[<hov 1>[%d" d ;
- List.iter (fun d -> Format.fprintf fmt ",@,%d" d) ds ;
- Format.fprintf fmt "]@]"
+ Format.fprintf fmt "@[<hov 1>[%d" d ;
+ List.iter (fun d -> Format.fprintf fmt ",@,%d" d) ds ;
+ Format.fprintf fmt "]@]"
let rec sizeof n = function [] -> n | d::ds -> sizeof (n*d) ds
@@ -302,9 +302,9 @@ struct
let rec join s da db len =
match da , db with
| d::da , d'::db when d = d' ->
- let s' = s * d in
- if len mod s' = 0 then d :: join s' da db len else
- join_array s len
+ let s' = s * d in
+ if len mod s' = 0 then d :: join s' da db len else
+ join_array s len
| _ -> join_array s len
let rec merge d1 d2 =
@@ -349,14 +349,14 @@ struct
let len = max (ra.ofs + ra.len) (rb.ofs + rb.len) - ofs in
begin match ra.dim , rb.dim with
| Dim(s,da) , Dim(s',db) when s = s' ->
- if len mod s = 0 then
- let ta = abs (ra.ofs - rb.ofs) in
- let tb = abs (ra.ofs + ra.len - rb.ofs - rb.len) in
- if ta mod s = 0 && tb mod s = 0 then
- let reg = mu ~raw:false ra.reg rb.reg in
- let ds = Matrix.join s da db len in
- let dim = Dim(s,ds) in
- aligned := Some { ofs ; len ; reg ; dim }
+ if len mod s = 0 then
+ let ta = abs (ra.ofs - rb.ofs) in
+ let tb = abs (ra.ofs + ra.len - rb.ofs - rb.len) in
+ if ta mod s = 0 && tb mod s = 0 then
+ let reg = mu ~raw:false ra.reg rb.reg in
+ let ds = Matrix.join s da db len in
+ let dim = Dim(s,ds) in
+ aligned := Some { ofs ; len ; reg ; dim }
| _ -> ()
end ;
match !aligned with
@@ -367,8 +367,8 @@ struct
let flatten rg = match rg.dim with
| Dim(s,ds) when ds <> [] ->
- let n = Matrix.sizeof 1 ds in
- { rg with dim = Dim(s,Matrix.array [] n) }
+ let n = Matrix.sizeof 1 ds in
+ { rg with dim = Dim(s,Matrix.array [] n) }
| _ -> rg
let included p n { ofs ; len } =
@@ -395,24 +395,24 @@ struct
match ova , ovb with
| [],ovc | ovc,[] -> ovc
| ra::wa , rb::wb ->
- let sa = ra.ofs + ra.len in
- let sb = rb.ofs + rb.len in
- if sa <= rb.ofs then ra :: merge pp mu wa ovb else
- if sb <= ra.ofs then rb :: merge pp mu ova wb else
- if sa < sb then
- merge pp mu wa (Range.overlap pp mu ra rb :: wb)
- else
- merge pp mu (Range.overlap pp mu ra rb :: wa) wb
+ let sa = ra.ofs + ra.len in
+ let sb = rb.ofs + rb.len in
+ if sa <= rb.ofs then ra :: merge pp mu wa ovb else
+ if sb <= ra.ofs then rb :: merge pp mu ova wb else
+ if sa < sb then
+ merge pp mu wa (Range.overlap pp mu ra rb :: wb)
+ else
+ merge pp mu (Range.overlap pp mu ra rb :: wa) wb
let rec pack eq = function
| ({ dim = Dim(s ,da) } as ra ) ::
({ dim = Dim(s',db) } as rb ) ::
ovl when eq ra.reg rb.reg && s = s' && ra.ofs + ra.len = rb.ofs ->
- let len = ra.len + rb.len in
- let ds = Matrix.join s da db len in
- pack eq ({ ofs = ra.ofs ; len ; reg = ra.reg ; dim = Dim(s,ds) } :: ovl)
+ let len = ra.len + rb.len in
+ let ds = Matrix.join s da db len in
+ pack eq ({ ofs = ra.ofs ; len ; reg = ra.reg ; dim = Dim(s,ds) } :: ovl)
| rg :: ovl ->
- rg :: pack eq ovl
+ rg :: pack eq ovl
| [] -> []
let flatten ovl = List.map Range.flatten ovl
@@ -475,9 +475,9 @@ struct
| Garbled -> Format.pp_print_string fmt "garbled"
| Chunk v -> Value.pretty pp fmt v
| Layout { sizeof ; layout } ->
- Overlay.pretty
- ~title:(fun fmt -> Format.fprintf fmt "sizeof:%d" sizeof)
- pp fmt layout
+ Overlay.pretty
+ ~title:(fun fmt -> Format.fprintf fmt "sizeof:%d" sizeof)
+ pp fmt layout
let deref ~pointed (_,typ) =
match Cil.unrollType typ with
@@ -490,64 +490,64 @@ struct
if s = Cil.bitsSizeOf typ then Some (List.rev rds) else
match Cil.unrollType typ with
| TArray( te , Some e , _ ) ->
- begin match Ctypes.get_int e with
- | None -> None
- | Some n -> get_dim s (if n = 1 then rds else n::rds) te
- end
+ begin match Ctypes.get_int e with
+ | None -> None
+ | Some n -> get_dim s (if n = 1 then rds else n::rds) te
+ end
| _ -> None
let shift_may cache pp offset reg ~inline cluster =
match offset , cluster with
| _ , Garbled -> None
| _ , Empty ->
- let sizeof = Offset.container cache offset in
- Some { sizeof ; layout = [] }
+ let sizeof = Offset.container cache offset in
+ Some { sizeof ; layout = [] }
| Field fd , Chunk v ->
- begin
- let s = Value.sizeof v in
- match get_dim s [] fd.ftype with
- | None -> None
- | Some ds ->
- let dim = Dim(s,ds) in
- Some (Compound.field cache fd reg dim)
- end
+ begin
+ let s = Value.sizeof v in
+ match get_dim s [] fd.ftype with
+ | None -> None
+ | Some ds ->
+ let dim = Dim(s,ds) in
+ Some (Compound.field cache fd reg dim)
+ end
| Index(te,n) , Chunk v ->
- begin
- let s = Value.sizeof v in
- match get_dim s (Matrix.array [] n) te with
- | None -> None
- | Some ds ->
- let dim = Dim(s,ds) in
- Some (Compound.index te n reg dim)
- end
+ begin
+ let s = Value.sizeof v in
+ match get_dim s (Matrix.array [] n) te with
+ | None -> None
+ | Some ds ->
+ let dim = Dim(s,ds) in
+ Some (Compound.index te n reg dim)
+ end
| Field fd , Layout d ->
- let (ofs,len),sizeof = Offset.range_field cache fd in
- if d.sizeof = len then
- let layout =
- if inline then
- List.map (Range.shift ofs) d.layout
- else
- [ { ofs ; len ; reg ; dim=Dim(len,[]) } ]
- in Some { sizeof ; layout }
- else None
+ let (ofs,len),sizeof = Offset.range_field cache fd in
+ if d.sizeof = len then
+ let layout =
+ if inline then
+ List.map (Range.shift ofs) d.layout
+ else
+ [ { ofs ; len ; reg ; dim=Dim(len,[]) } ]
+ in Some { sizeof ; layout }
+ else None
| Index(te,n) , Layout {
sizeof = s ;
layout = [ { ofs=0 ; len ; reg ; dim = Dim(se,dse) } ]
}
when inline && s = len && Cil.bitsSizeOf te = len ->
- let dim = Dim(se,Matrix.array dse n) in
- Some (Compound.index te n reg dim)
+ let dim = Dim(se,Matrix.array dse n) in
+ Some (Compound.index te n reg dim)
| Index(te,n) , Layout { sizeof } ->
- let size = Cil.bitsSizeOf te in
- if sizeof = size then
- let dim = Dim(size,Matrix.array [] n) in
- Some (Compound.index te n reg dim)
- else
- ( if Wp.has_dkey garbled_key then
- Wp.debug ~dkey:garbled_key
- "@[<hv 0>Garbled Offset:@ Index= {%a}[%d];@ Cluster= %a;@]"
- Cil_datatype.Typ.pretty te n (pretty pp) cluster ;
- None )
+ let size = Cil.bitsSizeOf te in
+ if sizeof = size then
+ let dim = Dim(size,Matrix.array [] n) in
+ Some (Compound.index te n reg dim)
+ else
+ ( if Wp.has_dkey garbled_key then
+ Wp.debug ~dkey:garbled_key
+ "@[<hv 0>Garbled Offset:@ Index= {%a}[%d];@ Cluster= %a;@]"
+ Cil_datatype.Typ.pretty te n (pretty pp) cluster ;
+ None )
let shift cache pp offset reg ~inline cluster =
match shift_may cache pp offset reg ~inline cluster
@@ -558,23 +558,23 @@ struct
match a,b with
| Empty , c | c , Empty -> c
| Chunk va , Chunk vb ->
- begin match Value.merge (mu ~raw:false) va vb with
- | None -> Garbled
- | Some v -> Chunk v
- end
+ begin match Value.merge (mu ~raw:false) va vb with
+ | None -> Garbled
+ | Some v -> Chunk v
+ end
| Layout { layout = [ { ofs=0 ; len=la ; reg=ra ; dim=Dim(s,da) } ] } ,
Layout { layout = [ { ofs=0 ; len=lb ; reg=rb ; dim=Dim(s',db) } ] }
when s = s' ->
- let reg = mu ~raw:false ra rb in
- let len = max la lb in
- let ds = Matrix.join s da db len in
- let layout = [ { ofs=0 ; len ; reg ; dim=Dim(s,ds) } ] in
- Layout { sizeof = len ; layout }
+ let reg = mu ~raw:false ra rb in
+ let len = max la lb in
+ let ds = Matrix.join s da db len in
+ let layout = [ { ofs=0 ; len ; reg ; dim=Dim(s,ds) } ] in
+ Layout { sizeof = len ; layout }
| Layout { sizeof ; layout = la } ,
Layout { sizeof = s ; layout = lb }
when s = sizeof ->
- let layout = Overlay.merge pp mu la lb in
- Layout { sizeof ; layout }
+ let layout = Overlay.merge pp mu la lb in
+ Layout { sizeof ; layout }
| _ -> Garbled
let merge pp mu a b =
@@ -587,7 +587,7 @@ struct
let reshape ~eq ~flat ~pack = function
| Layout layout when flat || pack ->
- Layout (Compound.reshape ~eq ~flat ~pack layout)
+ Layout (Compound.reshape ~eq ~flat ~pack layout)
| cluster -> cluster
end
@@ -650,9 +650,9 @@ struct
| Rnone,s | s,Rnone -> s
| Rtop,_ | _,Rtop -> Rtop
| _ ->
- match merge_var a b with
- | Some x -> merge_field x a b
- | None -> Rtop
+ match merge_var a b with
+ | Some x -> merge_field x a b
+ | None -> Rtop
let indexed = function
| Rnone | Rfield _ -> false
diff --git a/src/plugins/wp/Letify.ml b/src/plugins/wp/Letify.ml
index 0e792d0961dc2f5725e360d7578947725e80e8b5..26e6a46ffd3a6d18bea9e093303c1648caaf0c31 100644
--- a/src/plugins/wp/Letify.ml
+++ b/src/plugins/wp/Letify.ml
@@ -50,10 +50,10 @@ struct
let r = match F.repr e with
| Rdef fvs -> List.for_all (fun (_,e) -> is_ground env e) fvs
| Fun(f,es) ->
- begin match Fun.category f with
- | Constructor -> List.for_all (is_ground env) es
- | _ -> false
- end
+ begin match Fun.category f with
+ | Constructor -> List.for_all (is_ground env) es
+ | _ -> false
+ end
| _ -> false in
env.ground <- Tmap.add e r env.ground ; r
end
@@ -79,13 +79,13 @@ struct
begin
match F.repr a , F.repr b with
| Fun(f,_) , Fun(g,_) when Wp_parameters.Reduce.get () ->
- let cmp = frank f - frank g in
- if cmp < 0 then add_sigma env a b else
- if cmp > 0 then add_sigma env b a
+ let cmp = frank f - frank g in
+ if cmp < 0 then add_sigma env a b else
+ if cmp > 0 then add_sigma env b a
| Fun(f,_) , _ when frank f = 0 ->
- add_sigma env a b
+ add_sigma env a b
| _ , Fun(f,_) when frank f = 0 ->
- add_sigma env b a
+ add_sigma env b a
| _ -> ()
end
@@ -94,25 +94,25 @@ struct
| True | False -> ()
| And ps -> List.iter (walk env) ps
| Eq(a,b) ->
- add_clause env h ;
- if is_ground env b then
- add_sigma env a b
- else
- if is_ground env a then
- add_sigma env b a
- else
- reduce env a b
+ add_clause env h ;
+ if is_ground env b then
+ add_sigma env a b
+ else
+ if is_ground env a then
+ add_sigma env b a
+ else
+ reduce env a b
| Fun(f,[x]) ->
- begin
- add_clause env h ;
- try
- let iota = Cint.is_cint f in
- let conv = Cint.convert iota x in
- add_sigma env conv x ;
- with Not_found -> ()
- end
+ begin
+ add_clause env h ;
+ try
+ let iota = Cint.is_cint f in
+ let conv = Cint.convert iota x in
+ add_sigma env conv x ;
+ with Not_found -> ()
+ end
| _ ->
- add_clause env h
+ add_clause env h
let e_apply env = F.e_subst (Subst.copy env.sigma)
let p_apply env = F.p_subst (Subst.copy env.sigma)
@@ -211,11 +211,11 @@ struct
match sigma.cache with
| Some s -> s
| None ->
- let s = Lang.sigma () in
- F.Subst.add_fun s (lookup sigma.def) ;
- F.Subst.add_fun s (fun e -> Tmap.find e sigma.cst) ;
- F.Subst.add_filter s (filter sigma.dall) ;
- sigma.cache <- Some s ; s
+ let s = Lang.sigma () in
+ F.Subst.add_fun s (lookup sigma.def) ;
+ F.Subst.add_fun s (fun e -> Tmap.find e sigma.cst) ;
+ F.Subst.add_filter s (filter sigma.dall) ;
+ sigma.cache <- Some s ; s
let e_apply sigma e = F.e_subst (subst sigma) e
let p_apply sigma p = F.p_subst (subst sigma) p
@@ -309,23 +309,23 @@ struct
let extract_forall_equality fb =
begin match F.repr (F.QED.lc_repr fb) with
| Imply ([la;lb],c) ->
- begin match F.repr c with
- | Eq _ ->
- let order = 0 in (** todo get the order from term *)
- begin match F.repr la, F.repr lb with
- | Leq(a,b), Leq(c,d) ->
- begin
- match F.repr a, F.repr b, F.repr c, F.repr d with
- | Bvar(o1,Int), Kint cstb, Kint csta, Bvar(o2,Int) when
- o1 = order && o2 = order -> Some(csta,cstb)
- | Kint csta, Bvar(o1,Int), Bvar(o2,Int), Kint cstb when
- o1 = order && o2 = order -> Some(csta,cstb)
- | _ -> None
- end
+ begin match F.repr c with
+ | Eq _ ->
+ let order = 0 in (** todo get the order from term *)
+ begin match F.repr la, F.repr lb with
+ | Leq(a,b), Leq(c,d) ->
+ begin
+ match F.repr a, F.repr b, F.repr c, F.repr d with
+ | Bvar(o1,Int), Kint cstb, Kint csta, Bvar(o2,Int) when
+ o1 = order && o2 = order -> Some(csta,cstb)
+ | Kint csta, Bvar(o1,Int), Bvar(o2,Int), Kint cstb when
+ o1 = order && o2 = order -> Some(csta,cstb)
| _ -> None
end
- | _ -> None
- end
+ | _ -> None
+ end
+ | _ -> None
+ end
| _ -> None
end
@@ -334,47 +334,47 @@ struct
let rec add_pred sigma p = match F.repr p with
| And ps -> List.fold_left add_pred sigma ps
| Eq(a,b) ->
- begin
- match F.repr a , F.repr b with
- | Fvar x , _ when not (F.occurs x b) -> add x b sigma
- | _ , Fvar x when not (F.occurs x a) -> add x a sigma
- | _ ->
- match F.is_closed a , F.is_closed b with
- | true , false -> add_cst b a sigma
- | false , true -> add_cst a b sigma
- | true , true ->
- if F.compare a b < 0
- then add_cst b a sigma
- else add_cst a b sigma
- | false , false -> add_lit p sigma
- end
+ begin
+ match F.repr a , F.repr b with
+ | Fvar x , _ when not (F.occurs x b) -> add x b sigma
+ | _ , Fvar x when not (F.occurs x a) -> add x a sigma
+ | _ ->
+ match F.is_closed a , F.is_closed b with
+ | true , false -> add_cst b a sigma
+ | false , true -> add_cst a b sigma
+ | true , true ->
+ if F.compare a b < 0
+ then add_cst b a sigma
+ else add_cst a b sigma
+ | false , false -> add_lit p sigma
+ end
| Leq(a,b) ->
- if mem_lit (e_leq b a) sigma
- then add_pred sigma (e_eq a b)
- else add_lit p sigma
+ if mem_lit (e_leq b a) sigma
+ then add_pred sigma (e_eq a b)
+ else add_lit p sigma
| Lt(a,b) ->
- let sigma = if is_kint b then add_pred sigma (e_leq a (e_add b e_one)) else sigma in
- let sigma = if is_kint a then add_pred sigma (e_leq (e_sub a e_one) b) else sigma in
- add_lit p (add_lit (e_leq a b) (add_lit (e_neq a b) sigma))
+ let sigma = if is_kint b then add_pred sigma (e_leq a (e_add b e_one)) else sigma in
+ let sigma = if is_kint a then add_pred sigma (e_leq (e_sub a e_one) b) else sigma in
+ add_lit p (add_lit (e_leq a b) (add_lit (e_neq a b) sigma))
| Neq _ | Fun _ | Not _ -> add_lit p sigma
| Bind (Forall,Int,fb) ->
- let bound = Integer.of_int (Wp_parameters.BoundForallUnfolding.get ()) in
- begin match extract_forall_equality fb with
- | Some (csta,cstb) when
- Integer.le csta cstb &&
- Integer.le (Integer.sub cstb csta) bound ->
- let rec aux sigma i =
- if Integer.lt cstb i then sigma
- else begin
- let eq = F.QED.e_apply p [e_zint i] in
- (** qed should be able to simplify it directly *)
- let sigma = add_pred sigma eq in
- aux sigma (Integer.succ i)
- end
- in
- aux sigma csta
- | _ -> sigma
- end
+ let bound = Integer.of_int (Wp_parameters.BoundForallUnfolding.get ()) in
+ begin match extract_forall_equality fb with
+ | Some (csta,cstb) when
+ Integer.le csta cstb &&
+ Integer.le (Integer.sub cstb csta) bound ->
+ let rec aux sigma i =
+ if Integer.lt cstb i then sigma
+ else begin
+ let eq = F.QED.e_apply p [e_zint i] in
+ (** qed should be able to simplify it directly *)
+ let sigma = add_pred sigma eq in
+ aux sigma (Integer.succ i)
+ end
+ in
+ aux sigma csta
+ | _ -> sigma
+ end
| _ -> sigma
let assume sigma p = add_pred sigma (F.e_prop p)
@@ -421,9 +421,9 @@ struct
let rec diff s y = function
| [] -> s
| e::es ->
- match F.repr e with
- | Fvar x when x==y -> diff s y es
- | _ -> diff (e_opp e :: s) y es
+ match F.repr e with
+ | Fvar x when x==y -> diff s y es
+ | _ -> diff (e_opp e :: s) y es
let add_linear w x pos neg =
add_def w x (e_sum (diff pos x neg))
@@ -432,20 +432,20 @@ struct
let rec atoms = function
| [] -> []
| e::es ->
- match F.repr e with
- | Fvar x -> x :: atoms es
- | _ -> atoms es
+ match F.repr e with
+ | Fvar x -> x :: atoms es
+ | _ -> atoms es
let rec defs w p =
match F.repr p with
| And ps -> List.iter (defs w) ps
| Eq(a,b) -> defs_eq w a b
| Not p ->
- begin
- match F.repr p with
- | Fvar x -> add_def w x e_false
- | _ -> ()
- end
+ begin
+ match F.repr p with
+ | Fvar x -> add_def w x e_false
+ | _ -> ()
+ end
| Fvar x -> add_def w x e_true
| _ -> ()
@@ -500,10 +500,10 @@ let rec extract defs sref cycle x =
if not (occurs cycle e) then
match F.repr e with
| Fvar y ->
- begin
- try let d = Sigma.find y !sref in rs := d :: !rs
- with Not_found -> ys := y :: !ys
- end
+ begin
+ try let d = Sigma.find y !sref in rs := d :: !rs
+ with Not_found -> ys := y :: !ys
+ end
| _ -> es := e :: !es
) ds ;
(* Now choose the represent of x and the dependencies *)
diff --git a/src/plugins/wp/LogicAssigns.ml b/src/plugins/wp/LogicAssigns.ml
index e5f68039c692a7b87e7853dfc76e18b8bc3c6a73..963c2c936e2db8073163376f8c2e5f64794ebf8c 100644
--- a/src/plugins/wp/LogicAssigns.ml
+++ b/src/plugins/wp/LogicAssigns.ml
@@ -52,18 +52,18 @@ struct
| [] -> Bag.concat (M.Sigma.assigned ~pre:s.pre ~post:s.post D.empty) hs
| [obj,sloc] ->
- let eq_sloc = M.assigned s obj sloc in
- let hs_sloc = Bag.list (List.map Cvalues.equation eq_sloc) in
- let hs_sdom = M.Sigma.assigned ~pre:s.pre ~post:s.post (dsloc obj sloc) in
- Bag.concat (Bag.concat hs_sloc hs_sdom) hs
+ let eq_sloc = M.assigned s obj sloc in
+ let hs_sloc = Bag.list (List.map Cvalues.equation eq_sloc) in
+ let hs_sdom = M.Sigma.assigned ~pre:s.pre ~post:s.post (dsloc obj sloc) in
+ Bag.concat (Bag.concat hs_sloc hs_sdom) hs
| (obj,sloc)::tail ->
- let sigma = M.Sigma.havoc s.post (dsloc obj sloc) in
- let s_local = { pre = sigma ; post = s.post } in
- let s_other = { pre = s.pre ; post = sigma } in
- let eq_sloc = M.assigned s_local obj sloc in
- let hs_sloc = Bag.list (List.map Cvalues.equation eq_sloc) in
- assigned_seq (Bag.concat hs_sloc hs) s_other tail
+ let sigma = M.Sigma.havoc s.post (dsloc obj sloc) in
+ let s_local = { pre = sigma ; post = s.post } in
+ let s_other = { pre = s.pre ; post = sigma } in
+ let eq_sloc = M.assigned s_local obj sloc in
+ let hs_sloc = Bag.list (List.map Cvalues.equation eq_sloc) in
+ assigned_seq (Bag.concat hs_sloc hs) s_other tail
let apply_assigns (s:sigma sequence) (r: M.loc Sigs.region) =
Bag.elements (assigned_seq Bag.empty s r)
diff --git a/src/plugins/wp/LogicBuiltins.ml b/src/plugins/wp/LogicBuiltins.ml
index 04077deac7bbe2232c8eb55c771e16d1e12f6826..b8e4b2639367ab3def3afb961b5a4ec3ecf102c7 100644
--- a/src/plugins/wp/LogicBuiltins.ml
+++ b/src/plugins/wp/LogicBuiltins.ml
@@ -80,15 +80,15 @@ let pp_kind fmt = function
let pp_kinds fmt = function
| [] -> ()
| t::ts ->
- Format.fprintf fmt "(%a" pp_kind t ;
- List.iter (fun t -> Format.fprintf fmt ",%a" pp_kind t) ts ;
- Format.fprintf fmt ")"
+ Format.fprintf fmt "(%a" pp_kind t ;
+ List.iter (fun t -> Format.fprintf fmt ",%a" pp_kind t) ts ;
+ Format.fprintf fmt ")"
let pp_libs fmt = function
| [] -> ()
| t::ts ->
- Format.fprintf fmt ": %s" t ;
- List.iter (fun t -> Format.fprintf fmt ",%s" t) ts
+ Format.fprintf fmt ": %s" t ;
+ List.iter (fun t -> Format.fprintf fmt ",%s" t) ts
let pp_link fmt = function
| ACSLDEF -> Format.pp_print_string fmt "(ACSL)"
@@ -293,8 +293,8 @@ let find_lib file =
let rec lookup file = function
| [] -> Wp_parameters.abort "File '%s' not found" file
| dir::dirs ->
- let path = Printf.sprintf "%s/%s" dir file in
- if Sys.file_exists path then path else lookup file dirs
+ let path = Printf.sprintf "%s/%s" dir file in
+ if Sys.file_exists path then path else lookup file dirs
in
lookup file (cdriver_ro ()).includes
diff --git a/src/plugins/wp/LogicCompiler.ml b/src/plugins/wp/LogicCompiler.ml
index 81aa77b29c469e1cb91c7915c20944925ac0e41d..788b1505046e66bb3d06f0beffb927dcfac94882 100644
--- a/src/plugins/wp/LogicCompiler.ml
+++ b/src/plugins/wp/LogicCompiler.ml
@@ -105,11 +105,11 @@ struct
let has_ltype ltype t =
match Logic_utils.unroll_type ~unroll_typedef:false ltype with
| Ltype (lt, _) ->
- if not (Typedefs.mem lt) then !compile_logic_type ltype ;
- begin match Typedefs.find lt with
- | Some lfun -> F.p_call lfun [t]
- | None -> p_true
- end
+ if not (Typedefs.mem lt) then !compile_logic_type ltype ;
+ begin match Typedefs.find lt with
+ | Some lfun -> F.p_call lfun [t]
+ | None -> p_true
+ end
| Ctype typ -> Cvalues.has_ctype typ t
| _ -> p_true
@@ -280,8 +280,8 @@ struct
let get_call = function
| { call = Some call } -> call
| { descr } ->
- Wp_parameters.fatal
- "Frame '%s' has is outside a function definition" descr
+ Wp_parameters.fatal
+ "Frame '%s' has is outside a function definition" descr
let formal x =
try
@@ -303,19 +303,19 @@ struct
match f.result with
| Some r -> r
| None ->
- let tr = return_type f.kf in
- let basename = Kernel_function.get_name f.kf in
- let x = fresh_cvar ~basename tr in
- let r = R_var x in
- f.result <- Some r ; r
+ let tr = return_type f.kf in
+ let basename = Kernel_function.get_name f.kf in
+ let x = fresh_cvar ~basename tr in
+ let r = R_var x in
+ f.result <- Some r ; r
let status () =
let f = get_call (Context.get cframe) in
match f.status with
| Some x -> x
| None ->
- let x = fresh_cvar ~basename:"status" Cil.intType in
- f.status <- Some x ; x
+ let x = fresh_cvar ~basename:"status" Cil.intType in
+ f.status <- Some x ; x
let trigger tg =
if tg <> Qed.Engine.TgAny then
@@ -407,14 +407,14 @@ struct
let rec profile_env vars domain sigv = function
| [] -> { vars=vars ; lhere=None ; current=None } , domain , List.rev sigv
| lv :: profile ->
- let x = param_of_lv lv in
- let h = has_ltype lv.lv_type (e_var x) in
- let v = Cvalues.plain lv.lv_type (e_var x) in
- profile_env
- (Logic_var.Map.add lv v vars)
- (h::domain)
- ((lv,x)::sigv)
- profile
+ let x = param_of_lv lv in
+ let h = has_ltype lv.lv_type (e_var x) in
+ let v = Cvalues.plain lv.lv_type (e_var x) in
+ profile_env
+ (Logic_var.Map.add lv v vars)
+ (h::domain)
+ ((lv,x)::sigv)
+ profile
let default_label env = function
| [l] -> move_at env (mem_frame (Clabels.of_logic l))
@@ -528,29 +528,29 @@ struct
match l.l_type with
| None -> ()
| Some tr ->
- match Cvalues.ldomain tr with
- | None -> ()
- | Some p ->
- let name = "T" ^ Lang.logic_id l in
- let vs = List.map e_var ldef.d_params in
- let rec conditions vs sigp =
- match vs , sigp with
- | v::vs , Sig_value lv :: sigp ->
- let cond = has_ltype lv.lv_type v in
- cond :: conditions vs sigp
- | _ -> [] in
- let result = F.e_fun ldef.d_lfun vs in
- let lemma = p_hyps (conditions vs sigp) (p result) in
- let trigger = Trigger.of_term result in
- Definitions.define_lemma {
- l_name = name ;
- l_kind = Admit ;
- l_types = ldef.d_types ;
- l_forall = ldef.d_params ;
- l_triggers = [[trigger]] ;
- l_cluster = ldef.d_cluster ;
- l_lemma = lemma ;
- }
+ match Cvalues.ldomain tr with
+ | None -> ()
+ | Some p ->
+ let name = "T" ^ Lang.logic_id l in
+ let vs = List.map e_var ldef.d_params in
+ let rec conditions vs sigp =
+ match vs , sigp with
+ | v::vs , Sig_value lv :: sigp ->
+ let cond = has_ltype lv.lv_type v in
+ cond :: conditions vs sigp
+ | _ -> [] in
+ let result = F.e_fun ldef.d_lfun vs in
+ let lemma = p_hyps (conditions vs sigp) (p result) in
+ let trigger = Trigger.of_term result in
+ Definitions.define_lemma {
+ l_name = name ;
+ l_kind = Admit ;
+ l_types = ldef.d_types ;
+ l_forall = ldef.d_params ;
+ l_triggers = [[trigger]] ;
+ l_cluster = ldef.d_cluster ;
+ l_lemma = lemma ;
+ }
(* -------------------------------------------------------------------------- *)
(* --- Compiling Pure Logic Function --- *)
@@ -639,15 +639,15 @@ struct
match F.repr r with
| Qed.Logic.Kint c -> CST c
| _ ->
- let ldef = {
- d_lfun = ACSL l ;
- d_types = List.length l.l_tparams ;
- d_params = xs ;
- d_cluster = cluster ;
- d_definition = Function(tau,is_recursive l,r) ;
- } in
- Definitions.define_symbol ldef ;
- type_for_signature l ldef s ; SIG s
+ let ldef = {
+ d_lfun = ACSL l ;
+ d_types = List.length l.l_tparams ;
+ d_params = xs ;
+ d_cluster = cluster ;
+ d_definition = Function(tau,is_recursive l,r) ;
+ } in
+ Definitions.define_symbol ldef ;
+ type_for_signature l ldef s ; SIG s
(* -------------------------------------------------------------------------- *)
(* --- Compiling Logic Predicate with Definition --- *)
@@ -670,15 +670,15 @@ struct
let heap_case labels_used support = function
| Sig_value _ -> support
| Sig_chunk(chk,l_case) ->
- let l_ind =
- try LabelMap.find l_case labels_used
- with Not_found -> LabelSet.empty
- in
- let l_chk =
- try Heap.Map.find chk support
- with Not_found -> LabelSet.empty
- in
- Heap.Map.add chk (LabelSet.union l_chk l_ind) support
+ let l_ind =
+ try LabelMap.find l_case labels_used
+ with Not_found -> LabelSet.empty
+ in
+ let l_chk =
+ try Heap.Map.find chk support
+ with Not_found -> LabelSet.empty
+ in
+ Heap.Map.add chk (LabelSet.union l_chk l_ind) support
(* -------------------------------------------------------------------------- *)
(* --- Compiling Inductive Logic --- *)
@@ -736,14 +736,14 @@ struct
Signature.update l (SIG s_rec) ;
match l.l_body with
| LBnone ->
- let vars = match section with
- | Toplevel _ -> []
- | Axiomatic a -> Varinfo.Set.elements a.ax_reads
- in if l.l_labels <> [] && vars = [] then
- Wp_parameters.warning ~once:true ~current:false
- "No definition for '%s' interpreted as reads nothing"
- l.l_var_info.lv_name ;
- compile_lbnone cluster l vars
+ let vars = match section with
+ | Toplevel _ -> []
+ | Axiomatic a -> Varinfo.Set.elements a.ax_reads
+ in if l.l_labels <> [] && vars = [] then
+ Wp_parameters.warning ~once:true ~current:false
+ "No definition for '%s' interpreted as reads nothing"
+ l.l_var_info.lv_name ;
+ compile_lbnone cluster l vars
| LBterm t -> compile_lbterm cluster l t
| LBpred p -> compile_lbpred cluster l p
| LBreads ts -> compile_lbreads cluster l ts
@@ -756,44 +756,44 @@ struct
let define_type cluster lt =
let constrainer = match lt with
| { lt_def = Some(LTsum(ctors)) ; lt_name ; lt_params=[] } ->
- let frame = logic_frame lt_name [] in
- in_frame frame
- begin fun () ->
- let lfun = Lang.generated_p ~coloring:true ("is_" ^ lt_name) in
- let tau_lt = Lang.tau_of_ltype (Ltype(lt, [])) in
- Typedefs.update lt (Some lfun) ;
- let term_constraint ltyp =
- let v = Lang.freshvar ~basename:"p" (Lang.tau_of_ltype ltyp) in
- v, (has_ltype ltyp (Lang.F.e_var v))
- in
- let ctor_to_prop = function
- | { ctor_name = l_name ; ctor_params = ts } as const ->
- let vs, cs = List.split (List.map term_constraint ts) in
- let ts = List.map Lang.F.e_var vs in
- let const = F.e_fun ~result:tau_lt (CTOR const) ts in
- let is_lt = F.p_call lfun [const] in
- {
- l_name ;
- l_types = 0 ;
- l_kind = Admit ;
- l_triggers = [frame.triggers] ;
- l_forall = vs ;
- l_cluster = cluster ;
- l_lemma = p_hyps cs is_lt ;
- }
- in
- let cases = List.map ctor_to_prop ctors in
- Definitions.define_symbol {
- d_lfun = lfun ;
- d_types = 0 ;
- d_params = [ Lang.freshvar ~basename:"v" tau_lt ] ;
- d_cluster = cluster ;
- d_definition = Inductive cases
- } ;
- Some lfun
- end ()
+ let frame = logic_frame lt_name [] in
+ in_frame frame
+ begin fun () ->
+ let lfun = Lang.generated_p ~coloring:true ("is_" ^ lt_name) in
+ let tau_lt = Lang.tau_of_ltype (Ltype(lt, [])) in
+ Typedefs.update lt (Some lfun) ;
+ let term_constraint ltyp =
+ let v = Lang.freshvar ~basename:"p" (Lang.tau_of_ltype ltyp) in
+ v, (has_ltype ltyp (Lang.F.e_var v))
+ in
+ let ctor_to_prop = function
+ | { ctor_name = l_name ; ctor_params = ts } as const ->
+ let vs, cs = List.split (List.map term_constraint ts) in
+ let ts = List.map Lang.F.e_var vs in
+ let const = F.e_fun ~result:tau_lt (CTOR const) ts in
+ let is_lt = F.p_call lfun [const] in
+ {
+ l_name ;
+ l_types = 0 ;
+ l_kind = Admit ;
+ l_triggers = [frame.triggers] ;
+ l_forall = vs ;
+ l_cluster = cluster ;
+ l_lemma = p_hyps cs is_lt ;
+ }
+ in
+ let cases = List.map ctor_to_prop ctors in
+ Definitions.define_symbol {
+ d_lfun = lfun ;
+ d_types = 0 ;
+ d_params = [ Lang.freshvar ~basename:"v" tau_lt ] ;
+ d_cluster = cluster ;
+ d_definition = Inductive cases
+ } ;
+ Some lfun
+ end ()
| { lt_def = Some(LTsum(_)) ; lt_params=_ } ->
- Wp_parameters.not_yet_implemented "Type parameters for sum types"
+ Wp_parameters.not_yet_implemented "Type parameters for sum types"
| _ -> None
in
Typedefs.update lt constrainer ;
@@ -836,37 +836,37 @@ struct
let cluster = Definitions.section section in
match section with
| Toplevel _ ->
- Signature.memoize (compile_logic cluster section) phi
+ Signature.memoize (compile_logic cluster section) phi
| Axiomatic ax ->
- (* force compilation of entire axiomatics *)
- define_axiomatic cluster ax ;
- try Signature.find phi
- with Not_found ->
- Wp_parameters.fatal ~current:true
- "Axiomatic '%s' compiled, but '%a' not"
- ax.ax_name Printer.pp_logic_var phi.l_var_info
+ (* force compilation of entire axiomatics *)
+ define_axiomatic cluster ax ;
+ try Signature.find phi
+ with Not_found ->
+ Wp_parameters.fatal ~current:true
+ "Axiomatic '%s' compiled, but '%a' not"
+ ax.ax_name Printer.pp_logic_var phi.l_var_info
let rec logic_type t =
match Logic_utils.unroll_type ~unroll_typedef:false t with
| Ctype _ -> ()
| Linteger | Lreal | Lvar _ | Larrow _ -> ()
| Ltype(lt,ps) ->
- List.iter logic_type ps ;
- if not (Typedefs.mem lt) then
- begin
- Typedefs.update lt None ;
- if not (Lang.is_builtin lt) &&
- not (Logic_const.is_boolean_type t)
- then
- let section = LogicUsage.section_of_type lt in
- let cluster = Definitions.section section in
- match section with
- | Toplevel _ ->
- define_type cluster lt
- | Axiomatic ax ->
- (* force compilation of entire axiomatics *)
- define_axiomatic cluster ax
- end
+ List.iter logic_type ps ;
+ if not (Typedefs.mem lt) then
+ begin
+ Typedefs.update lt None ;
+ if not (Lang.is_builtin lt) &&
+ not (Logic_const.is_boolean_type t)
+ then
+ let section = LogicUsage.section_of_type lt in
+ let cluster = Definitions.section section in
+ match section with
+ | Toplevel _ ->
+ define_type cluster lt
+ | Axiomatic ax ->
+ (* force compilation of entire axiomatics *)
+ define_axiomatic cluster ax
+ end
let () = compile_logic_type := logic_type
let logic_profile phi =
@@ -883,9 +883,9 @@ struct
match phi_labels, labels with
| [], [] -> LabelMap.empty
| l1 :: phi_labels, l2 :: labels ->
- let l1 = Clabels.of_logic l1 in
- let l2 = Clabels.of_logic l2 in
- LabelMap.add l1 (mem_at env l2) (bind_labels env phi_labels labels)
+ let l1 = Clabels.of_logic l1 in
+ let l2 = Clabels.of_logic l2 in
+ LabelMap.add l1 (mem_at env l2) (bind_labels env phi_labels labels)
| _ -> Wp_parameters.fatal "Incorrect by AST typing"
let call_params env
@@ -901,12 +901,12 @@ struct
(function
| Sig_value lv -> Logic_var.Map.find lv mparams
| Sig_chunk(c,l) ->
- let sigma =
- try LabelMap.find l mlabels
- with Not_found ->
- Wp_parameters.fatal "*** Label %a not-found@." Clabels.pretty l
- in
- M.Sigma.value sigma c
+ let sigma =
+ try LabelMap.find l mlabels
+ with Not_found ->
+ Wp_parameters.fatal "*** Label %a not-found@." Clabels.pretty l
+ in
+ M.Sigma.value sigma c
) sparam
let call_fun env
@@ -917,8 +917,8 @@ struct
match signature phi with
| CST c -> e_zint c
| SIG sparam ->
- let es = call_params env phi labels sparam parameters in
- F.e_fun ~result (ACSL phi) es
+ let es = call_params env phi labels sparam parameters in
+ F.e_fun ~result (ACSL phi) es
let call_pred env
(phi:logic_info)
@@ -927,8 +927,8 @@ struct
match signature phi with
| CST _ -> assert false
| SIG sparam ->
- let es = call_params env phi labels sparam parameters in
- F.p_call (ACSL phi) es
+ let es = call_params env phi labels sparam parameters in
+ F.p_call (ACSL phi) es
(* -------------------------------------------------------------------------- *)
(* --- Variable Bindings --- *)
diff --git a/src/plugins/wp/LogicSemantics.ml b/src/plugins/wp/LogicSemantics.ml
index f9ce31602dd9316b5099a6b4195c33053d7f4340..101a6aa06307174ecdb982d97074daf7cfd5de07 100644
--- a/src/plugins/wp/LogicSemantics.ml
+++ b/src/plugins/wp/LogicSemantics.ml
@@ -96,7 +96,7 @@ struct
| Vexp e -> M.pointer_loc e
| Vloc l -> l
| _ ->
- Warning.error "Non-expected set of locations (%a)" Printer.pp_term t
+ Warning.error "Non-expected set of locations (%a)" Printer.pp_term t
let val_of_term env t =
match C.logic env t with
@@ -104,7 +104,7 @@ struct
| Vloc l -> M.pointer_val l
| Vset s -> Vset.concretize s
| Lset _ ->
- Warning.error "Non-expected set of values (%a)" Printer.pp_term t
+ Warning.error "Non-expected set of values (%a)" Printer.pp_term t
let set_of_term env t = L.vset (C.logic env t)
@@ -112,8 +112,8 @@ struct
let v = C.logic env t in
match v with
| Vexp s when Logic_typing.is_set_type t.term_type ->
- let te = Logic_typing.type_of_set_elem t.term_type in
- Vset [Vset.Set(tau_of_ltype te,s)]
+ let te = Logic_typing.type_of_set_elem t.term_type in
+ Vset [Vset.Set(tau_of_ltype te,s)]
| w -> w
let term env t =
@@ -130,12 +130,12 @@ struct
| TNoOffset -> v
| TModel _ -> Wp_parameters.not_yet_implemented "Model field"
| TField(f,offset) ->
- let v_f = L.map (fun r -> e_getfield r (Cfield (f, KValue))) v in
- access_offset env v_f offset
+ let v_f = L.map (fun r -> e_getfield r (Cfield (f, KValue))) v in
+ access_offset env v_f offset
| TIndex(k,offset) ->
- let rk = C.logic env k in
- let v_k = L.apply e_get v rk in
- access_offset env v_k offset
+ let rk = C.logic env k in
+ let v_k = L.apply e_get v rk in
+ access_offset env v_k offset
(* -------------------------------------------------------------------------- *)
(* --- Updating an Offset (sub field-index in a compound) --- *)
@@ -145,13 +145,13 @@ struct
| TNoOffset -> v
| TModel _ -> Wp_parameters.not_yet_implemented "Model field"
| TField(f,offset) ->
- let r_f = e_getfield r (Cfield (f, KValue)) in
- let r_fv = update_offset env r_f offset v in
- e_setfield r (Cfield (f, KValue)) r_fv
+ let r_f = e_getfield r (Cfield (f, KValue)) in
+ let r_fv = update_offset env r_f offset v in
+ e_setfield r (Cfield (f, KValue)) r_fv
| TIndex(k,offset) ->
- let k = val_of_term env k in
- let r_kv = update_offset env (e_get r k) offset v in
- e_set r k r_kv
+ let k = val_of_term env k in
+ let r_kv = update_offset env (e_get r k) offset v in
+ e_set r k r_kv
(* -------------------------------------------------------------------------- *)
(* --- Shifting Location of an Offset (pointer shift) --- *)
@@ -162,13 +162,13 @@ struct
| TNoOffset -> typ , v
| TModel _ -> Wp_parameters.not_yet_implemented "Model field"
| TField(f,offset) ->
- logic_offset env f.ftype (L.field v f) offset
+ logic_offset env f.ftype (L.field v f) offset
| TIndex(k,offset) ->
- let te = Cil.typeOf_array_elem typ in
- let size = Ctypes.get_array_size (Ctypes.object_of typ) in
- let obj = Ctypes.object_of te in
- let vloc = L.shift v obj ?size (C.logic env k) in
- logic_offset env te vloc offset
+ let te = Cil.typeOf_array_elem typ in
+ let size = Ctypes.get_array_size (Ctypes.object_of typ) in
+ let obj = Ctypes.object_of te in
+ let vloc = L.shift v obj ?size (C.logic env k) in
+ logic_offset env te vloc offset
(* -------------------------------------------------------------------------- *)
(* --- Logic Variable --- *)
@@ -182,10 +182,10 @@ struct
match lv.lv_origin with
| None -> VAL (C.logic_var env lv)
| Some x ->
- if x.vformal then match C.formal x with
- | Some v -> VAL (logic_of_value v)
- | None -> VAR x
- else VAR x
+ if x.vformal then match C.formal x with
+ | Some v -> VAL (logic_of_value v)
+ | None -> VAR x
+ else VAR x
(* -------------------------------------------------------------------------- *)
(* --- Term L-Values (this means 'loading' the l-value) --- *)
@@ -198,25 +198,25 @@ struct
let term_lval env (lhost,loffset) =
match lhost with
| TResult ty ->
- begin match C.result () with
- | Sigs.R_var x ->
- access_offset env (Vexp (e_var x)) loffset
- | Sigs.R_loc l ->
- load_loc env ty l loffset
- end
+ begin match C.result () with
+ | Sigs.R_var x ->
+ access_offset env (Vexp (e_var x)) loffset
+ | Sigs.R_loc l ->
+ load_loc env ty l loffset
+ end
| TMem e ->
- let te = Logic_typing.ctype_of_pointed e.term_type in
- let te , lp = logic_offset env te (C.logic env e) loffset in
- L.load (C.current env) (Ctypes.object_of te) lp
+ let te = Logic_typing.ctype_of_pointed e.term_type in
+ let te , lp = logic_offset env te (C.logic env e) loffset in
+ L.load (C.current env) (Ctypes.object_of te) lp
| TVar{lv_name="\\exit_status"} ->
- assert (loffset = TNoOffset) ; (* int ! *)
- Vexp (e_var (C.status ()))
+ assert (loffset = TNoOffset) ; (* int ! *)
+ Vexp (e_var (C.status ()))
| TVar lv ->
- begin
- match logic_var env lv with
- | VAL v -> access_offset env v loffset
- | VAR x -> load_loc env x.vtype (M.cvar x) loffset
- end
+ begin
+ match logic_var env lv with
+ | VAL v -> access_offset env v loffset
+ | VAR x -> load_loc env x.vtype (M.cvar x) loffset
+ end
(* -------------------------------------------------------------------------- *)
(* --- Address of L-Values --- *)
@@ -225,24 +225,24 @@ struct
let logic_lval env (lhost,loffset) =
match lhost with
| TResult ty ->
- begin match C.result () with
- | R_loc l ->
- logic_offset env ty (Vloc l) loffset
- | R_var _ ->
- Wp_parameters.abort ~current:true "Address of \\result"
- end
+ begin match C.result () with
+ | R_loc l ->
+ logic_offset env ty (Vloc l) loffset
+ | R_var _ ->
+ Wp_parameters.abort ~current:true "Address of \\result"
+ end
| TMem e ->
- let te = Logic_typing.ctype_of_pointed e.term_type in
- logic_offset env te (C.logic env e) loffset
+ let te = Logic_typing.ctype_of_pointed e.term_type in
+ logic_offset env te (C.logic env e) loffset
| TVar lv ->
- begin
- match logic_var env lv with
- | VAL v ->
- Wp_parameters.abort ~current:true
- "Address of logic value (%a)@." (Cvalues.pp_logic M.pretty) v
- | VAR x ->
- logic_offset env x.vtype (Vloc (M.cvar x)) loffset
- end
+ begin
+ match logic_var env lv with
+ | VAL v ->
+ Wp_parameters.abort ~current:true
+ "Address of logic value (%a)@." (Cvalues.pp_logic M.pretty) v
+ | VAR x ->
+ logic_offset env x.vtype (Vloc (M.cvar x)) loffset
+ end
let addr_lval env lv = snd (logic_lval env lv)
@@ -252,8 +252,8 @@ struct
| Vexp e -> te , M.pointer_loc e
| Vloc l -> te , l
| _ ->
- Wp_parameters.abort ~current:true "Unexpected set (%a)"
- Printer.pp_term_lval lv
+ Wp_parameters.abort ~current:true "Unexpected set (%a)"
+ Printer.pp_term_lval lv
(* -------------------------------------------------------------------------- *)
(* --- Unary Operators --- *)
@@ -285,25 +285,25 @@ struct
| Ltype({lt_name="set"},[_]) -> EQ_set
| Linteger | Lreal | Lvar _ | Larrow _ | Ltype _ -> EQ_plain
| Ctype t ->
- match Ctypes.object_of t with
- | C_pointer _ -> EQ_loc
- | C_int _ -> EQ_plain
- | C_float f -> EQ_float f
- | C_comp c -> EQ_comp c
- | C_array a -> EQ_array (Ctypes.array_dimensions a)
+ match Ctypes.object_of t with
+ | C_pointer _ -> EQ_loc
+ | C_int _ -> EQ_plain
+ | C_float f -> EQ_float f
+ | C_comp c -> EQ_comp c
+ | C_array a -> EQ_array (Ctypes.array_dimensions a)
let eqsort_of_comparison a b =
match eqsort_of_type a.term_type , eqsort_of_type b.term_type with
| EQ_set , _ | _ , EQ_set -> EQ_set
| EQ_loc , EQ_loc -> EQ_loc
| EQ_comp c1 , EQ_comp c2 ->
- if Compinfo.equal c1 c2 then EQ_comp c1 else EQ_incomparable
+ if Compinfo.equal c1 c2 then EQ_comp c1 else EQ_incomparable
| EQ_array(t1,d1) , EQ_array(t2,d2) ->
- if Ctypes.equal t1 t2 then
- match Matrix.merge d1 d2 with
- | Some d -> EQ_array(t1,d)
- | None -> EQ_incomparable
- else EQ_incomparable
+ if Ctypes.equal t1 t2 then
+ match Matrix.merge d1 d2 with
+ | Some d -> EQ_array(t1,d)
+ | None -> EQ_incomparable
+ else EQ_incomparable
| EQ_plain , EQ_plain -> EQ_plain
| EQ_float f1 , EQ_float f2 when f1 = f2 -> EQ_float f1
| _ -> EQ_incomparable
@@ -316,42 +316,42 @@ struct
match eqsort_of_comparison a b with
| EQ_set ->
- let sa = set_of_term env a in
- let sb = set_of_term env b in
- (* TODO: should be parametric in the equality of elements *)
- Vset.equal sa sb
+ let sa = set_of_term env a in
+ let sb = set_of_term env b in
+ (* TODO: should be parametric in the equality of elements *)
+ Vset.equal sa sb
| EQ_loc ->
- let la = loc_of_term env a in
- let lb = loc_of_term env b in
- M.loc_eq la lb
+ let la = loc_of_term env a in
+ let lb = loc_of_term env b in
+ M.loc_eq la lb
| EQ_comp c ->
- let va = val_of_term env a in
- let vb = val_of_term env b in
- if use_equal polarity
- then p_equal va vb
- else Cvalues.equal_comp c va vb
+ let va = val_of_term env a in
+ let vb = val_of_term env b in
+ if use_equal polarity
+ then p_equal va vb
+ else Cvalues.equal_comp c va vb
| EQ_array m ->
- let va = val_of_term env a in
- let vb = val_of_term env b in
- if use_equal polarity
- then p_equal va vb
- else Cvalues.equal_array m va vb
+ let va = val_of_term env a in
+ let vb = val_of_term env b in
+ if use_equal polarity
+ then p_equal va vb
+ else Cvalues.equal_array m va vb
| EQ_float f ->
- Cfloat.feq f (val_of_term env a) (val_of_term env b)
+ Cfloat.feq f (val_of_term env a) (val_of_term env b)
| EQ_plain ->
- p_equal (val_of_term env a) (val_of_term env b)
+ p_equal (val_of_term env a) (val_of_term env b)
| EQ_incomparable ->
- (* incomparable terms *)
- Warning.error
- "@[Incomparable terms:@ type %a with@ type %a@]"
- Printer.pp_logic_type a.term_type
- Printer.pp_logic_type b.term_type
+ (* incomparable terms *)
+ Warning.error
+ "@[Incomparable terms:@ type %a with@ type %a@]"
+ Printer.pp_logic_type a.term_type
+ Printer.pp_logic_type b.term_type
let term_diff polarity env a b =
p_not (term_equal (Cvalues.negate polarity) env a b)
@@ -360,9 +360,9 @@ struct
let float_of_logic_type lt =
match Logic_utils.unroll_type lt with
| Ctype ty ->
- (match Cil.unrollType ty with
- | TFloat(f,_) -> Some (Ctypes.c_float f)
- | _ -> None)
+ (match Cil.unrollType ty with
+ | TFloat(f,_) -> Some (Ctypes.c_float f)
+ | _ -> None)
| _ -> None
let compare_term env vrel lrel frel a b =
@@ -405,10 +405,10 @@ struct
match ts with
| [] -> acc
| t::others ->
- match t.term_node with
- | TBinOp(binop,a,b) when bop == binop ->
- fold_assoc bop acc (a::b::others)
- | _ -> fold_assoc bop (t::acc) others
+ match t.term_node with
+ | TBinOp(binop,a,b) when bop == binop ->
+ fold_assoc bop acc (a::b::others)
+ | _ -> fold_assoc bop (t::acc) others
let term_binop env binop a b =
match binop with
@@ -418,20 +418,20 @@ struct
| Div -> arith env (L.apply e_div) (L.apply F.e_div) a b
| Mod -> L.apply e_mod (C.logic env a) (C.logic env b)
| PlusPI ->
- let va = C.logic env a in
- let vb = C.logic env b in
- let te = Logic_typing.ctype_of_pointed a.term_type in
- L.shift va (Ctypes.object_of te) vb
+ let va = C.logic env a in
+ let vb = C.logic env b in
+ let te = Logic_typing.ctype_of_pointed a.term_type in
+ L.shift va (Ctypes.object_of te) vb
| MinusPI ->
- let va = C.logic env a in
- let vb = C.logic env b in
- let te = Logic_typing.ctype_of_pointed a.term_type in
- L.shift va (Ctypes.object_of te) (L.map_opp vb)
+ let va = C.logic env a in
+ let vb = C.logic env b in
+ let te = Logic_typing.ctype_of_pointed a.term_type in
+ L.shift va (Ctypes.object_of te) (L.map_opp vb)
| MinusPP ->
- let te = Logic_typing.ctype_of_pointed a.term_type in
- let la = loc_of_term env a in
- let lb = loc_of_term env b in
- Vexp(M.loc_diff (Ctypes.object_of te) la lb)
+ let te = Logic_typing.ctype_of_pointed a.term_type in
+ let la = loc_of_term env a in
+ let lb = loc_of_term env b in
+ Vexp(M.loc_diff (Ctypes.object_of te) la lb)
| Shiftlt -> L.apply Cint.l_lsl (C.logic env a) (C.logic env b)
| Shiftrt -> L.apply Cint.l_lsr (C.logic env a) (C.logic env b)
| BAnd -> L.apply Cint.l_and (C.logic env a) (C.logic env b)
@@ -464,25 +464,25 @@ struct
| Linteger -> L_integer
| Lreal -> L_real
| Ctype src_ctype ->
- begin
- match Ctypes.object_of src_ctype with
- | C_int i -> L_cint i
- | C_float f -> L_cfloat f
- | C_pointer te -> L_pointer te
- | C_array a -> L_array a (* into the logic, C array = logic array *)
- | C_comp c when c.cstruct ->
- Warning.error "@[Logic cast from struct (%a) not implemented yet@]"
- Printer.pp_typ src_ctype
- | C_comp _ ->
- Warning.error "@[Logic cast from union (%a) not implemented yet@]"
- Printer.pp_typ src_ctype
- end
+ begin
+ match Ctypes.object_of src_ctype with
+ | C_int i -> L_cint i
+ | C_float f -> L_cfloat f
+ | C_pointer te -> L_pointer te
+ | C_array a -> L_array a (* into the logic, C array = logic array *)
+ | C_comp c when c.cstruct ->
+ Warning.error "@[Logic cast from struct (%a) not implemented yet@]"
+ Printer.pp_typ src_ctype
+ | C_comp _ ->
+ Warning.error "@[Logic cast from union (%a) not implemented yet@]"
+ Printer.pp_typ src_ctype
+ end
| Ltype _ as b when Logic_const.is_boolean_type b -> L_bool
| Ltype({lt_name="set"},[elt_ltype]) -> (* lifting or set of elements ? *)
- cvsort_of_ltype elt_ltype
+ cvsort_of_ltype elt_ltype
| (Ltype _ | Lvar _ | Larrow _) as typ ->
- Warning.error "@[Logic cast from (%a) not implemented yet@]"
- Printer.pp_logic_type typ
+ Warning.error "@[Logic cast from (%a) not implemented yet@]"
+ Printer.pp_logic_type typ
(** cast to a C type *)
let term_cast_to_ctype env dst_ctype t =
@@ -497,107 +497,107 @@ struct
match Ctypes.object_of dst_ctype , cvsort_of_ltype t.term_type with
(* Cast to C integers from ...*)
| C_int _ , L_bool ->
- L.map Cvalues.bool_val (C.logic env t)
+ L.map Cvalues.bool_val (C.logic env t)
| C_int i , L_cint i0 ->
- let v = C.logic env t in
- if (Ctypes.sub_c_int i0 i) then v
- else L.map (Cint.convert i) v
+ let v = C.logic env t in
+ if (Ctypes.sub_c_int i0 i) then v
+ else L.map (Cint.convert i) v
| C_int i , L_integer ->
- L.map (Cint.convert i) (C.logic env t)
+ L.map (Cint.convert i) (C.logic env t)
| C_int i , L_pointer _ ->
- L.map_l2t (M.int_of_loc i) (C.logic env t)
+ L.map_l2t (M.int_of_loc i) (C.logic env t)
| C_int i , L_real ->
- L.map (Cint.of_real i) (C.logic env t)
+ L.map (Cint.of_real i) (C.logic env t)
| C_int i , L_cfloat f ->
- L.map (fun v -> Cint.of_real i (Cfloat.real_of_float f v)) (C.logic env t)
+ L.map (fun v -> Cint.of_real i (Cfloat.real_of_float f v)) (C.logic env t)
| C_int _, L_array _ ->
- Warning.error "@[Logic cast to sized integer (%a) from (%a) not implemented yet@]"
- Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
+ Warning.error "@[Logic cast to sized integer (%a) from (%a) not implemented yet@]"
+ Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
(* Cast to C float from ... *)
| C_float f , L_real ->
- L.map (Cfloat.float_of_real f) (C.logic env t)
+ L.map (Cfloat.float_of_real f) (C.logic env t)
| C_float ft, L_cfloat ff ->
- let map v = if Ctypes.equal_float ff ft then v else Cfloat.float_of_real ft (Cfloat.real_of_float ff v) in
- L.map map (C.logic env t)
+ let map v = if Ctypes.equal_float ff ft then v else Cfloat.float_of_real ft (Cfloat.real_of_float ff v) in
+ L.map map (C.logic env t)
| C_float f , (L_cint _ | L_integer) ->
- L.map (Cfloat.float_of_int f) (C.logic env t)
+ L.map (Cfloat.float_of_int f) (C.logic env t)
| C_float _, (L_bool|L_pointer _|L_array _) ->
- Warning.error "@[Logic cast to float (%a) from (%a) not implemented yet@]"
- Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
+ Warning.error "@[Logic cast to float (%a) from (%a) not implemented yet@]"
+ Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
(* Cast to C pointer from ... *)
| C_pointer ty , (L_integer | L_cint _) ->
- let obj = Ctypes.object_of ty in
- L.map_t2l (M.loc_of_int obj) (C.logic env t)
+ let obj = Ctypes.object_of ty in
+ L.map_t2l (M.loc_of_int obj) (C.logic env t)
| C_pointer ty , L_pointer t0 ->
- cast_ptr ty t0
+ cast_ptr ty t0
| C_pointer _, (L_bool|L_real|L_cfloat _|L_array _) ->
- Warning.error "@[Logic cast to pointer (%a) from (%a) not implemented yet@]"
- Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
+ Warning.error "@[Logic cast to pointer (%a) from (%a) not implemented yet@]"
+ Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
(* Cast to C array from ... *)
| C_array _, L_pointer t0 ->
- (* cast to an array `(T[])(p)` is equivalent
- to a deref of a cast to a pointer `*(T( * )[])(p)` *)
- let cast = cast_ptr dst_ctype t0 in
- L.load (C.current env) (Ctypes.object_of dst_ctype) cast
+ (* cast to an array `(T[])(p)` is equivalent
+ to a deref of a cast to a pointer `*(T( * )[])(p)` *)
+ let cast = cast_ptr dst_ctype t0 in
+ L.load (C.current env) (Ctypes.object_of dst_ctype) cast
| C_array dst_arr_info, L_array src_arr_info
when Ctypes.AinfoComparable.equal dst_arr_info src_arr_info ->
- (* cast from/to the same type *)
- C.logic env t
+ (* cast from/to the same type *)
+ C.logic env t
| C_array {arr_flat=Some _}, (L_integer|L_cint _|L_bool|L_real|L_cfloat _|L_array _) ->
- Warning.error "@[Logic cast to sized array (%a) from (%a) not implemented yet@]"
- Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
+ Warning.error "@[Logic cast to sized array (%a) from (%a) not implemented yet@]"
+ Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
| C_array {arr_flat=None}, (L_integer|L_cint _|L_bool|L_real|L_cfloat _|L_array _) ->
- Warning.error "@[Logic cast to unsized array (%a) from (%a) not implemented yet@]"
- Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
+ Warning.error "@[Logic cast to unsized array (%a) from (%a) not implemented yet@]"
+ Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
(* Cast to C compound from ... *)
| C_comp c, (L_integer|L_cint _|L_bool|L_real|L_cfloat _|L_array _|L_pointer _) when c.cstruct ->
- Warning.error "@[Logic cast to struct (%a) from (%a) not implemented yet@]"
- Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
+ Warning.error "@[Logic cast to struct (%a) from (%a) not implemented yet@]"
+ Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
| C_comp _, (L_integer|L_cint _|L_bool|L_real|L_cfloat _|L_array _|L_pointer _) ->
- Warning.error "@[Logic cast to union (%a) from (%a) not implemented yet@]"
- Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
+ Warning.error "@[Logic cast to union (%a) from (%a) not implemented yet@]"
+ Printer.pp_typ dst_ctype Printer.pp_logic_type t.term_type
let term_cast_to_real env t =
let src_ltype = Logic_utils.unroll_type ~unroll_typedef:false t.term_type in
match cvsort_of_ltype src_ltype with
| L_cint _ ->
- L.map (fun x -> Cmath.real_of_int (Cint.to_integer x)) (C.logic env t)
+ L.map (fun x -> Cmath.real_of_int (Cint.to_integer x)) (C.logic env t)
| L_integer ->
- L.map Cmath.real_of_int (C.logic env t)
+ L.map Cmath.real_of_int (C.logic env t)
| L_cfloat f ->
- L.map (Cfloat.real_of_float f) (C.logic env t)
+ L.map (Cfloat.real_of_float f) (C.logic env t)
| L_real -> C.logic env t
| L_bool|L_pointer _|L_array _ ->
- Warning.error "@[Logic cast from (%a) to (%a) not implemented yet@]"
- Printer.pp_logic_type src_ltype Printer.pp_logic_type Lreal
+ Warning.error "@[Logic cast from (%a) to (%a) not implemented yet@]"
+ Printer.pp_logic_type src_ltype Printer.pp_logic_type Lreal
let term_cast_to_integer env t =
let src_ltype = Logic_utils.unroll_type ~unroll_typedef:false t.term_type in
match cvsort_of_ltype src_ltype with
| L_real ->
- L.map Cmath.int_of_real (C.logic env t)
+ L.map Cmath.int_of_real (C.logic env t)
| L_cint _ ->
- L.map Cint.to_integer (C.logic env t)
+ L.map Cint.to_integer (C.logic env t)
| L_integer -> C.logic env t
| L_cfloat f ->
- L.map
- (fun x -> Cmath.int_of_real (Cfloat.real_of_float f x))
- (C.logic env t)
+ L.map
+ (fun x -> Cmath.int_of_real (Cfloat.real_of_float f x))
+ (C.logic env t)
| L_bool ->
- L.map Cmath.bool_of_int (C.logic env t)
+ L.map Cmath.bool_of_int (C.logic env t)
| L_pointer _|L_array _ ->
- Warning.error "@[Logic cast from (%a) to (%a) not implemented yet@]"
- Printer.pp_logic_type src_ltype Printer.pp_logic_type Linteger
+ Warning.error "@[Logic cast from (%a) to (%a) not implemented yet@]"
+ Printer.pp_logic_type src_ltype Printer.pp_logic_type Linteger
let term_cast_to_boolean env t =
let src_ltype = Logic_utils.unroll_type ~unroll_typedef:false t.term_type in
match cvsort_of_ltype src_ltype with
| L_bool -> C.logic env t
| L_integer | L_cint _ ->
- L.map Cmath.int_of_bool (C.logic env t)
+ L.map Cmath.int_of_bool (C.logic env t)
| L_real | L_cfloat _ | L_pointer _ | L_array _ ->
- Warning.error "@[Logic cast from (%a) to (%a) not implemented yet@]"
- Printer.pp_logic_type src_ltype Printer.pp_logic_type Logic_const.boolean_type
+ Warning.error "@[Logic cast from (%a) to (%a) not implemented yet@]"
+ Printer.pp_logic_type src_ltype Printer.pp_logic_type Logic_const.boolean_type
let rec term_cast_to_ltype env dst_ltype t =
match Logic_utils.unroll_type ~unroll_typedef:false dst_ltype with
@@ -606,11 +606,11 @@ struct
| Lreal -> term_cast_to_real env t
| Ltype _ as b when Logic_const.is_boolean_type b -> term_cast_to_boolean env t
| Ltype({lt_name="set"},[elt_ltype]) -> (* lifting, set of elements ? *)
- term_cast_to_ltype env elt_ltype t
+ term_cast_to_ltype env elt_ltype t
| (Ltype _ | Lvar _ | Larrow _) as dst_ltype ->
- let src_ltype = Logic_utils.unroll_type ~unroll_typedef:false t.term_type in
- Warning.error "@[Logic cast to (%a) from (%a) not implemented yet@]"
- Printer.pp_logic_type dst_ltype Printer.pp_logic_type src_ltype
+ let src_ltype = Logic_utils.unroll_type ~unroll_typedef:false t.term_type in
+ Warning.error "@[Logic cast to (%a) from (%a) not implemented yet@]"
+ Printer.pp_logic_type dst_ltype Printer.pp_logic_type src_ltype
(* -------------------------------------------------------------------------- *)
@@ -621,15 +621,15 @@ struct
let rec acc xs env hs = function
| [] -> List.rev xs , env , hs
| v::vs ->
- let t = Lang.tau_of_ltype v.lv_type in
- let x = Lang.freshvar ~basename:v.lv_name t in
- let h =
- if Wp_parameters.SimplifyForall.get ()
- then F.p_true
- else C.has_ltype v.lv_type (e_var x)
- in
- let e = C.env_let env v (Vexp (e_var x)) in
- acc (x::xs) e (h::hs) vs in
+ let t = Lang.tau_of_ltype v.lv_type in
+ let x = Lang.freshvar ~basename:v.lv_name t in
+ let h =
+ if Wp_parameters.SimplifyForall.get ()
+ then F.p_true
+ else C.has_ltype v.lv_type (e_var x)
+ in
+ let e = C.env_let env v (Vexp (e_var x)) in
+ acc (x::xs) e (h::hs) vs in
acc [] env [] qs
(* -------------------------------------------------------------------------- *)
@@ -648,26 +648,26 @@ struct
match t.term_node with
| TConst c -> Vexp (Cvalues.logic_constant c)
| TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ ->
- Vexp (Cvalues.constant_term t)
+ Vexp (Cvalues.constant_term t)
| TLval lval ->
- if Cil.isVolatileTermLval lval &&
- Cvalues.volatile ~warn:"unsafe volatile access to (term) l-value" ()
- then term_undefined t
- else term_lval env lval
+ if Cil.isVolatileTermLval lval &&
+ Cvalues.volatile ~warn:"unsafe volatile access to (term) l-value" ()
+ then term_undefined t
+ else term_lval env lval
| TAddrOf lval -> addr_lval env lval
| TStartOf lval ->
- begin
- let lt = Cil.typeOfTermLval lval in
- let base = addr_lval env lval in
- match Logic_utils.unroll_type lt with
- | Ctype ct ->
- L.map_loc (fun l -> Cvalues.startof ~shift:M.shift l ct) base
- | _ -> base
- end
+ begin
+ let lt = Cil.typeOfTermLval lval in
+ let base = addr_lval env lval in
+ match Logic_utils.unroll_type lt with
+ | Ctype ct ->
+ L.map_loc (fun l -> Cvalues.startof ~shift:M.shift l ct) base
+ | _ -> base
+ end
| TUnOp(Neg,t) when not (Logic_typing.is_integral_type t.term_type) ->
- L.map F.e_opp (C.logic env t)
+ L.map F.e_opp (C.logic env t)
| TUnOp(unop,t) -> term_unop unop (C.logic env t)
| TBinOp(binop,a,b) -> term_binop env binop a b
@@ -675,93 +675,93 @@ struct
| TLogic_coerce(typ,t) -> term_cast_to_ltype env typ t
| Tapp(f,ls,ts) ->
- let vs = List.map (val_of_term env) ts in
- let result = Lang.tau_of_ltype t.term_type in
- let r = match LogicBuiltins.logic f with
- | ACSLDEF -> C.call_fun env result f ls vs
- | HACK phi -> phi vs
- | LFUN f -> e_fun ~result f vs
- in Vexp r
+ let vs = List.map (val_of_term env) ts in
+ let result = Lang.tau_of_ltype t.term_type in
+ let r = match LogicBuiltins.logic f with
+ | ACSLDEF -> C.call_fun env result f ls vs
+ | HACK phi -> phi vs
+ | LFUN f -> e_fun ~result f vs
+ in Vexp r
| Tlambda _ ->
- Warning.error "Lambda-functions not yet implemented"
+ Warning.error "Lambda-functions not yet implemented"
| TDataCons({ctor_name="\\true"},_) -> Vexp(e_true)
| TDataCons({ctor_name="\\false"},_) -> Vexp(e_false)
| TDataCons(c,ts) ->
- let es = List.map (val_of_term env) ts in
- let r = match LogicBuiltins.ctor c with
- | ACSLDEF -> e_fun (CTOR c) es
- | HACK phi -> phi es
- | LFUN f -> e_fun f es ~result:(Lang.tau_of_ltype t.term_type)
- in Vexp r
+ let es = List.map (val_of_term env) ts in
+ let r = match LogicBuiltins.ctor c with
+ | ACSLDEF -> e_fun (CTOR c) es
+ | HACK phi -> phi es
+ | LFUN f -> e_fun f es ~result:(Lang.tau_of_ltype t.term_type)
+ in Vexp r
| Tif( cond , a , b ) ->
- let c = val_of_term env cond in
- let a = val_of_term env a in
- let b = val_of_term env b in
- Vexp (e_if c a b)
+ let c = val_of_term env cond in
+ let a = val_of_term env a in
+ let b = val_of_term env b in
+ Vexp (e_if c a b)
| Tat( t , label ) ->
- let clabel = Clabels.of_logic label in
- C.logic (C.env_at env clabel) t
+ let clabel = Clabels.of_logic label in
+ C.logic (C.env_at env clabel) t
| Tbase_addr (label,t) ->
- ignore label ;
- L.map_loc M.base_addr (C.logic env t)
+ ignore label ;
+ L.map_loc M.base_addr (C.logic env t)
| Toffset (label,t) ->
- ignore label ;
- L.map_l2t M.base_offset (C.logic env t)
+ ignore label ;
+ L.map_l2t M.base_offset (C.logic env t)
| Tblock_length (label,t) ->
- let obj = object_of (Logic_typing.ctype_of_pointed t.term_type) in
- let sigma = C.mem_at env (of_logic label) in
- L.map_l2t (M.block_length sigma obj) (C.logic env t)
+ let obj = object_of (Logic_typing.ctype_of_pointed t.term_type) in
+ let sigma = C.mem_at env (of_logic label) in
+ L.map_l2t (M.block_length sigma obj) (C.logic env t)
| Tnull ->
- Vloc M.null
+ Vloc M.null
| TUpdate(a,offset,b) ->
- Vexp (update_offset env (val_of_term env a) offset (val_of_term env b))
+ Vexp (update_offset env (val_of_term env a) offset (val_of_term env b))
| Tempty_set -> Vset []
| Tunion ts ->
- L.union t.term_type (List.map (collection_of_term env) ts)
+ L.union t.term_type (List.map (collection_of_term env) ts)
| Tinter ts ->
- L.inter t.term_type (List.map (collection_of_term env) ts)
+ L.inter t.term_type (List.map (collection_of_term env) ts)
| Tcomprehension(t,qs,cond) ->
- begin
- let xs,env,domain = bind_quantifiers env qs in
- let condition = match cond with
- | None -> p_conj domain
- | Some p ->
- let cc = C.pred `NoPolarity env in
- let p = Lang.without_assume cc p in
- p_conj (p :: domain)
- in match C.logic env t with
- | Vexp e -> Vset[Vset.Descr(xs,e,condition)]
- | Vloc l -> Lset[Sdescr(xs,l,condition)]
- | _ -> Wp_parameters.fatal "comprehension set of sets"
- end
+ begin
+ let xs,env,domain = bind_quantifiers env qs in
+ let condition = match cond with
+ | None -> p_conj domain
+ | Some p ->
+ let cc = C.pred `NoPolarity env in
+ let p = Lang.without_assume cc p in
+ p_conj (p :: domain)
+ in match C.logic env t with
+ | Vexp e -> Vset[Vset.Descr(xs,e,condition)]
+ | Vloc l -> Lset[Sdescr(xs,l,condition)]
+ | _ -> Wp_parameters.fatal "comprehension set of sets"
+ end
| Tlet( { l_var_info=v ; l_body=LBterm a } , b ) ->
- let va = C.logic env a in
- C.logic (C.env_let env v va) b
+ let va = C.logic env a in
+ C.logic (C.env_let env v va) b
| Tlet _ ->
- Warning.error "Complex let-binding not implemented yet (%a)"
- Printer.pp_term t
+ Warning.error "Complex let-binding not implemented yet (%a)"
+ Printer.pp_term t
| Trange(a,b) ->
- let bound env = function
- | None -> None
- | Some x -> Some (val_of_term env x)
- in Vset(Vset.range (bound env a) (bound env b))
+ let bound env = function
+ | None -> None
+ | Some x -> Some (val_of_term env x)
+ in Vset(Vset.range (bound env a) (bound env b))
| Ttypeof _ | Ttype _ ->
- Warning.error "Type tag not implemented yet"
+ Warning.error "Type tag not implemented yet"
(* -------------------------------------------------------------------------- *)
(* --- Separated --- *)
@@ -810,19 +810,19 @@ struct
let call_pred env f ls es =
match C.logic_info env f with
| Some p ->
- if ls <> [] || es <> [] then
- Warning.error "Unexpected parameters for named predicate '%a'"
- Logic_info.pretty f ; p
+ if ls <> [] || es <> [] then
+ Warning.error "Unexpected parameters for named predicate '%a'"
+ Logic_info.pretty f ; p
| None ->
- let empty ls =
- if ls <> [] then
- Warning.error "Unexpected labels for purely logic '%a'"
- Logic_info.pretty f ;
- in
- match LogicBuiltins.logic f with
- | ACSLDEF -> C.call_pred env f ls es
- | HACK phi -> empty ls ; F.p_bool (phi es)
- | LFUN p -> empty ls ; p_call p es
+ let empty ls =
+ if ls <> [] then
+ Warning.error "Unexpected labels for purely logic '%a'"
+ Logic_info.pretty f ;
+ in
+ match LogicBuiltins.logic f with
+ | ACSLDEF -> C.call_pred env f ls es
+ | HACK phi -> empty ls ; F.p_bool (phi es)
+ | LFUN p -> empty ls ; p_call p es
let predicate polarity env p =
match p.pred_content with
@@ -834,49 +834,49 @@ struct
| Por(a,b) -> p_or (C.pred polarity env a) (C.pred polarity env b)
| Pxor(a,b) -> p_not (p_equiv (C.pred `NoPolarity env a) (C.pred `NoPolarity env b))
| Pimplies(a,b) ->
- let negated = Cvalues.negate polarity in
- p_imply (C.pred negated env a) (C.pred polarity env b)
+ let negated = Cvalues.negate polarity in
+ p_imply (C.pred negated env a) (C.pred polarity env b)
| Piff(a,b) -> p_equiv (C.pred `NoPolarity env a) (C.pred `NoPolarity env b)
| Pnot a -> p_not (C.pred (Cvalues.negate polarity) env a)
| Pif(t,a,b) ->
- p_if (p_bool (val_of_term env t))
- (C.pred polarity env a)
- (C.pred polarity env b)
+ p_if (p_bool (val_of_term env t))
+ (C.pred polarity env a)
+ (C.pred polarity env b)
| Papp({l_var_info = {lv_name = "\\subset"}},_,ts) ->
- begin match ts with
- | [a;b] -> L.subset
- a.term_type (C.logic env a)
- b.term_type (C.logic env b)
- | _ -> Warning.error "\\subset requires 2 arguments"
- end
+ begin match ts with
+ | [a;b] -> L.subset
+ a.term_type (C.logic env a)
+ b.term_type (C.logic env b)
+ | _ -> Warning.error "\\subset requires 2 arguments"
+ end
| Papp(f,ls,ts) ->
- call_pred env f ls @@ List.map (val_of_term env) ts
+ call_pred env f ls @@ List.map (val_of_term env) ts
| Plet( { l_var_info=v ; l_body=LBterm a } , p ) ->
- let va = C.logic env a in
- C.pred polarity (C.env_let env v va) p
+ let va = C.logic env a in
+ C.pred polarity (C.env_let env v va) p
| Plet( { l_var_info=v ; l_body=LBpred q } , p ) ->
- let vq = C.pred `NoPolarity env q in
- C.pred polarity (C.env_letp env v vq) p
+ let vq = C.pred `NoPolarity env q in
+ C.pred polarity (C.env_letp env v vq) p
| Plet _ ->
- Warning.error "Complex let-inding not implemented yet (%a)"
- Printer.pp_predicate p
+ Warning.error "Complex let-inding not implemented yet (%a)"
+ Printer.pp_predicate p
| Pforall(qs,p) ->
- let xs,env,hs = bind_quantifiers env qs in
- let p = Lang.without_assume (C.pred polarity env) p in
- p_forall xs (p_hyps hs p)
+ let xs,env,hs = bind_quantifiers env qs in
+ let p = Lang.without_assume (C.pred polarity env) p in
+ p_forall xs (p_hyps hs p)
| Pexists(qs,p) ->
- let xs,env,hs = bind_quantifiers env qs in
- let p = Lang.without_assume (C.pred polarity env) p in
- p_exists xs (p_conj (p :: hs))
+ let xs,env,hs = bind_quantifiers env qs in
+ let p = Lang.without_assume (C.pred polarity env) p in
+ p_exists xs (p_conj (p :: hs))
| Pat(p,label) ->
- let clabel = Clabels.of_logic label in
- C.pred polarity (C.env_at env clabel) p
+ let clabel = Clabels.of_logic label in
+ C.pred polarity (C.env_at env clabel) p
| Pvalid(label,t) -> valid env RW label t
| Pvalid_read(label,t) -> valid env RD label t
@@ -885,14 +885,14 @@ struct
| Pinitialized(label, t) -> initialized env label t
| Pvalid_function _t ->
- Warning.error
- "\\valid_function not yet implemented@\n\
- @[<hov 0>(%a)@]" Printer.pp_predicate p
+ Warning.error
+ "\\valid_function not yet implemented@\n\
+ @[<hov 0>(%a)@]" Printer.pp_predicate p
| Pallocable _ | Pfreeable _ | Pfresh _ | Pdangling _ ->
- Warning.error
- "Allocation, initialization and danglingness not yet implemented@\n\
- @[<hov 0>(%a)@]" Printer.pp_predicate p
+ Warning.error
+ "Allocation, initialization and danglingness not yet implemented@\n\
+ @[<hov 0>(%a)@]" Printer.pp_predicate p
(* -------------------------------------------------------------------------- *)
@@ -903,8 +903,8 @@ struct
match fst lv with
| TResult _ | TVar{lv_name="\\exit_status"} -> [] (* special case ! *)
| _ ->
- let obj = Ctypes.object_of_logic_type (Cil.typeOfTermLval lv) in
- L.region obj (addr_lval env lv)
+ let obj = Ctypes.object_of_logic_type (Cil.typeOfTermLval lv) in
+ L.region obj (addr_lval env lv)
let assignable env t =
match t.term_node with
@@ -913,32 +913,32 @@ struct
| Tunion ts -> List.concat (List.map (C.region env) ts)
| Tinter _ -> Warning.error "Intersection in assigns not implemented yet"
| Tcomprehension(t,qs,cond) ->
- begin
- let xs,env,domain = bind_quantifiers env qs in
- let conditions = match cond with
- | None -> domain
- | Some p -> C.pred `NoPolarity env p :: domain
- in
- List.map
- (function (obj,sloc) ->
- obj , match sloc with
- | Sloc l -> Sdescr(xs,l,p_conj conditions)
- | (Sarray _ | Srange _ | Sdescr _) as sloc ->
- let ys,l,extend = L.rdescr sloc in
- Sdescr(xs@ys,l,p_conj (extend :: conditions))
- ) (C.region env t)
- end
+ begin
+ let xs,env,domain = bind_quantifiers env qs in
+ let conditions = match cond with
+ | None -> domain
+ | Some p -> C.pred `NoPolarity env p :: domain
+ in
+ List.map
+ (function (obj,sloc) ->
+ obj , match sloc with
+ | Sloc l -> Sdescr(xs,l,p_conj conditions)
+ | (Sarray _ | Srange _ | Sdescr _) as sloc ->
+ let ys,l,extend = L.rdescr sloc in
+ Sdescr(xs@ys,l,p_conj (extend :: conditions))
+ ) (C.region env t)
+ end
| Tat(t,label) ->
- C.region (C.env_at env (Clabels.of_logic label)) t
+ C.region (C.env_at env (Clabels.of_logic label)) t
| Tlet( { l_var_info=v ; l_body=LBterm a } , b ) ->
- let va = C.logic env a in
- C.region (C.env_let env v va) b
+ let va = C.logic env a in
+ C.region (C.env_let env v va) b
| Tlet _ ->
- Warning.error "Complex let-binding not implemented yet (%a)"
- Printer.pp_term t
+ Warning.error "Complex let-binding not implemented yet (%a)"
+ Printer.pp_term t
| TCastE (_,t)
| TLogic_coerce(_,t) -> C.region env t
@@ -965,17 +965,17 @@ struct
let pred_protected polarity env p =
match polarity with
| `Positive ->
- Warning.handle
- ~effect:"Target turned to False"
- ~severe:true ~handler:(fun _ -> p_false)
- (predicate `Positive env) p
+ Warning.handle
+ ~effect:"Target turned to False"
+ ~severe:true ~handler:(fun _ -> p_false)
+ (predicate `Positive env) p
| `Negative ->
- Warning.handle
- ~effect:"Ignored Hypothesis"
- ~severe:false ~handler:(fun _ -> p_true)
- (predicate `Negative env) p
+ Warning.handle
+ ~effect:"Ignored Hypothesis"
+ ~severe:false ~handler:(fun _ -> p_true)
+ (predicate `Negative env) p
| `NoPolarity ->
- predicate `NoPolarity env p
+ predicate `NoPolarity env p
(* -------------------------------------------------------------------------- *)
(* --- Boot Strapping --- *)
@@ -1037,8 +1037,8 @@ struct
| Sarray(l,_,_) -> M.occurs x l
| Srange(l,_,a,b) -> M.occurs x l || occurs_opt x a || occurs_opt x b
| Sdescr(xs,l,p) ->
- if List.exists (Var.equal x) xs then false
- else (M.occurs x l || F.occursp x p)
+ if List.exists (Var.equal x) xs then false
+ else (M.occurs x l || F.occursp x p)
let occurs x region = List.exists (fun (_,s) -> occurs_sloc x s) region
@@ -1047,13 +1047,13 @@ struct
let vars_sloc = function
| Sloc l
| Sarray(l,_,_) ->
- M.vars l
+ M.vars l
| Srange(l,_,a,b) ->
- Vars.union (M.vars l) (Vars.union (vars_opt a) (vars_opt b))
+ Vars.union (M.vars l) (Vars.union (vars_opt a) (vars_opt b))
| Sdescr(xs,l,p) ->
- List.fold_left
- (fun xs x -> Vars.remove x xs)
- (Vars.union (M.vars l) (F.varsp p)) xs
+ List.fold_left
+ (fun xs x -> Vars.remove x xs)
+ (Vars.union (M.vars l) (F.varsp p)) xs
let vars region =
List.fold_left
@@ -1075,32 +1075,32 @@ struct
let range size = Some e_zero, Some (e_sub (e_int size) e_one) in
match sloc with
| Sloc loc ->
- begin match obj with
- | C_pointer _ | C_int _ | C_float _
- | C_comp { cfields = None } | C_array { arr_flat = None } ->
- (* Nothing to unfold *)
- p_false
-
- | C_comp { cfields = Some fields } ->
- let assignable_field f =
- let reg = Ctypes.object_of f.ftype, Sloc (M.field loc f) in
- assignable_region (unfold-1) reg assignable
- in
- p_conj (List.map assignable_field fields)
-
- | C_array { arr_flat = Some { arr_size=len ; arr_cell=typ } } ->
- let obj = Ctypes.object_of typ in
- assignable_unfolded_range unfold loc obj (range len) assignable
- end
+ begin match obj with
+ | C_pointer _ | C_int _ | C_float _
+ | C_comp { cfields = None } | C_array { arr_flat = None } ->
+ (* Nothing to unfold *)
+ p_false
+
+ | C_comp { cfields = Some fields } ->
+ let assignable_field f =
+ let reg = Ctypes.object_of f.ftype, Sloc (M.field loc f) in
+ assignable_region (unfold-1) reg assignable
+ in
+ p_conj (List.map assignable_field fields)
+
+ | C_array { arr_flat = Some { arr_size=len ; arr_cell=typ } } ->
+ let obj = Ctypes.object_of typ in
+ assignable_unfolded_range unfold loc obj (range len) assignable
+ end
| Sarray (loc, obj, len) ->
- assignable_unfolded_range unfold loc obj (range len) assignable
+ assignable_unfolded_range unfold loc obj (range len) assignable
| Srange (loc, obj, b, e) ->
- assignable_unfolded_range unfold loc obj (b, e) assignable
+ assignable_unfolded_range unfold loc obj (b, e) assignable
| Sdescr (xs, loc, guard) ->
- assignable_unfolded_descr unfold obj xs loc guard assignable
+ assignable_unfolded_descr unfold obj xs loc guard assignable
and assignable_unfolded_range unfold loc obj (low, up) =
let x = Lang.freshvar ~basename:"k" Lang.t_int in
diff --git a/src/plugins/wp/LogicUsage.ml b/src/plugins/wp/LogicUsage.ml
index 73c014d98693b1db3d65e66adeb477c644091570..da74400e580d1cb25a4d00e556574a76ce44c383 100644
--- a/src/plugins/wp/LogicUsage.ml
+++ b/src/plugins/wp/LogicUsage.ml
@@ -161,13 +161,13 @@ let compute_logicname l =
match LSet.elements over with
| [] | [_] -> d.names <- LMap.add l base d.names ; base
| symbols ->
- let rec register k = function
- | l::ls ->
- let name = Printf.sprintf "%s_%d_" base k in
- d.names <- LMap.add l name d.names ;
- register (succ k) ls
- | [] -> ()
- in register 1 symbols ; LMap.find l d.names
+ let rec register k = function
+ | l::ls ->
+ let name = Printf.sprintf "%s_%d_" base k in
+ d.names <- LMap.add l name d.names ;
+ register (succ k) ls
+ | [] -> ()
+ in register 1 symbols ; LMap.find l d.names
let is_overloaded l =
let d = Database.get () in
@@ -179,12 +179,12 @@ let pp_profile fmt l =
match l.l_profile with
| [] -> ()
| x::xs ->
- Format.fprintf fmt "@[<hov 1>(%a" Printer.pp_logic_type x.lv_type ;
- List.iter
- (fun y -> Format.fprintf fmt ",@,%a"
- Printer.pp_logic_type y.lv_type)
- xs ;
- Format.fprintf fmt ")@]"
+ Format.fprintf fmt "@[<hov 1>(%a" Printer.pp_logic_type x.lv_type ;
+ List.iter
+ (fun y -> Format.fprintf fmt ",@,%a"
+ Printer.pp_logic_type y.lv_type)
+ xs ;
+ Format.fprintf fmt ")@]"
(* -------------------------------------------------------------------------- *)
(* --- Utilities --- *)
@@ -200,15 +200,15 @@ let ip_lemma l =
let lemma_of_global ~context = function
| Dlemma(name,labels,types,pred,attrs,loc) ->
- {
- lem_name = name ;
- lem_position = fst loc ;
- lem_types = types ;
- lem_labels = labels ;
- lem_predicate = pred ;
- lem_depends = context ;
- lem_attrs = attrs ;
- }
+ {
+ lem_name = name ;
+ lem_position = fst loc ;
+ lem_types = types ;
+ lem_labels = labels ;
+ lem_predicate = pred ;
+ lem_depends = context ;
+ lem_attrs = attrs ;
+ }
| _ -> assert false
let populate a ~context = function
@@ -224,18 +224,18 @@ let ip_of_axiomatic g =
let axiomatic_of_global ~context = function
| Daxiomatic(name,globals,_,loc) as g ->
- let a = {
- ax_name = name ;
- ax_position = fst loc ;
- ax_property = ip_of_axiomatic g ;
- ax_reads = Varinfo.Set.empty ;
- ax_types = [] ; ax_lemmas = [] ; ax_logics = [] ;
- } in
- List.iter (populate a ~context) globals ;
- a.ax_types <- List.rev a.ax_types ;
- a.ax_logics <- List.rev a.ax_logics ;
- a.ax_lemmas <- List.rev a.ax_lemmas ;
- a
+ let a = {
+ ax_name = name ;
+ ax_position = fst loc ;
+ ax_property = ip_of_axiomatic g ;
+ ax_reads = Varinfo.Set.empty ;
+ ax_types = [] ; ax_lemmas = [] ; ax_logics = [] ;
+ } in
+ List.iter (populate a ~context) globals ;
+ a.ax_types <- List.rev a.ax_types ;
+ a.ax_logics <- List.rev a.ax_logics ;
+ a.ax_lemmas <- List.rev a.ax_lemmas ;
+ a
| _ -> assert false
let register_logic d section l =
@@ -318,14 +318,14 @@ class visitor =
method private do_call l labels =
match inductive with
| Some case ->
- if Logic_info.equal l case.ind_logic then
- case.ind_call <- List.fold_left2 add_call case.ind_call l.l_labels labels
+ if Logic_info.equal l case.ind_logic then
+ case.ind_call <- List.fold_left2 add_call case.ind_call l.l_labels labels
| None ->
- match caller with
- | None -> ()
- | Some f ->
- if Logic_info.equal f l then
- database.recursives <- LSet.add f database.recursives
+ match caller with
+ | None -> ()
+ | Some f ->
+ if Logic_info.equal f l then
+ database.recursives <- LSet.add f database.recursives
method private do_case l (case,_labels,_types,pnamed) =
begin
@@ -368,51 +368,51 @@ class visitor =
(* --- AXIOMATICS --- *)
| Daxiomatic _ ->
- begin
- let pf = database.proofcontext in
- let ax = axiomatic_of_global pf global in
- register_axiomatic database ax ;
- axiomatic <- Some ax ;
- DoChildrenPost
- (fun g ->
- if not (is_global_axiomatic ax) then
- database.proofcontext <- pf ;
- axiomatic <- None ;
- toplevel <- succ toplevel ;
- g)
- end
+ begin
+ let pf = database.proofcontext in
+ let ax = axiomatic_of_global pf global in
+ register_axiomatic database ax ;
+ axiomatic <- Some ax ;
+ DoChildrenPost
+ (fun g ->
+ if not (is_global_axiomatic ax) then
+ database.proofcontext <- pf ;
+ axiomatic <- None ;
+ toplevel <- succ toplevel ;
+ g)
+ end
(* --- LOGIC INFO --- *)
| Dtype_annot(l,_)
| Dinvariant(l,_)
| Dfun_or_pred(l,_) ->
- begin
- register_logic database self#section l ;
- match l.l_body with
- | LBnone when axiomatic = None -> SkipChildren
+ begin
+ register_logic database self#section l ;
+ match l.l_body with
+ | LBnone when axiomatic = None -> SkipChildren
- | LBnone | LBreads _ | LBterm _ | LBpred _ ->
- caller <- Some l ;
- DoChildrenPost (fun g -> caller <- None ; g)
+ | LBnone | LBreads _ | LBterm _ | LBpred _ ->
+ caller <- Some l ;
+ DoChildrenPost (fun g -> caller <- None ; g)
- | LBinductive cases ->
- register_cases l (List.map (self#do_case l) cases) ;
- SkipChildren
- end
+ | LBinductive cases ->
+ register_cases l (List.map (self#do_case l) cases) ;
+ SkipChildren
+ end
(* --- LEMMAS --- *)
| Dlemma _ ->
- let lem = lemma_of_global database.proofcontext global in
- register_lemma database self#section lem ;
- if Logic_utils.use_predicate lem.lem_predicate.tp_kind then
- database.proofcontext <- lem :: database.proofcontext ;
- SkipChildren
+ let lem = lemma_of_global database.proofcontext global in
+ register_lemma database self#section lem ;
+ if Logic_utils.use_predicate lem.lem_predicate.tp_kind then
+ database.proofcontext <- lem :: database.proofcontext ;
+ SkipChildren
| Dtype(t,_) ->
- register_type database self#section t ;
- SkipChildren
+ register_type database self#section t ;
+ SkipChildren
(* --- OTHERS --- *)
diff --git a/src/plugins/wp/Matrix.ml b/src/plugins/wp/Matrix.ml
index 3b1ca91772e1ebbeb8d3f8ea4d875257bbc6040f..1a52f8f5621f2b23d29432a01fc28d3e1560201e 100644
--- a/src/plugins/wp/Matrix.ml
+++ b/src/plugins/wp/Matrix.ml
@@ -71,47 +71,47 @@ type env = {
let rec collect rank = function
| [] ->
- {
- size_var = [] ;
- size_val = [] ;
- index_var = [] ;
- index_val = [] ;
- index_range = [] ;
- index_offset = [] ;
- length = Some e_one ;
- }
+ {
+ size_var = [] ;
+ size_val = [] ;
+ index_var = [] ;
+ index_val = [] ;
+ index_range = [] ;
+ index_offset = [] ;
+ length = Some e_one ;
+ }
| d::ds ->
- let denv = collect (succ rank) ds in
- let k_base = match rank with 0 -> "i" | 1 -> "j" | _ -> "k" in
- let k_var = Lang.freshvar ~basename:k_base Qed.Logic.Int in
- let k_val = e_var k_var in
- let k_ofs = e_prod (k_val :: denv.size_val) in
- match d with
- | `Ext ->
- { denv with
- index_var = k_var :: denv.index_var ;
- index_val = k_val :: denv.index_val ;
- index_offset = k_ofs :: denv.index_offset ;
- length = None ;
- }
- | `Fix ->
- let n_base = match rank with 0 -> "n" | 1 -> "m" | _ -> "d" in
- let n_var = Lang.freshvar ~basename:n_base Qed.Logic.Int in
- let n_val = e_var n_var in
- let k_inf = p_leq e_zero k_val in
- let k_sup = p_lt k_val n_val in
- let length = match denv.length with
- | None -> None
- | Some len -> Some (e_mul n_val len)
- in {
- size_var = n_var :: denv.size_var ;
- size_val = n_val :: denv.size_val ;
- index_var = k_var :: denv.index_var ;
- index_val = k_val :: denv.index_val ;
- index_offset = k_ofs :: denv.index_offset ;
- index_range = k_inf :: k_sup :: denv.index_range ;
- length ;
- }
+ let denv = collect (succ rank) ds in
+ let k_base = match rank with 0 -> "i" | 1 -> "j" | _ -> "k" in
+ let k_var = Lang.freshvar ~basename:k_base Qed.Logic.Int in
+ let k_val = e_var k_var in
+ let k_ofs = e_prod (k_val :: denv.size_val) in
+ match d with
+ | `Ext ->
+ { denv with
+ index_var = k_var :: denv.index_var ;
+ index_val = k_val :: denv.index_val ;
+ index_offset = k_ofs :: denv.index_offset ;
+ length = None ;
+ }
+ | `Fix ->
+ let n_base = match rank with 0 -> "n" | 1 -> "m" | _ -> "d" in
+ let n_var = Lang.freshvar ~basename:n_base Qed.Logic.Int in
+ let n_val = e_var n_var in
+ let k_inf = p_leq e_zero k_val in
+ let k_sup = p_lt k_val n_val in
+ let length = match denv.length with
+ | None -> None
+ | Some len -> Some (e_mul n_val len)
+ in {
+ size_var = n_var :: denv.size_var ;
+ size_val = n_val :: denv.size_val ;
+ index_var = k_var :: denv.index_var ;
+ index_val = k_val :: denv.index_val ;
+ index_offset = k_ofs :: denv.index_offset ;
+ index_range = k_inf :: k_sup :: denv.index_range ;
+ length ;
+ }
let cc_env = collect 0
@@ -132,10 +132,10 @@ let rec do_merge ds1 ds2 =
| [] , [] -> []
| [] , _ | _ , [] -> raise Exit
| d1::ds1 , d2::ds2 ->
- let d = match d1 , d2 with
- | None , _ | _ , None -> None
- | Some n1 , Some n2 -> if n1=n2 then d1 else raise Exit
- in d :: do_merge ds1 ds2
+ let d = match d1 , d2 with
+ | None , _ | _ , None -> None
+ | Some n1 , Some n2 -> if n1=n2 then d1 else raise Exit
+ in d :: do_merge ds1 ds2
let merge ds1 ds2 =
try Some(do_merge ds1 ds2)
diff --git a/src/plugins/wp/MemDebug.ml b/src/plugins/wp/MemDebug.ml
index 3bbb3ce1476182a5820cf93b52e51fffb1582d48..e8f274c809dfa06256bd2a56df8ac8415b358145 100644
--- a/src/plugins/wp/MemDebug.ml
+++ b/src/plugins/wp/MemDebug.ml
@@ -48,18 +48,18 @@ let pp_value pp_loc fmt = function
let pp_rloc pp_loc fmt = function
| Rloc(_obj,l) -> Format.fprintf fmt "[@{%a}@]" pp_loc l
| Rrange(l,_obj,tmin,tmax) ->
- Format.fprintf fmt "@[%a+(%a..%a)@]" pp_loc l
- (Pretty_utils.pp_opt pp_term) tmin (Pretty_utils.pp_opt pp_term) tmax
+ Format.fprintf fmt "@[%a+(%a..%a)@]" pp_loc l
+ (Pretty_utils.pp_opt pp_term) tmin (Pretty_utils.pp_opt pp_term) tmax
let pp_sloc pp_loc fmt = function
| Sloc l -> Format.fprintf fmt "@[{%a}@]" pp_loc l
| Sarray(l,_obj,size) -> Format.fprintf fmt "@[%a+(0..%d)@]" pp_loc l size
| Srange(l,_obj,tmin,tmax) ->
- Format.fprintf fmt "@[%a+(%a..%a)@]" pp_loc l
- (Pretty_utils.pp_opt pp_term) tmin (Pretty_utils.pp_opt pp_term) tmax
+ Format.fprintf fmt "@[%a+(%a..%a)@]" pp_loc l
+ (Pretty_utils.pp_opt pp_term) tmin (Pretty_utils.pp_opt pp_term) tmax
| Sdescr(xs,l,p) ->
- Format.fprintf fmt "@[{ %a @,| %a@,; %a }@]" pp_loc l
- (Pretty_utils.pp_list pp_var) xs pp_pred p
+ Format.fprintf fmt "@[{ %a @,| %a@,; %a }@]" pp_loc l
+ (Pretty_utils.pp_list pp_var) xs pp_pred p
(* ------------------------------------------------------------------------ *)
(* ---- Debug Memory Model ---- *)
diff --git a/src/plugins/wp/MemLoader.ml b/src/plugins/wp/MemLoader.ml
index 982ecd1a45a26f259ca3486a7e2f826007d6688f..0679550d2dffde557893d88c6baaa45828bdf250 100644
--- a/src/plugins/wp/MemLoader.ml
+++ b/src/plugins/wp/MemLoader.ml
@@ -275,13 +275,13 @@ struct
match c.cfields with
| None -> Definitions.Logic result
| Some fields ->
- let def = List.map
- (fun f ->
- Cfield (f, Info.kind) ,
- Info.load sigma (object_of f.ftype) (M.field loc f)
- ) fields
- in
- Definitions.Function( result , Def , e_record def )
+ let def = List.map
+ (fun f ->
+ Cfield (f, Info.kind) ,
+ Info.load sigma (object_of f.ftype) (M.field loc f)
+ ) fields
+ in
+ Definitions.Function( result , Def , e_record def )
in
Definitions.define_symbol {
d_lfun = lfun ; d_types = 0 ;
@@ -443,11 +443,11 @@ struct
let def = match c.cfields with
| None -> Logic Lang.t_prop
| Some fields ->
- let def = p_all
- (fun f -> !isinitrec sigma (object_of f.ftype) (M.field loc f))
- fields
- in
- Predicate(Def, def)
+ let def = p_all
+ (fun f -> !isinitrec sigma (object_of f.ftype) (M.field loc f))
+ fields
+ in
+ Predicate(Def, def)
in
Definitions.define_symbol {
d_lfun = lfun ; d_types = 0 ;
@@ -544,15 +544,15 @@ struct
let initialized sigma = function
| Rloc(obj, loc) -> initialized_loc sigma obj loc
| Rrange(loc, obj, Some low, Some up) ->
- let x = Lang.freshvar ~basename:"i" Lang.t_int in
- let v = e_var x in
- let hyps = [ p_leq low v ; p_leq v up] in
- let loc = M.shift loc obj v in
- p_forall [x] (p_hyps hyps (initialized_loc sigma obj loc))
+ let x = Lang.freshvar ~basename:"i" Lang.t_int in
+ let v = e_var x in
+ let hyps = [ p_leq low v ; p_leq v up] in
+ let loc = M.shift loc obj v in
+ p_forall [x] (p_hyps hyps (initialized_loc sigma obj loc))
| Rrange(_l, _, low, up) ->
- Wp_parameters.abort ~current:true
- "Invalid infinite range @[<hov 2>+@,(%a@,..%a)@]"
- Vset.pp_bound low Vset.pp_bound up
+ Wp_parameters.abort ~current:true
+ "Invalid infinite range @[<hov 2>+@,(%a@,..%a)@]"
+ Vset.pp_bound low Vset.pp_bound up
module INIT_LOADER =
LOADER_GEN
@@ -621,16 +621,16 @@ struct
let stored seq obj loc value =
match obj with
| C_int _ | C_float _ | C_pointer _ ->
- [ updated_atom seq obj loc value ]
+ [ updated_atom seq obj loc value ]
| C_comp _ | C_array _ ->
- Set(load_value seq.post obj loc, value) :: havoc seq obj loc
+ Set(load_value seq.post obj loc, value) :: havoc seq obj loc
let stored_init seq obj loc value =
match obj with
| C_int _ | C_float _ | C_pointer _ ->
- [ updated_init_atom seq loc value ]
+ [ updated_init_atom seq loc value ]
| C_comp _ | C_array _ ->
- Set(load_init seq.post obj loc, value) :: havoc_init seq obj loc
+ Set(load_init seq.post obj loc, value) :: havoc_init seq obj loc
let copied s obj p q = stored s obj p (load_value s.pre obj q)
@@ -643,12 +643,12 @@ struct
let assigned_loc seq obj loc =
match obj with
| C_int _ | C_float _ | C_pointer _ ->
- let value = Lang.freshvar ~basename:"v" (Lang.tau_of_object obj) in
- let init = Lang.freshvar ~basename:"i" (Lang.init_of_object obj) in
- [ updated_init_atom seq loc (e_var init) ;
- updated_atom seq obj loc (e_var value) ]
+ let value = Lang.freshvar ~basename:"v" (Lang.tau_of_object obj) in
+ let init = Lang.freshvar ~basename:"i" (Lang.init_of_object obj) in
+ [ updated_init_atom seq loc (e_var init) ;
+ updated_atom seq obj loc (e_var value) ]
| C_comp _ | C_array _ ->
- havoc seq obj loc @ havoc_init seq obj loc
+ havoc seq obj loc @ havoc_init seq obj loc
let assigned_range s obj l a b =
havoc_length s obj (M.shift l obj a) (e_range a b) @
@@ -659,23 +659,23 @@ struct
match sloc with
| Sloc loc -> assigned_loc seq obj loc
| Sdescr(xs,loc,condition) ->
- let ps = ref [] in
- Domain.iter
- (fun c ->
- let m1 = Sigma.value seq.pre c in
- let m2 = Sigma.value seq.post c in
- let p,separated,equal = M.eqmem_forall obj loc c m1 m2 in
- let sep_from_all = F.p_forall xs (F.p_imply condition separated) in
- let phi = F.p_forall p (F.p_imply sep_from_all equal) in
- ps := Assert phi :: !ps
- ) (domain obj loc) ;
- !ps
+ let ps = ref [] in
+ Domain.iter
+ (fun c ->
+ let m1 = Sigma.value seq.pre c in
+ let m2 = Sigma.value seq.post c in
+ let p,separated,equal = M.eqmem_forall obj loc c m1 m2 in
+ let sep_from_all = F.p_forall xs (F.p_imply condition separated) in
+ let phi = F.p_forall p (F.p_imply sep_from_all equal) in
+ ps := Assert phi :: !ps
+ ) (domain obj loc) ;
+ !ps
| Sarray(loc,obj,n) ->
- assigned_range seq obj loc e_zero (e_int (n-1))
+ assigned_range seq obj loc e_zero (e_int (n-1))
| Srange(loc,obj,u,v) ->
- let a = match u with Some a -> a | None -> e_zero in
- let b = match v with Some b -> b | None -> M.last seq.pre obj loc in
- assigned_range seq obj loc a b
+ let a = match u with Some a -> a | None -> e_zero in
+ let b = match v with Some b -> b | None -> M.last seq.pre obj loc in
+ assigned_range seq obj loc a b
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/MemMemory.ml b/src/plugins/wp/MemMemory.ml
index 7c4439368ec666ff44f8782f3c23ba1709fccd26..7abc48fbe81daae3a1a7d4501320d4c79dfcdc3d 100644
--- a/src/plugins/wp/MemMemory.ml
+++ b/src/plugins/wp/MemMemory.ml
@@ -195,27 +195,27 @@ let register ?(base=nop) ?(offset=nop) ?equal ?(linear=false) lfun =
let r_separated = function
| [p;a;q;b] ->
- if a == F.e_one && b == F.e_one then F.e_neq p q
- else
- begin
- let a_negative = F.e_leq a F.e_zero in
- let b_negative = F.e_leq b F.e_zero in
- if a_negative == e_true || b_negative == e_true then e_true else
- let bp = a_base p in
- let bq = a_base q in
- let open Qed.Logic in
- match F.is_true (F.e_eq bp bq) with
- | No -> e_true (* Have S *)
- | Yes when (a_negative == e_false && b_negative == e_false) ->
- (* Reduced to S *)
- let p_ofs = a_offset p in
- let q_ofs = a_offset q in
- let p_ofs' = F.e_add p_ofs a in
- let q_ofs' = F.e_add q_ofs b in
- F.e_or [ F.e_leq q_ofs' p_ofs ;
- F.e_leq p_ofs' q_ofs ]
- | _ -> raise Not_found
- end
+ if a == F.e_one && b == F.e_one then F.e_neq p q
+ else
+ begin
+ let a_negative = F.e_leq a F.e_zero in
+ let b_negative = F.e_leq b F.e_zero in
+ if a_negative == e_true || b_negative == e_true then e_true else
+ let bp = a_base p in
+ let bq = a_base q in
+ let open Qed.Logic in
+ match F.is_true (F.e_eq bp bq) with
+ | No -> e_true (* Have S *)
+ | Yes when (a_negative == e_false && b_negative == e_false) ->
+ (* Reduced to S *)
+ let p_ofs = a_offset p in
+ let q_ofs = a_offset q in
+ let p_ofs' = F.e_add p_ofs a in
+ let q_ofs' = F.e_add q_ofs b in
+ F.e_or [ F.e_leq q_ofs' p_ofs ;
+ F.e_leq p_ofs' q_ofs ]
+ | _ -> raise Not_found
+ end
| _ -> raise Not_found
let is_separated args = F.is_true (r_separated args)
@@ -250,33 +250,33 @@ let is_separated args = F.is_true (r_separated args)
let r_included = function
| [p;a;q;b] ->
- if F.e_eq p q == F.e_true
- then F.e_imply [F.e_lt F.e_zero a] (F.e_leq a b) (* INC_P *)
- else
- if (F.e_eq a b == F.e_true) && (F.e_lt F.e_zero a == F.e_true)
- then F.e_eq p q (* INC_A *)
- else
- begin
- let a_empty = F.e_leq a F.e_zero in
- let b_negative = F.e_lt b F.e_zero in
- if a_empty == F.e_true then F.e_true (* INC_1 *) else
- if b_negative == F.e_true then a_empty (* INC_2 *) else
- let bp = a_base p in
- let bq = a_base q in
- let open Qed.Logic in
- match F.is_true (F.e_eq bp bq) with
- | No -> a_empty (* INC_3 *)
- | Yes when (a_empty == e_false && b_negative == e_false) ->
- (* INC_4 *)
- let p_ofs = a_offset p in
- let q_ofs = a_offset q in
- if a == b then F.e_eq p_ofs q_ofs
- else
- let p_ofs' = e_add p_ofs a in
- let q_ofs' = e_add q_ofs b in
- e_and [ F.e_leq q_ofs p_ofs ; F.e_leq p_ofs' q_ofs' ]
- | _ -> raise Not_found
- end
+ if F.e_eq p q == F.e_true
+ then F.e_imply [F.e_lt F.e_zero a] (F.e_leq a b) (* INC_P *)
+ else
+ if (F.e_eq a b == F.e_true) && (F.e_lt F.e_zero a == F.e_true)
+ then F.e_eq p q (* INC_A *)
+ else
+ begin
+ let a_empty = F.e_leq a F.e_zero in
+ let b_negative = F.e_lt b F.e_zero in
+ if a_empty == F.e_true then F.e_true (* INC_1 *) else
+ if b_negative == F.e_true then a_empty (* INC_2 *) else
+ let bp = a_base p in
+ let bq = a_base q in
+ let open Qed.Logic in
+ match F.is_true (F.e_eq bp bq) with
+ | No -> a_empty (* INC_3 *)
+ | Yes when (a_empty == e_false && b_negative == e_false) ->
+ (* INC_4 *)
+ let p_ofs = a_offset p in
+ let q_ofs = a_offset q in
+ if a == b then F.e_eq p_ofs q_ofs
+ else
+ let p_ofs' = e_add p_ofs a in
+ let q_ofs' = e_add q_ofs b in
+ e_and [ F.e_leq q_ofs p_ofs ; F.e_leq p_ofs' q_ofs' ]
+ | _ -> raise Not_found
+ end
| _ -> raise Not_found
(* -------------------------------------------------------------------------- *)
@@ -304,11 +304,11 @@ let r_havoc = function
*)
let r_get_havoc = function
| [undef;m;p;a] ->
- (fun _ k ->
- match is_separated [p;a;k;e_one] with
- | L.Yes -> F.e_get m k
- | L.No -> F.e_get undef k
- | _ -> raise Not_found)
+ (fun _ k ->
+ match is_separated [p;a;k;e_one] with
+ | L.Yes -> F.e_get m k
+ | L.No -> F.e_get undef k
+ | _ -> raise Not_found)
| _ -> raise Not_found
(* -------------------------------------------------------------------------- *)
@@ -340,7 +340,7 @@ let null_base p = e_eq (F.e_fun f_base [p]) F.e_zero
*)
let r_valid_unref = function
| [_; p; n] when F.decide (null_base p) ->
- e_leq n e_zero
+ e_leq n e_zero
| _ -> raise Not_found
(* - lemma valid_obj_null: forall m n. valid_obj m null n *)
@@ -411,47 +411,47 @@ type range =
let range ~shift ~addrof ~sizeof = function
| Sigs.Rloc(obj,loc) ->
- LOC( addrof loc , sizeof obj )
+ LOC( addrof loc , sizeof obj )
| Sigs.Rrange(loc,obj,Some a,Some b) ->
- let s = sizeof obj in
- let p = addrof (shift loc obj a) in
- let n = e_mul s (e_range a b) in
- LOC( p , n )
+ let s = sizeof obj in
+ let p = addrof (shift loc obj a) in
+ let n = e_mul s (e_range a b) in
+ LOC( p , n )
| Sigs.Rrange(loc,_obj,None,None) ->
- RANGE( a_base (addrof loc) , Vset.range None None )
+ RANGE( a_base (addrof loc) , Vset.range None None )
| Sigs.Rrange(loc,obj,Some a,None) ->
- let s = sizeof obj in
- RANGE( a_base (addrof loc) , Vset.range (Some (e_mul s a)) None )
+ let s = sizeof obj in
+ RANGE( a_base (addrof loc) , Vset.range (Some (e_mul s a)) None )
| Sigs.Rrange(loc,obj,None,Some b) ->
- let s = sizeof obj in
- RANGE( a_base (addrof loc) , Vset.range None (Some (e_mul s b)) )
+ let s = sizeof obj in
+ RANGE( a_base (addrof loc) , Vset.range None (Some (e_mul s b)) )
let range_set = function
| LOC(l,n) ->
- let a = a_offset l in
- let b = e_add a n in
- a_base l , Vset.range (Some a) (Some b)
+ let a = a_offset l in
+ let b = e_add a n in
+ a_base l , Vset.range (Some a) (Some b)
| RANGE(base,set) -> base , set
let r_included r1 r2 =
match r1 , r2 with
| LOC(l1,n1) , LOC(l2,n2) ->
- F.p_call p_included [l1;n1;l2;n2]
+ F.p_call p_included [l1;n1;l2;n2]
| _ ->
- let base1,set1 = range_set r1 in
- let base2,set2 = range_set r2 in
- F.p_if (F.p_equal base1 base2)
- (Vset.subset set1 set2)
- (Vset.is_empty set1)
+ let base1,set1 = range_set r1 in
+ let base2,set2 = range_set r2 in
+ F.p_if (F.p_equal base1 base2)
+ (Vset.subset set1 set2)
+ (Vset.is_empty set1)
let r_disjoint r1 r2 =
match r1 , r2 with
| LOC(l1,n1) , LOC(l2,n2) ->
- F.p_call p_separated [l1;n1;l2;n2]
+ F.p_call p_separated [l1;n1;l2;n2]
| _ ->
- let base1,set1 = range_set r1 in
- let base2,set2 = range_set r2 in
- F.p_imply (F.p_equal base1 base2) (Vset.disjoint set1 set2)
+ let base1,set1 = range_set r1 in
+ let base2,set2 = range_set r2 in
+ F.p_imply (F.p_equal base1 base2) (Vset.disjoint set1 set2)
let included ~shift ~addrof ~sizeof s1 s2 =
let range = range ~shift ~addrof ~sizeof in
diff --git a/src/plugins/wp/MemRegion.ml b/src/plugins/wp/MemRegion.ml
index e08946df3de2743a715726d38307fc91d6cfef70..9f86b8738ba75753bd0ac92c41fb22fbb3669523 100644
--- a/src/plugins/wp/MemRegion.ml
+++ b/src/plugins/wp/MemRegion.ml
@@ -138,24 +138,24 @@ let phi_consistent index =
match F.repr index with
| L.Fun(f,[]) when f == f_inull -> F.e_false
| L.Fun(f,[x]) when f == f_index_var ->
- F.e_neq x F.e_zero
+ F.e_neq x F.e_zero
| L.Fun(f,[l]) when f == f_index_ref ->
- F.e_prop @@ p_consistent l
+ F.e_prop @@ p_consistent l
| L.Fun(f,[l;k;n]) when f == f_index_mem ->
- F.e_prop @@ F.p_conj @@ p_range k n [p_consistent l]
+ F.e_prop @@ F.p_conj @@ p_range k n [p_consistent l]
| L.Fun(f,es) ->
- F.e_prop @@ (IndexBuiltin.find f).consistent es
+ F.e_prop @@ (IndexBuiltin.find f).consistent es
| _ -> raise Not_found
let phi_consistent_range index sizeof =
match F.repr index with
| L.Fun(f,[l;k;n]) when f == f_index_mem ->
- F.e_prop @@ F.p_conj @@ F.[
- p_leq e_zero sizeof ;
- p_leq e_zero k ;
- p_leq (e_add k sizeof) n ;
- p_consistent l ;
- ]
+ F.e_prop @@ F.p_conj @@ F.[
+ p_leq e_zero sizeof ;
+ p_leq e_zero k ;
+ p_leq (e_add k sizeof) n ;
+ p_consistent l ;
+ ]
| _ -> raise Not_found
let () = Context.register
@@ -228,11 +228,11 @@ struct
let pretty fmt = function
| [] -> Format.fprintf fmt "{}"
| p::ps ->
- begin
- Format.fprintf fmt "@[<hov 2>{%d" p ;
- List.iter (fun p -> Format.fprintf fmt ",@,%d" p) ps ;
- Format.fprintf fmt "}@]" ;
- end
+ begin
+ Format.fprintf fmt "@[<hov 2>{%d" p ;
+ List.iter (fun p -> Format.fprintf fmt ",@,%d" p) ps ;
+ Format.fprintf fmt "}@]" ;
+ end
let compare = Stdlib.compare
@@ -242,8 +242,8 @@ struct
match F.repr a with
| L.Add es -> List.fold_left walk s es
| L.Kint z ->
- (try s + Integer.to_int_exn z
- with Z.Overflow -> s)
+ (try s + Integer.to_int_exn z
+ with Z.Overflow -> s)
| _ -> s
in walk 0 k
@@ -329,9 +329,9 @@ struct
let rec add_range_dims ps ks ns =
match ks , ns with
| k::ks , n::ns ->
- add_range_dims F.(p_range k (e_int n) ps) ks ns
+ add_range_dims F.(p_range k (e_int n) ps) ks ns
| k::ks , [] ->
- add_range_dims F.(p_equal e_zero k :: ps) ks []
+ add_range_dims F.(p_equal e_zero k :: ps) ks []
| [] , _ -> ps
(* Consistent index.
@@ -345,11 +345,11 @@ struct
match F.repr a with
| L.Add es -> List.fold_left get_linear poly es
| L.Kint z ->
- (try (Integer.to_int_exn z,F.e_one)::poly
- with Z.Overflow -> (1,a)::poly)
+ (try (Integer.to_int_exn z,F.e_one)::poly
+ with Z.Overflow -> (1,a)::poly)
| L.Times(c,e) ->
- (try (Integer.to_int_exn c,e)::poly
- with Z.Overflow -> (1,a)::poly)
+ (try (Integer.to_int_exn c,e)::poly
+ with Z.Overflow -> (1,a)::poly)
| _ -> (1,a)::poly
(* Some of linear form *)
@@ -362,16 +362,16 @@ struct
let rec euclid q r ci = function
| [] -> q,r
| (c,k)::poly ->
- let q0 = c / ci in
- let r0 = c mod ci in
- euclid (F.e_add q (F.e_fact q0 k)) ((r0,k)::r) ci poly
+ let q0 = c / ci in
+ let r0 = c mod ci in
+ euclid (F.e_add q (F.e_fact q0 k)) ((r0,k)::r) ci poly
(* Linear offset decomposed on each coefficient *)
let rec add_linear_index cs ks ks' p =
match cs , ks with
| c :: cs , k :: ks ->
- let k' , r = euclid k [] c p in
- add_linear_index cs ks (k'::ks') r
+ let k' , r = euclid k [] c p in
+ add_linear_index cs ks (k'::ks') r
| _ -> List.rev_append ks' ks , p
(* Linear offset and remainder delta *)
@@ -382,12 +382,12 @@ struct
(* Builtin simplifier *)
let builtin_index cs f es p = match es with
| l::ks ->
- let ks' , r = offset cs ks p in
- if Qed.Hcons.equal_list F.equal ks ks' then
- raise Not_found
- else
- let l' = F.e_fun f (l :: ks) in
- l_shift_index l' r
+ let ks' , r = offset cs ks p in
+ if Qed.Hcons.equal_list F.equal ks ks' then
+ raise Not_found
+ else
+ let l' = F.e_fun f (l :: ks) in
+ l_shift_index l' r
| _ -> raise Not_found
end
@@ -471,8 +471,8 @@ let pp_value = Value.pretty pp_region
let pp_args fmt = function
| [] -> ()
| k::ks ->
- F.pp_term fmt k ;
- List.iter (fun k -> Format.fprintf fmt "@,,%a" F.pp_term k) ks
+ F.pp_term fmt k ;
+ List.iter (fun k -> Format.fprintf fmt "@,,%a" F.pp_term k) ks
let pp_field fmt k =
if F.is_atomic k then
@@ -506,40 +506,40 @@ let vars = function
| GarbledMix -> F.Vars.empty
| Index l | Lref(_,l,_) | Lmem(_,l,_,_) | Lraw(_,l,_,_) -> F.vars l
| Lfld(_,l,k,_) ->
- F.Vars.union (F.vars l) (F.vars k)
+ F.Vars.union (F.vars l) (F.vars k)
| Larr(_,l,k,ks,_,_) ->
- Qed.Hcons.fold_list F.Vars.union F.vars F.Vars.empty (l::k::ks)
+ Qed.Hcons.fold_list F.Vars.union F.vars F.Vars.empty (l::k::ks)
let occurs x = function
| GarbledMix -> false
| Index l | Lref(_,l,_) | Lmem(_,l,_,_) | Lraw(_,l,_,_) -> F.occurs x l
| Lfld(_,l,k,_) ->
- F.occurs x l || F.occurs x k
+ F.occurs x l || F.occurs x k
| Larr(_,l,k,ks,_,_) ->
- List.exists (F.occurs x) (l::k::ks)
+ List.exists (F.occurs x) (l::k::ks)
let pretty fmt = function
| GarbledMix -> Format.pp_print_string fmt "garbled-mix"
| Index l ->
- Format.fprintf fmt "@[<hov 2>Index(%a)@]" pp_index l
+ Format.fprintf fmt "@[<hov 2>Index(%a)@]" pp_index l
| Lref(r,l,r') ->
- Format.fprintf fmt "@[<hov 2>Ref@,{%a->%a}@,(%a)@]"
- pp_region r pp_region r' pp_index l
+ Format.fprintf fmt "@[<hov 2>Ref@,{%a->%a}@,(%a)@]"
+ pp_region r pp_region r' pp_index l
| Lmem(r,l,_,v) ->
- Format.fprintf fmt "@[<hov 2>Mem@,{%a:@,%a}@,(%a)@]"
- pp_region r pp_value v pp_index l
+ Format.fprintf fmt "@[<hov 2>Mem@,{%a:@,%a}@,(%a)@]"
+ pp_region r pp_value v pp_index l
| Lraw(r,l,_,None) ->
- Format.fprintf fmt "@[<hov 2>Raw@,{%a}@,(%a)"
- pp_region r pp_index l
+ Format.fprintf fmt "@[<hov 2>Raw@,{%a}@,(%a)"
+ pp_region r pp_index l
| Lraw(r,l,_,Some r') ->
- Format.fprintf fmt "@[<hov 2>Raw@,{%a->%a}@,(%a)"
- pp_region r pp_region r' pp_index l
+ Format.fprintf fmt "@[<hov 2>Raw@,{%a->%a}@,(%a)"
+ pp_region r pp_region r' pp_index l
| Lfld(r,l,k,_) ->
- Format.fprintf fmt "@[<hov 2>Field@,{%a}@,(%a%a)@]"
- pp_region r pp_index l pp_field k
+ Format.fprintf fmt "@[<hov 2>Field@,{%a}@,(%a%a)@]"
+ pp_region r pp_index l pp_field k
| Larr(r,l,k,ks,_,_) ->
- Format.fprintf fmt "@[<hov 2>Index@,{%a}@,@[<hov 2>(%a[%a]%a)@]@]"
- pp_region r pp_index l pp_args ks pp_delta k
+ Format.fprintf fmt "@[<hov 2>Index@,{%a}@,@[<hov 2>(%a[%a]%a)@]@]"
+ pp_region r pp_index l pp_args ks pp_delta k
(* -------------------------------------------------------------------------- *)
(* --- Loc Constructors --- *)
@@ -567,9 +567,9 @@ and index_field map r l ofs len overlay =
and index_dim map r l ofs len = function
| Raw s | Dim(s,[]) ->
- index map r (l_index_mem l F.e_zero (F.e_int s)) ofs len
+ index map r (l_index_mem l F.e_zero (F.e_int s)) ofs len
| Dim(s,ds) ->
- index_array map r l (ARRAY.zeroes ds) ofs len s ds
+ index_array map r l (ARRAY.zeroes ds) ofs len s ds
and index_array map r l ks ofs len s ds =
let cs = ARRAY.coefs s ds in
@@ -649,8 +649,8 @@ struct
| Mu_alloc -> MemMemory.t_malloc
| Mu_raw _ -> t_bits
| Mu_mem(_,root,v) ->
- let value = tau_of_value v in
- if Root.indexed root then L.Array(t_addr,value) else value
+ let value = tau_of_value v in
+ if Root.indexed root then L.Array(t_addr,value) else value
let basename_of_chunk = function
| Mu_raw _ -> "B"
@@ -747,9 +747,9 @@ struct
let load_pointer sigma ty = function
| Lmem(r,l,rt,(Pointer r' as v)) ->
- loc_of_index r' ty (load_mem sigma r rt v l)
+ loc_of_index r' ty (load_mem sigma r rt v l)
| Lref(_,l,r') ->
- loc_of_index r' ty (l_index_ref l)
+ loc_of_index r' ty (l_index_ref l)
| l -> error "Can not load pointer value from %a" pretty l
let havoc obj loc ~length (chunk:chunk) ~fresh ~current =
@@ -757,38 +757,38 @@ struct
| Mu_alloc -> fresh
| Mu_raw _ -> error "Can not havoc raw memories"
| Mu_mem(_,root,_) ->
- if Layout.Root.indexed root then
- let addr = to_addr loc in
- let offset = F.e_fact (Ctypes.bits_sizeof_object obj) length in
- F.e_fun MemMemory.f_havoc [fresh;current;addr;offset]
- else
- fresh
+ if Layout.Root.indexed root then
+ let addr = to_addr loc in
+ let offset = F.e_fact (Ctypes.bits_sizeof_object obj) length in
+ F.e_fun MemMemory.f_havoc [fresh;current;addr;offset]
+ else
+ fresh
let eqmem obj loc chunk m1 m2 =
match chunk with
| Mu_alloc -> error "Can not compare allocation tables"
| Mu_raw _ -> error "Can not compare raw memories"
| Mu_mem(_,root,_) ->
- if Layout.Root.indexed root then
- let addr = to_addr loc in
- let offset = F.e_int (Ctypes.bits_sizeof_object obj) in
- F.p_call MemMemory.p_eqmem [m1;m2;addr;offset]
- else F.p_equal m1 m2
+ if Layout.Root.indexed root then
+ let addr = to_addr loc in
+ let offset = F.e_int (Ctypes.bits_sizeof_object obj) in
+ F.p_call MemMemory.p_eqmem [m1;m2;addr;offset]
+ else F.p_equal m1 m2
let eqmem_forall obj loc chunk m1 m2 =
match chunk with
| Mu_alloc -> error "Can not compare allocation tables"
| Mu_raw _ -> error "Can not compare raw memories"
| Mu_mem(_,root,_) ->
- if Layout.Root.indexed root then
- let xp = Lang.freshvar ~basename:"p" t_addr in
- let p = F.e_var xp in
- let a = to_addr loc in
- let n = F.e_int (Ctypes.bits_sizeof_object obj) in
- let separated = p_separated p F.e_one a n in
- let equal = F.p_equal (F.e_get m1 p) (F.e_get m2 p) in
- [xp],separated,equal
- else [],F.p_true,F.p_equal m1 m2
+ if Layout.Root.indexed root then
+ let xp = Lang.freshvar ~basename:"p" t_addr in
+ let p = F.e_var xp in
+ let a = to_addr loc in
+ let n = F.e_int (Ctypes.bits_sizeof_object obj) in
+ let separated = p_separated p F.e_one a n in
+ let equal = F.p_equal (F.e_get m1 p) (F.e_get m2 p) in
+ [xp],separated,equal
+ else [],F.p_true,F.p_equal m1 m2
let last _ = error "Can not compute last valid index"
diff --git a/src/plugins/wp/MemTyped.ml b/src/plugins/wp/MemTyped.ml
index f79ee802cf54e287c0282b3048637d50ca121947..d66b0885ded60cc22f74ef9bb096bc2d68147866 100644
--- a/src/plugins/wp/MemTyped.ml
+++ b/src/plugins/wp/MemTyped.ml
@@ -201,10 +201,10 @@ and footprint_comp { cfields } =
match cfields with
| None -> all_value_chunks ()
| Some fields ->
- List.fold_left
- (fun ft f ->
- Heap.Set.union ft (footprint (object_of f.ftype))
- ) Heap.Set.empty fields
+ List.fold_left
+ (fun ft f ->
+ Heap.Set.union ft (footprint (object_of f.ftype))
+ ) Heap.Set.empty fields
and all_value_chunks () =
let ints =
@@ -251,32 +251,32 @@ let rec length_of_object = function
| C_int _ | C_float _ | C_pointer _ -> e_one
| C_comp c -> length_of_comp c
| C_array { arr_flat = Some { arr_size = n } ; arr_element = elt } ->
- e_mul (e_int n) (length_of_typ elt)
+ e_mul (e_int n) (length_of_typ elt)
| C_array _ as a ->
- if Wp_parameters.ExternArrays.get () then
- e_int max_int
- else
- Warning.error ~source:"Typed Model"
- "Undefined array-size (%a)" Ctypes.pretty a
+ if Wp_parameters.ExternArrays.get () then
+ e_int max_int
+ else
+ Warning.error ~source:"Typed Model"
+ "Undefined array-size (%a)" Ctypes.pretty a
and length_of_typ t = length_of_object (object_of t)
and length_of_field f = length_of_typ f.ftype
and length_of_comp c =
match c.cfields with
| None ->
- Lang.F.e_fun (OPAQUE_COMP_LENGTH.get c) []
+ Lang.F.e_fun (OPAQUE_COMP_LENGTH.get c) []
| Some fields ->
- (* union field are considered as struct field *)
- e_sum (List.map length_of_field fields)
+ (* union field are considered as struct field *)
+ e_sum (List.map length_of_field fields)
let position_of_field f =
let rec fnext k f = function
| [] -> assert false
| g::gs ->
- if Fieldinfo.equal f g then k
- else fnext (e_add k (length_of_field g)) f gs
- (* Just as we fail if the field does not exists, we fail
- if we try to get a field position in an opaque struct. *)
+ if Fieldinfo.equal f g then k
+ else fnext (e_add k (length_of_field g)) f gs
+ (* Just as we fail if the field does not exists, we fail
+ if we try to get a field position in an opaque struct. *)
in fnext e_zero f (Option.get f.fcomp.cfields)
(* -------------------------------------------------------------------------- *)
@@ -382,10 +382,10 @@ module ShiftGen = WpContext.StaticGenerator(Cobj)
| C_pointer _ -> Format.fprintf fmt "PTR"
| C_comp c -> Format.pp_print_string fmt (Lang.comp_id c)
| C_array a ->
- let te = object_of a.arr_element in
- match a.arr_flat with
- | None -> Format.fprintf fmt "A_%a" c_object_id te
- | Some f -> Format.fprintf fmt "A%d_%a" f.arr_size c_object_id te
+ let te = object_of a.arr_element in
+ match a.arr_flat with
+ | None -> Format.fprintf fmt "A_%a" c_object_id te
+ | Some f -> Format.fprintf fmt "A%d_%a" f.arr_size c_object_id te
let c_object_id c = Format.asprintf "%a@?" c_object_id c
@@ -564,38 +564,38 @@ module BASE = WpContext.Generator(Varinfo)
match size with
| None -> ()
| Some size ->
- let a = Lang.freshvar ~basename:"alloc" t_malloc in
- let m = e_var a in
- let m_linked = p_call p_linked [m] in
- let base_size = p_equal (F.e_get m base) size in
- Definitions.define_lemma {
- l_kind = Admit ;
- l_name = name ; l_types = 0 ;
- l_triggers = [] ; l_forall = [] ;
- l_lemma = p_forall [a] (p_imply m_linked base_size) ;
- l_cluster = cluster_globals () ;
- }
+ let a = Lang.freshvar ~basename:"alloc" t_malloc in
+ let m = e_var a in
+ let m_linked = p_call p_linked [m] in
+ let base_size = p_equal (F.e_get m base) size in
+ Definitions.define_lemma {
+ l_kind = Admit ;
+ l_name = name ; l_types = 0 ;
+ l_triggers = [] ; l_forall = [] ;
+ l_lemma = p_forall [a] (p_imply m_linked base_size) ;
+ l_cluster = cluster_globals () ;
+ }
let initialization prefix x base =
match sizeof x with
| Some size when Cvalues.always_initialized x ->
- let a = Lang.freshvar ~basename:"init" t_init in
- let m = e_var a in
- let init_access =
- if size = e_one then
- p_bool (F.e_get m (a_addr base e_zero))
- else
- F.p_call p_is_init_r [ m ; a_addr base e_zero ; size ]
- in
- let m_init = p_call p_cinits [m] in
- let init_prop = p_forall [a] (p_imply m_init init_access) in
- Definitions.define_lemma {
- l_kind = Admit ;
- l_name = prefix ^ "_init" ; l_types = 0 ;
- l_triggers = [] ; l_forall = [] ;
- l_lemma = init_prop ;
- l_cluster = cluster_globals () ;
- }
+ let a = Lang.freshvar ~basename:"init" t_init in
+ let m = e_var a in
+ let init_access =
+ if size = e_one then
+ p_bool (F.e_get m (a_addr base e_zero))
+ else
+ F.p_call p_is_init_r [ m ; a_addr base e_zero ; size ]
+ in
+ let m_init = p_call p_cinits [m] in
+ let init_prop = p_forall [a] (p_imply m_init init_access) in
+ Definitions.define_lemma {
+ l_kind = Admit ;
+ l_name = prefix ^ "_init" ; l_types = 0 ;
+ l_triggers = [] ; l_forall = [] ;
+ l_lemma = init_prop ;
+ l_cluster = cluster_globals () ;
+ }
| _ -> ()
let generate x =
@@ -647,9 +647,9 @@ let block_length sigma obj l =
let n_cells = e_div (allocated sigma l) (length_of_object obj) in
match obj with
| C_comp ({ cfields = None } as c) ->
- e_mul (Cvalues.bytes_length_of_opaque_comp c) n_cells
+ e_mul (Cvalues.bytes_length_of_opaque_comp c) n_cells
| _ ->
- e_fact (Ctypes.sizeof_object obj) n_cells
+ e_fact (Ctypes.sizeof_object obj) n_cells
(* -------------------------------------------------------------------------- *)
(* --- Cast --- *)
@@ -699,11 +699,11 @@ struct
| C_float f -> A (F f)
| C_pointer t -> A (P t)
| C_comp ( { cfields = Some [f] } as c ) ->
- begin (* union having only one field is equivalent to a struct *)
- match Ctypes.object_of f.ftype with
- | C_array _ -> (if c.cstruct then S c else U c)
- | cobj -> get_slot cobj
- end
+ begin (* union having only one field is equivalent to a struct *)
+ match Ctypes.object_of f.ftype with
+ | C_array _ -> (if c.cstruct then S c else U c)
+ | cobj -> get_slot cobj
+ end
| C_comp c -> if c.cstruct then S c else U c
| C_array _ -> assert false
@@ -735,34 +735,34 @@ struct
let pp_layout fmt = function
| [b] -> pp_block fmt b
| bs ->
- begin
- Format.fprintf fmt "@[<hov 2>{" ;
- List.iter (fun b -> Format.fprintf fmt "@ %a" pp_block b) bs ;
- Format.fprintf fmt " }@]" ;
- end
+ begin
+ Format.fprintf fmt "@[<hov 2>{" ;
+ List.iter (fun b -> Format.fprintf fmt "@ %a" pp_block b) bs ;
+ Format.fprintf fmt " }@]" ;
+ end
(* requires n > 1 *)
let rec add_many cobj n w = (* returns [layout obj]*n @ [w] *)
assert (n > 1L) ;
match cobj, w with
| C_array { arr_flat = Some a }, _ when a.arr_cell_nbr = 1L ->
- add_many (Ctypes.object_of a.arr_cell) n w
+ add_many (Ctypes.object_of a.arr_cell) n w
| C_array _, Arr(o, m)::w when 0 = compare_ptr_conflated o cobj ->
- Arr(o, Int64.add m n)::w
+ Arr(o, Int64.add m n)::w
| C_array _, _ -> Arr(cobj, n)::w
| _ -> add_slot (get_slot cobj) n w
let rec rlayout w = function (* returns [layout obj] @ [w] *)
| C_array { arr_flat = Some a } ->
- let cobj = Ctypes.object_of a.arr_cell in
- if a.arr_cell_nbr = 1L
- then rlayout w cobj
- else add_many cobj a.arr_cell_nbr w
+ let cobj = Ctypes.object_of a.arr_cell in
+ if a.arr_cell_nbr = 1L
+ then rlayout w cobj
+ else add_many cobj a.arr_cell_nbr w
| C_array { arr_element = e } ->
- if Wp_parameters.ExternArrays.get () then
- add_many (Ctypes.object_of e) Int64.max_int w
- else
- add_block Garbled w
+ if Wp_parameters.ExternArrays.get () then
+ add_many (Ctypes.object_of e) Int64.max_int w
+ else
+ add_block Garbled w
| cobj -> add_slot (get_slot cobj) 1L w
let layout (obj : c_object) : layout = rlayout [] obj
@@ -770,10 +770,10 @@ struct
let clayout (c: Cil_types.compinfo) : layout =
match c.cfields with
| None ->
- [Garbled]
+ [Garbled]
| Some fields ->
- let flayout w f = rlayout w (Ctypes.object_of f.ftype) in
- List.fold_left flayout [] (List.rev fields)
+ let flayout w f = rlayout w (Ctypes.object_of f.ftype) in
+ List.fold_left flayout [] (List.rev fields)
type comparison = Srem of layout | Drem of layout | Equal | Mismatch
@@ -796,7 +796,7 @@ struct
| S c1, _ -> compare ~dst:(clayout c1) ~src:[Str(src,1L)]
| _, S c2 -> compare ~dst:[Str(dst,1L)] ~src:(clayout c2)
| U c1, U c2 -> (* for union, the layouts must be equal *)
- if equal (clayout c1) (clayout c2) then Equal else Mismatch
+ if equal (clayout c1) (clayout c2) then Equal else Mismatch
| U _, A _ -> Mismatch
| A _, U _ -> Mismatch
and compare ~dst ~src =
@@ -805,58 +805,58 @@ struct
| [] , obj -> Srem obj (* src = dst @ obj *)
| obj , [] -> Drem obj (* dst = src @ obj *)
| p::w1 , q::w2 ->
- match p , q with
- | Garbled , _ | _ , Garbled -> Mismatch
- | Str(a,n) , Str(b,m) ->
- begin
- match compare_slot a b with
- | Mismatch -> Mismatch
- | Drem a'->
- let w1 = a' @ decr_slot a n w1 in
- let w2 = decr_slot b m w2 in
- compare w1 w2
- | Srem b' ->
- let w1 = decr_slot a n w1 in
- let w2 = b' @ decr_slot b m w2 in
- compare w1 w2
- | Equal ->
- if n < m then
- let w2 = Str(a,Int64.sub m n)::w2 in
- compare w1 w2
- else if n > m then
- let w1 = Str(a,Int64.sub n m)::w1 in
- compare w1 w2
- else
- (* n = m *)
- compare w1 w2
- end
- | Arr(u,n) , Arr(v,m) ->
- begin
- match compare ~dst:(layout u) ~src:(layout v) with
- | Mismatch -> Mismatch
- | Drem u' ->
- let w1 = u' @ add_array u (Int64.pred n) w1 in
- let w2 = add_array v (Int64.pred m) w2 in
- compare w1 w2
- | Srem v' ->
- let w1 = add_array u (Int64.pred n) w1 in
- let w2 = v' @ add_array v (Int64.pred m) w2 in
- compare w1 w2
- | Equal ->
- if n < m then
- let w2 = add_array v (Int64.sub m n) w2 in
- compare w1 w2
- else if n > m then
- let w1 = add_array u (Int64.sub n m) w1 in
- compare w1 w2
- else
- (* n = m *)
- compare w1 w2
- end
- | Arr(u,n) , Str _ ->
- compare ~dst:((layout u) @ add_array u (Int64.pred n) w1) ~src
- | Str _ , Arr(v,n) ->
- compare ~dst ~src:((layout v) @ add_array v (Int64.pred n) w2)
+ match p , q with
+ | Garbled , _ | _ , Garbled -> Mismatch
+ | Str(a,n) , Str(b,m) ->
+ begin
+ match compare_slot a b with
+ | Mismatch -> Mismatch
+ | Drem a'->
+ let w1 = a' @ decr_slot a n w1 in
+ let w2 = decr_slot b m w2 in
+ compare w1 w2
+ | Srem b' ->
+ let w1 = decr_slot a n w1 in
+ let w2 = b' @ decr_slot b m w2 in
+ compare w1 w2
+ | Equal ->
+ if n < m then
+ let w2 = Str(a,Int64.sub m n)::w2 in
+ compare w1 w2
+ else if n > m then
+ let w1 = Str(a,Int64.sub n m)::w1 in
+ compare w1 w2
+ else
+ (* n = m *)
+ compare w1 w2
+ end
+ | Arr(u,n) , Arr(v,m) ->
+ begin
+ match compare ~dst:(layout u) ~src:(layout v) with
+ | Mismatch -> Mismatch
+ | Drem u' ->
+ let w1 = u' @ add_array u (Int64.pred n) w1 in
+ let w2 = add_array v (Int64.pred m) w2 in
+ compare w1 w2
+ | Srem v' ->
+ let w1 = add_array u (Int64.pred n) w1 in
+ let w2 = v' @ add_array v (Int64.pred m) w2 in
+ compare w1 w2
+ | Equal ->
+ if n < m then
+ let w2 = add_array v (Int64.sub m n) w2 in
+ compare w1 w2
+ else if n > m then
+ let w1 = add_array u (Int64.sub n m) w1 in
+ compare w1 w2
+ else
+ (* n = m *)
+ compare w1 w2
+ end
+ | Arr(u,n) , Str _ ->
+ compare ~dst:((layout u) @ add_array u (Int64.pred n) w1) ~src
+ | Str _ , Arr(v,n) ->
+ compare ~dst ~src:((layout v) @ add_array v (Int64.pred n) w2)
let rec repeated ~dst ~src =
match dst , src with
@@ -867,33 +867,33 @@ struct
match p , q with
| Garbled , _ | _ , Garbled -> false
| Str(a,n) , Str(b,m) -> (* dst =?= repeated(src,n/m) *)
- begin
- match compare_slot ~dst:a ~src:b with
- | Mismatch -> false
- | Drem a' ->
- let w1 = a' @ decr_slot a n [] in
- let w2 = decr_slot b m [] in
- let cmp = compare ~dst:w1 ~src:w2 in
- repeated_result ~src cmp
- | Srem _ ->
- false
- | Equal -> (* dst =?= repeated(src,n/m) *)
- n >= m && (Int64.rem n m = 0L)
- end
+ begin
+ match compare_slot ~dst:a ~src:b with
+ | Mismatch -> false
+ | Drem a' ->
+ let w1 = a' @ decr_slot a n [] in
+ let w2 = decr_slot b m [] in
+ let cmp = compare ~dst:w1 ~src:w2 in
+ repeated_result ~src cmp
+ | Srem _ ->
+ false
+ | Equal -> (* dst =?= repeated(src,n/m) *)
+ n >= m && (Int64.rem n m = 0L)
+ end
| Arr(u,n) , Arr(v,m) ->
- begin
- match compare ~dst:(layout u) ~src:(layout v) with
- | Mismatch -> false
- | Drem u' ->
- let w1 = u' @ add_array u (Int64.pred n) [] in
- let w2 = add_array v (Int64.pred m) [] in
- let cmp = compare ~dst:w1 ~src:w2 in
- repeated_result ~src cmp
- | Srem _ ->
- false
- | Equal -> (* dst =?= repeated(src,n/m) *)
- n >= m && (Int64.rem n m = 0L)
- end
+ begin
+ match compare ~dst:(layout u) ~src:(layout v) with
+ | Mismatch -> false
+ | Drem u' ->
+ let w1 = u' @ add_array u (Int64.pred n) [] in
+ let w2 = add_array v (Int64.pred m) [] in
+ let cmp = compare ~dst:w1 ~src:w2 in
+ repeated_result ~src cmp
+ | Srem _ ->
+ false
+ | Equal -> (* dst =?= repeated(src,n/m) *)
+ n >= m && (Int64.rem n m = 0L)
+ end
| _ , _ -> repeated_compare ~dst ~src
end
| _ , _ -> repeated_compare ~dst ~src
@@ -910,11 +910,11 @@ struct
| C_comp c , C_comp d when Compinfo.equal c d -> true
| C_pointer _ , C_pointer _ -> true
| _ ->
- let src = layout src in
- match compare ~dst:(layout dst) ~src with
- | Equal | Srem _ -> true
- | Mismatch -> false
- | Drem dst -> repeated dst src
+ let src = layout src in
+ match compare ~dst:(layout dst) ~src with
+ | Equal | Srem _ -> true
+ | Mismatch -> false
+ | Drem dst -> repeated dst src
let rec pretty fmt = function
| C_pointer ty -> Format.fprintf fmt "%a*" pretty (Ctypes.object_of ty)
@@ -943,13 +943,13 @@ let cast s l =
match Context.get pointer with
| NoCast -> Warning.error ~source:"Typed Model" "%a" pp_mismatch s
| Fits ->
- if Layout.fits ~dst:s.post ~src:s.pre then l else
- Warning.error ~source:"Typed Model" "%a" pp_mismatch s
+ if Layout.fits ~dst:s.post ~src:s.pre then l else
+ Warning.error ~source:"Typed Model" "%a" pp_mismatch s
| Unsafe ->
- if not (Layout.fits ~dst:s.post ~src:s.pre) then
- Warning.emit ~severe:false ~source:"Typed Model"
- ~effect:"Keep pointer value"
- "%a" pp_mismatch s ; l
+ if not (Layout.fits ~dst:s.post ~src:s.pre) then
+ Warning.emit ~severe:false ~source:"Typed Model"
+ ~effect:"Keep pointer value"
+ "%a" pp_mismatch s ; l
end
let loc_of_int _ v = F.e_fun f_addr_of_int [v]
@@ -962,11 +962,11 @@ let int_of_loc _ l = F.e_fun f_int_of_addr [l]
let frames obj addr = function
| T_alloc -> []
| m ->
- let offset = length_of_object obj in
- let sizeof = F.e_one in
- let tau = Chunk.val_of_chunk m in
- let basename = Chunk.basename_of_chunk m in
- MemMemory.frames ~addr ~offset ~sizeof ~basename tau
+ let offset = length_of_object obj in
+ let sizeof = F.e_one in
+ let tau = Chunk.val_of_chunk m in
+ let basename = Chunk.basename_of_chunk m in
+ MemMemory.frames ~addr ~offset ~sizeof ~basename tau
(* -------------------------------------------------------------------------- *)
(* --- Chunk element type --- *)
@@ -1004,9 +1004,9 @@ module ChunkContent = WpContext.Generator(Chunk)
let is_chunk sigma = function
| M_int _ as m ->
- F.p_call (ChunkContent.get m) [ Sigma.value sigma m ]
+ F.p_call (ChunkContent.get m) [ Sigma.value sigma m ]
| _ ->
- p_true
+ p_true
let is_well_formed sigma =
let open Sigma in
@@ -1133,15 +1133,15 @@ let s_invalid sigma p n =
let segment phi = function
| Rloc(obj,l) ->
- phi l (length_of_object obj)
+ phi l (length_of_object obj)
| Rrange(l,obj,Some a,Some b) ->
- let l = shift l obj a in
- let n = e_mul (length_of_object obj) (e_range a b) in
- phi l n
+ let l = shift l obj a in
+ let n = e_mul (length_of_object obj) (e_range a b) in
+ phi l n
| Rrange(l,_,a,b) ->
- Wp_parameters.abort ~current:true
- "Invalid infinite range @[<hov 2>%a+@,(%a@,..%a)@]"
- F.pp_term l Vset.pp_bound a Vset.pp_bound b
+ Wp_parameters.abort ~current:true
+ "Invalid infinite range @[<hov 2>%a+@,(%a@,..%a)@]"
+ F.pp_term l Vset.pp_bound a Vset.pp_bound b
let valid sigma acs = segment (s_valid sigma acs)
let invalid sigma = segment (s_invalid sigma)
@@ -1221,9 +1221,9 @@ let lookup s e =
try match F.repr e with
| L.Fun( f , es ) -> Sigs.Maddr (lookup_f f es)
| L.Aget( m , k ) when Tmap.find m s = T_init ->
- Sigs.Mlval (lookup_lv k, KInit)
+ Sigs.Mlval (lookup_lv k, KInit)
| L.Aget( m , k ) when Tmap.find m s <> T_alloc ->
- Sigs.Mlval (lookup_lv k, KValue)
+ Sigs.Mlval (lookup_lv k, KValue)
| _ -> Sigs.Mterm
with Not_found -> Sigs.Mterm
@@ -1246,11 +1246,11 @@ let rec diff v1 v2 =
if v1 == v2 then Bag.empty else
match F.repr v2 with
| L.Aset( m , k , v ) ->
- let lv = lookup_lv k in
- let upd = Mstore( lv , v ) in
- Bag.append (diff v1 m) upd
+ let lv = lookup_lv k in
+ let upd = Mstore( lv , v ) in
+ Bag.append (diff v1 m) upd
| _ ->
- Bag.empty
+ Bag.empty
let updates seq domain =
let pool = ref Bag.empty in
diff --git a/src/plugins/wp/MemVal.ml b/src/plugins/wp/MemVal.ml
index f9ce1bc2aee6234cf669662def2482faee5ce75a..ebb5a682516e2c0d568b6a1b0f278685092ea1c3 100644
--- a/src/plugins/wp/MemVal.ml
+++ b/src/plugins/wp/MemVal.ml
@@ -142,10 +142,10 @@ let _phi_read ~obj ~read ~write mem off = match F.repr mem with
| Logic.Fun (f, [_; o; v]) when f == write && off == o -> v
(*read_tau (write_tau m o v) o == v*)
| Logic.Fun (f, [m; o; _]) when f == write ->
- let offset = a_iabs (F.e_sub off o) in
- if F.eval_leq (F.e_int (Ctypes.sizeof_object obj)) offset then
- F.e_fun read [m; off]
- else raise Not_found
+ let offset = a_iabs (F.e_sub off o) in
+ if F.eval_leq (F.e_int (Ctypes.sizeof_object obj)) offset then
+ F.e_fun read [m; off]
+ else raise Not_found
(*read_tau (write_tau m o v) o' == read m o' when |o - o'| <= sizeof(tau)*)
| _ -> raise Not_found
@@ -248,17 +248,17 @@ struct
| Base.Null -> "MNull"
| Base.String (eid, _) -> Format.sprintf "MStr_%d" eid
| Base.Allocated (vi, _dealloc, _) ->
- Format.sprintf "MAlloc_%s" (LogicUsage.basename vi)
+ Format.sprintf "MAlloc_%s" (LogicUsage.basename vi)
let basename_of_chunk = function
| M_base b -> basename_of_base b
let is_framed = function
| M_base b ->
- try
- (match WpContext.get_scope () with
- | WpContext.Global -> assert false
- | WpContext.Kf kf -> Base.is_formal_or_local b (Kernel_function.get_definition kf))
- with Invalid_argument _ | Kernel_function.No_Definition ->
- assert false (* by context. *)
+ try
+ (match WpContext.get_scope () with
+ | WpContext.Global -> assert false
+ | WpContext.Kf kf -> Base.is_formal_or_local b (Kernel_function.get_definition kf))
+ with Invalid_argument _ | Kernel_function.No_Definition ->
+ assert false (* by context. *)
end
let cluster () = Definitions.cluster ~id:"MemVal" ()
@@ -438,10 +438,10 @@ struct
| [] -> assert false
| [x] -> f x
| x :: xs ->
- F.e_if
- (F.e_eq (a_base l.loc_t) (F.e_int (Base.id x)))
- (f x)
- (aux xs)
+ F.e_if
+ (F.e_eq (a_base l.loc_t) (F.e_int (Base.id x)))
+ (f x)
+ (aux xs)
in
aux (V.domain l.loc_v)
@@ -450,10 +450,10 @@ struct
| [] -> assert false
| [x] -> f x
| x :: xs ->
- F.p_if
- (F.p_equal (a_base l.loc_t) (F.e_int (Base.id x)))
- (f x)
- (aux xs)
+ F.p_if
+ (F.p_equal (a_base l.loc_t) (F.e_int (Base.id x)))
+ (f x)
+ (aux xs)
in
aux (V.domain l.loc_v)
@@ -574,13 +574,13 @@ struct
let rec store acc = function
| [] -> assert false
| [c] ->
- let cond = F.e_and ((List.map (F.e_neq (a_base l.loc_t))) acc) in
- [ Assert (mk_write cond c) ]
+ let cond = F.e_and ((List.map (F.e_neq (a_base l.loc_t))) acc) in
+ [ Assert (mk_write cond c) ]
| c :: cs ->
- let bid = (F.e_int (Base.id c)) in
- let cond = F.e_eq (a_base l.loc_t) bid in
- [ Assert (mk_write cond c) ]
- @ store (bid :: acc) cs
+ let bid = (F.e_int (Base.id c)) in
+ let cond = F.e_eq (a_base l.loc_t) bid in
+ [ Assert (mk_write cond c) ]
+ @ store (bid :: acc) cs
in
store [ ] (V.domain l.loc_v)
@@ -607,7 +607,7 @@ struct
match F.is_equal (a_base l1.loc_t) (a_base l2.loc_t) with
| Logic.Yes -> F.e_sub (a_offset l1.loc_t) (a_offset l2.loc_t)
| Logic.Maybe | Logic.No ->
- Warning.error "Can only compare pointers with same base."
+ Warning.error "Can only compare pointers with same base."
let base_eq l1 l2 = F.p_equal (a_base l1.loc_t) (a_base l2.loc_t)
let offset_cmp cmpop l1 l2 = cmpop (a_offset l1.loc_t) (a_offset l2.loc_t)
@@ -628,14 +628,14 @@ struct
let range_of_rloc = function
| Rloc (obj, l) ->
- LOC (l, F.e_int (Ctypes.sizeof_object obj))
+ LOC (l, F.e_int (Ctypes.sizeof_object obj))
| Rrange (l, obj, Some a, Some b) ->
- let la = shift l obj a in
- let n = e_fact (Ctypes.sizeof_object obj) (F.e_range a b) in
- LOC (la, n)
+ let la = shift l obj a in
+ let n = e_fact (Ctypes.sizeof_object obj) (F.e_range a b) in
+ LOC (la, n)
| Rrange (l, obj, a_opt, b_opt) ->
- let f = F.e_fact (Ctypes.sizeof_object obj) in
- RANGE (l, Vset.range (Option.map f a_opt) (Option.map f b_opt))
+ let f = F.e_fact (Ctypes.sizeof_object obj) in
+ RANGE (l, Vset.range (Option.map f a_opt) (Option.map f b_opt))
(* -------------------------------------------------------------------------- *)
(* --- Validity --- *)
@@ -647,14 +647,14 @@ struct
| Base.Invalid -> Vset.singleton F.e_zero
| Base.Known (min_valid, max_valid)
| Base.Unknown (min_valid, Some max_valid, _) ->
- (* valid between min_valid .. max_valid inclusive *)
- let mn = F.e_bigint Integer.(e_div min_valid eight) in
- let mx = F.e_bigint Integer.(e_div max_valid eight) in
- Vset.range (Some mn) (Some mx)
+ (* valid between min_valid .. max_valid inclusive *)
+ let mn = F.e_bigint Integer.(e_div min_valid eight) in
+ let mx = F.e_bigint Integer.(e_div max_valid eight) in
+ Vset.range (Some mn) (Some mx)
| Base.Variable { Base.min_alloc = min_valid } ->
- (* valid between 0 .. min_valid inclusive *)
- let mn_valid = F.e_bigint Integer.(e_div min_valid eight) in
- Vset.range (Some F.e_zero) (Some mn_valid)
+ (* valid between 0 .. min_valid inclusive *)
+ let mn_valid = F.e_bigint Integer.(e_div min_valid eight) in
+ Vset.range (Some F.e_zero) (Some mn_valid)
| Base.Unknown (_, None, _) -> Vset.empty
let valid_range : sigma -> acs -> range -> pred = fun _ acs r ->
@@ -662,9 +662,9 @@ struct
| OBJ -> true (* TODO: *) in
let l, base_offset = match r with
| LOC (l, n) ->
- let a = a_offset l.loc_t in
- let b = F.e_add a (F.e_sub n F.e_one) in
- l, Vset.range (Some a) (Some b)
+ let a = a_offset l.loc_t in
+ let b = F.e_add a (F.e_sub n F.e_one) in
+ l, Vset.range (Some a) (Some b)
| RANGE (l, r) -> l, Vset.lift_add (Vset.singleton l.loc_t) r
in
let valid_base set base =
@@ -704,7 +704,7 @@ struct
match scope with
| Enter -> []
| Leave ->
- alloc_pred seq xs ()
+ alloc_pred seq xs ()
let scope seq sc xs =
let preds = scope seq sc xs in
@@ -724,9 +724,9 @@ struct
(* -------------------------------------------------------------------------- *)
let range_to_base_offset = function
| LOC (l, n) ->
- let a = a_offset l.loc_t in
- let b = F.e_add a n in
- l, Vset.range (Some a) (Some b)
+ let a = a_offset l.loc_t in
+ let b = F.e_add a n in
+ l, Vset.range (Some a) (Some b)
| RANGE (l, r) -> l, Vset.lift_add (Vset.singleton l.loc_t) r
let included : segment -> segment -> pred = fun s1 s2 ->
@@ -836,15 +836,15 @@ struct
(* assert (not (Ival.is_float ival)); (* by integer offsets *) *)
match Ival.project_small_set ival with
| Some is ->
- F.p_any
- (fun i -> F.p_equal x (F.e_bigint i))
- is
+ F.p_any
+ (fun i -> F.p_equal x (F.e_bigint i))
+ is
| None -> begin
match Ival.min_and_max ival with
| Some mn, Some mx ->
- F.p_and
- (F.p_leq (F.e_bigint mn) x)
- (F.p_leq x (F.e_bigint mx))
+ F.p_and
+ (F.p_leq (F.e_bigint mn) x)
+ (F.p_leq x (F.e_bigint mx))
| Some mn, None -> F.p_leq (F.e_bigint mn) x
| None, Some mx -> F.p_leq x (F.e_bigint mx)
| None, None -> F.p_true
diff --git a/src/plugins/wp/MemVar.ml b/src/plugins/wp/MemVar.ml
index 8bf846d8d084393897f903a8b04b0bbe2f2edf60..8f970adce2dab6cbccaa741d2b4c6f466ea1b8ff 100644
--- a/src/plugins/wp/MemVar.ml
+++ b/src/plugins/wp/MemVar.ml
@@ -56,7 +56,7 @@ struct
let kf,init = match WpContext.get_scope () with
| WpContext.Global -> None,false
| WpContext.Kf f ->
- Some f, Globals.is_entry_point ~when_lib_entry:false f in
+ Some f, Globals.is_entry_point ~when_lib_entry:false f in
let w = ref p in
V.iter ?kf ~init (fun vi -> w := MemoryContext.set vi (V.param vi) !w) ;
M.hypotheses !w
@@ -104,9 +104,9 @@ struct
let basename_of_chunk x =
match V.param x with
| ByRef ->
- "ra_" ^ LogicUsage.basename x
+ "ra_" ^ LogicUsage.basename x
| NotUsed | ByValue | ByShift | ByAddr | InContext _ | InArray _ ->
- "ta_" ^ LogicUsage.basename x
+ "ta_" ^ LogicUsage.basename x
let is_framed = is_framed_var
end
@@ -480,20 +480,20 @@ struct
if v1 == v2 then Bag.empty else
match F.repr v2 with
| Qed.Logic.Aset(m , k , vk) ->
- let upd = diff (Mstate.index lv k) (F.e_get m k) vk in
- Bag.concat (diff lv v1 m) upd
+ let upd = diff (Mstate.index lv k) (F.e_get m k) vk in
+ Bag.concat (diff lv v1 m) upd
| Qed.Logic.Rdef fvs ->
- rdiff lv v1 v2 fvs
+ rdiff lv v1 v2 fvs
| _ ->
- Bag.elt (Mstore(lv,v2))
+ Bag.elt (Mstore(lv,v2))
and rdiff lv v1 v2 = function
| (Lang.Cfield (fi, _k) as fd ,f2) :: fvs ->
- let f1 = F.e_getfield v1 fd in
- if f1 == f2 then rdiff lv v1 v2 fvs else
- let upd = diff (Mstate.field lv fi) f1 f2 in
- let m = F.e_setfield v2 fd f1 in
- Bag.concat upd (diff lv v1 m)
+ let f1 = F.e_getfield v1 fd in
+ if f1 == f2 then rdiff lv v1 v2 fvs else
+ let upd = diff (Mstate.field lv fi) f1 f2 in
+ let m = F.e_setfield v2 fd f1 in
+ Bag.concat upd (diff lv v1 m)
| (Lang.Mfield _,_)::_ -> Bag.elt (Mstore(lv,v2))
| [] -> Bag.empty
@@ -581,15 +581,15 @@ struct
let rec pp_offset ~obj fmt = function
| [] -> ()
| Field f :: ofs ->
- Format.fprintf fmt ".%s" f.fname ;
- pp_offset ~obj:(object_of f.ftype) fmt ofs
+ Format.fprintf fmt ".%s" f.fname ;
+ pp_offset ~obj:(object_of f.ftype) fmt ofs
| Shift(elt,k) :: ofs ->
- if Ctypes.is_array obj ~elt then
- ( Format.fprintf fmt ".(%a)" F.pp_term k ;
- pp_offset ~obj:elt fmt ofs )
- else
- ( Format.fprintf fmt ".(%a : %a)" F.pp_term k Ctypes.pretty elt ;
- pp_offset ~obj:elt fmt ofs )
+ if Ctypes.is_array obj ~elt then
+ ( Format.fprintf fmt ".(%a)" F.pp_term k ;
+ pp_offset ~obj:elt fmt ofs )
+ else
+ ( Format.fprintf fmt ".(%a : %a)" F.pp_term k Ctypes.pretty elt ;
+ pp_offset ~obj:elt fmt ofs )
let pp_mem fmt = function
| CVAL -> Format.pp_print_string fmt "var"
@@ -609,10 +609,10 @@ struct
| Ref x -> VAR.pretty fmt x
| Loc l -> M.pretty fmt l
| Val(m,x,ofs) ->
- let obj = vobject m x in
- Format.fprintf fmt "@[%a:%a%a@]"
- pp_mem m VAR.pretty x
- (pp_offset ~obj) ofs
+ let obj = vobject m x in
+ Format.fprintf fmt "@[%a:%a%a@]"
+ pp_mem m VAR.pretty x
+ (pp_offset ~obj) ofs
let noref ~op var =
Warning.error
@@ -718,18 +718,18 @@ struct
| Loc l -> M.block_length sigma.mem obj l
| Ref x -> noref ~op:"block-length of" x
| Val(m,x,_) ->
- begin match Ctypes.object_of (vtype m x) with
- | C_comp ({ cfields = None } as c) ->
- Cvalues.bytes_length_of_opaque_comp c
- | obj ->
- let size =
- if Ctypes.sizeof_defined obj
- then Ctypes.sizeof_object obj
- else if Wp_parameters.ExternArrays.get ()
- then max_int
- else Warning.error ~source:"MemVar" "Unknown array-size"
- in F.e_int size
- end
+ begin match Ctypes.object_of (vtype m x) with
+ | C_comp ({ cfields = None } as c) ->
+ Cvalues.bytes_length_of_opaque_comp c
+ | obj ->
+ let size =
+ if Ctypes.sizeof_defined obj
+ then Ctypes.sizeof_object obj
+ else if Wp_parameters.ExternArrays.get ()
+ then max_int
+ else Warning.error ~source:"MemVar" "Unknown array-size"
+ in F.e_int size
+ end
let cast obj l = Loc(M.cast obj (mloc_of_loc l))
let loc_of_int e a = Loc(M.loc_of_int e a)
@@ -750,48 +750,48 @@ struct
let rec update_gen kind a ofs v = match ofs with
| [] -> v
| Field f :: ofs ->
- let phi = Cfield (f, kind) in
- let a_f = F.e_getfield a phi in
- let a_f_v = update_gen kind a_f ofs v in
- F.e_setfield a phi a_f_v
+ let phi = Cfield (f, kind) in
+ let a_f = F.e_getfield a phi in
+ let a_f_v = update_gen kind a_f ofs v in
+ F.e_setfield a phi a_f_v
| Shift(_,k) :: ofs ->
- let a_k = F.e_get a k in
- let a_k_v = update_gen kind a_k ofs v in
- F.e_set a k a_k_v
+ let a_k = F.e_get a k in
+ let a_k_v = update_gen kind a_k ofs v in
+ F.e_set a k a_k_v
let update = update_gen KValue
let update_init = update_gen KInit
let load sigma obj = function
| Ref x ->
- begin match V.param x with
- | ByRef -> Sigs.Loc(Val(CREF,x,[]))
- | InContext n -> Sigs.Loc(Val(CTXT n,x,[]))
- | InArray n -> Sigs.Loc(Val(CARR n,x,[]))
- | NotUsed | ByAddr | ByValue | ByShift -> assert false
- end
+ begin match V.param x with
+ | ByRef -> Sigs.Loc(Val(CREF,x,[]))
+ | InContext n -> Sigs.Loc(Val(CTXT n,x,[]))
+ | InArray n -> Sigs.Loc(Val(CARR n,x,[]))
+ | NotUsed | ByAddr | ByValue | ByShift -> assert false
+ end
| Val((CREF|CVAL),x,ofs) ->
- Sigs.Val(access (get_term sigma x) ofs)
+ Sigs.Val(access (get_term sigma x) ofs)
| Loc l ->
- Cvalues.map_value
- (fun l -> Loc l)
- (M.load sigma.mem obj l)
+ Cvalues.map_value
+ (fun l -> Loc l)
+ (M.load sigma.mem obj l)
| Val((CTXT _|CARR _|HEAP) as m,x,ofs) ->
- Cvalues.map_value
- (fun l -> Loc l)
- (M.load sigma.mem obj (mloc_of_path m x ofs))
+ Cvalues.map_value
+ (fun l -> Loc l)
+ (M.load sigma.mem obj (mloc_of_path m x ofs))
let load_init sigma obj = function
| Ref _ ->
- e_true
+ e_true
| Val((CREF|CVAL),x,_) when Cvalues.always_initialized x ->
- Cvalues.initialized_obj obj
+ Cvalues.initialized_obj obj
| Val((CREF|CVAL),x,ofs) ->
- access_init (get_init_term sigma x) ofs
+ access_init (get_init_term sigma x) ofs
| Loc l ->
- M.load_init sigma.mem obj l
+ M.load_init sigma.mem obj l
| Val((CTXT _|CARR _|HEAP) as m,x,ofs) ->
- M.load_init sigma.mem obj (mloc_of_path m x ofs)
+ M.load_init sigma.mem obj (mloc_of_path m x ofs)
(* -------------------------------------------------------------------------- *)
(* --- Memory Store --- *)
@@ -811,11 +811,11 @@ struct
match l with
| Ref x -> noref ~op:"write to" x
| Val((CREF|CVAL),x,ofs) ->
- [memvar_stored kind seq x ofs v]
+ [memvar_stored kind seq x ofs v]
| Val((CTXT _|CARR _|HEAP) as m,x,ofs) ->
- mstored (mseq_of_seq seq) obj (mloc_of_path m x ofs) v
+ mstored (mseq_of_seq seq) obj (mloc_of_path m x ofs) v
| Loc l ->
- mstored (mseq_of_seq seq) obj l v
+ mstored (mseq_of_seq seq) obj l v
let stored = gen_stored KValue
let stored_init = gen_stored KInit
@@ -836,33 +836,33 @@ struct
let is_null = function
| Loc l -> M.is_null l
| Val ((CTXT Nullable|CARR Nullable)as m,x,ofs) ->
- M.is_null (mloc_of_path m x ofs)
+ M.is_null (mloc_of_path m x ofs)
| Ref _ | Val _ -> F.p_false
let rec offset = function
| [] -> e_zero
| Field f :: ofs ->
- e_add (e_int (Ctypes.field_offset f)) (offset ofs)
+ e_add (e_int (Ctypes.field_offset f)) (offset ofs)
| Shift(obj,k)::ofs ->
- e_add (e_fact (Ctypes.sizeof_object obj) k) (offset ofs)
+ e_add (e_fact (Ctypes.sizeof_object obj) k) (offset ofs)
let loc_diff obj a b =
match a , b with
| Loc l1 , Loc l2 -> M.loc_diff obj l1 l2
| Ref x , Ref y when Varinfo.equal x y -> e_zero
| Val(_,x,p) , Val(_,y,q) when Varinfo.equal x y ->
- e_div (e_sub (offset p) (offset q)) (e_int (Ctypes.sizeof_object obj))
+ e_div (e_sub (offset p) (offset q)) (e_int (Ctypes.sizeof_object obj))
| _ ->
- Warning.error ~source:"Reference Variable Model"
- "Uncomparable locations %a and %a" pretty a pretty b
+ Warning.error ~source:"Reference Variable Model"
+ "Uncomparable locations %a and %a" pretty a pretty b
let loc_compare lcmp icmp same a b =
match a , b with
| Loc l1 , Loc l2 -> lcmp l1 l2
| Ref x , Ref y ->
- if Varinfo.equal x y then same else p_not same
+ if Varinfo.equal x y then same else p_not same
| Val(_,x,p) , Val(_,y,q) ->
- if Varinfo.equal x y then icmp (offset p) (offset q) else p_not same
+ if Varinfo.equal x y then icmp (offset p) (offset q) else p_not same
| (Val _ | Loc _) , (Val _ | Loc _) -> lcmp (mloc_of_loc a) (mloc_of_loc b)
| Ref _ , (Val _ | Loc _) | (Val _ | Loc _) , Ref _ -> p_not same
@@ -919,10 +919,10 @@ struct
match offset with
| [] -> cond
| Field fd :: ofs ->
- offset_fits cond (Ctypes.object_of fd.ftype) ofs
+ offset_fits cond (Ctypes.object_of fd.ftype) ofs
| Shift(te,k) :: ofs ->
- let cond = array_check fits_inside cond te k obj in
- offset_fits cond te ofs
+ let cond = array_check fits_inside cond te k obj in
+ offset_fits cond te ofs
(* Append conditions to [cond] for [range=(elt,a,b)], starting at [offset],
consisting of [a..b] elements with type [elt] to fits inside the block,
@@ -931,20 +931,20 @@ struct
match offset with
| [] -> block_check fitting cond alloc range
| Field fd :: ofs ->
- range_check fitting cond (Ctypes.object_of fd.ftype,1) ofs range
+ range_check fitting cond (Ctypes.object_of fd.ftype,1) ofs range
| Shift(te,k) :: ofs ->
- if Ctypes.equal te elt then
- range_check fitting cond alloc ofs (elt,e_add a k,e_add b k)
- else
- match Ctypes.get_array (fst alloc) with
- | Some( e , Some n ) when Ctypes.equal e te ->
- let cond = fitting cond k k n in
- range_check fitting cond (e,n) ofs range
- | Some( _ , None ) ->
- unsized_array ()
- | _ ->
- let cond = block_check fitting cond alloc (te,k,k) in
- range_check fitting cond (te,1) ofs range
+ if Ctypes.equal te elt then
+ range_check fitting cond alloc ofs (elt,e_add a k,e_add b k)
+ else
+ match Ctypes.get_array (fst alloc) with
+ | Some( e , Some n ) when Ctypes.equal e te ->
+ let cond = fitting cond k k n in
+ range_check fitting cond (e,n) ofs range
+ | Some( _ , None ) ->
+ unsized_array ()
+ | _ ->
+ let cond = block_check fitting cond alloc (te,k,k) in
+ range_check fitting cond (te,1) ofs range
(* -------------------------------------------------------------------------- *)
(* --- Validity --- *)
@@ -954,27 +954,27 @@ struct
match acs , obj , ofs with
| OBJ , _ , [Shift(te,k)] -> Some(te,k,obj)
| OBJ , C_comp c , (Field fd :: ofs) ->
- begin
- match Option.map List.rev c.cfields with
- | Some (fd0::_) when Fieldinfo.equal fd fd0 ->
- last_field_shift acs (Ctypes.object_of fd.ftype) ofs
- | _ -> None
- end
+ begin
+ match Option.map List.rev c.cfields with
+ | Some (fd0::_) when Fieldinfo.equal fd fd0 ->
+ last_field_shift acs (Ctypes.object_of fd.ftype) ofs
+ | _ -> None
+ end
| _ -> None
let valid_offset acs obj ofs =
match last_field_shift acs obj ofs with
| Some(te,k,obj) ->
- F.p_conj (array_check fits_off_by_one [] te k obj)
+ F.p_conj (array_check fits_off_by_one [] te k obj)
| None ->
- F.p_conj (offset_fits [] obj ofs)
+ F.p_conj (offset_fits [] obj ofs)
let valid_range acs obj ofs range =
match last_field_shift acs obj ofs with
| Some _ ->
- F.p_conj (range_check fits_off_by_one [] (obj,1) ofs range)
+ F.p_conj (range_check fits_off_by_one [] (obj,1) ofs range)
| _ ->
- F.p_conj (range_check fits_inside [] (obj,1) ofs range)
+ F.p_conj (range_check fits_inside [] (obj,1) ofs range)
(* varinfo *)
@@ -988,7 +988,7 @@ struct
| CVAL | HEAP -> p_bool (ALLOC.value sigma.alloc x)
| CREF | CTXT Valid | CARR Valid -> p_true
| CTXT Nullable | CARR Nullable ->
- p_not @@ M.is_null (mloc_of_path mem x [])
+ p_not @@ M.is_null (mloc_of_path mem x [])
(* segment *)
@@ -1006,38 +1006,38 @@ struct
let valid sigma acs = function
| Rloc(obj,l) ->
- begin match l with
- | Ref _ -> p_true
- | Loc l -> M.valid sigma.mem acs (Rloc(obj,l))
- | Val(m,x,p) ->
- try valid_offset_path sigma acs m x p
+ begin match l with
+ | Ref _ -> p_true
+ | Loc l -> M.valid sigma.mem acs (Rloc(obj,l))
+ | Val(m,x,p) ->
+ try valid_offset_path sigma acs m x p
+ with ShiftMismatch ->
+ if is_heap_allocated m then
+ M.valid sigma.mem acs (Rloc(obj,mloc_of_loc l))
+ else
+ shift_mismatch l
+ end
+ | Rrange(l,elt,a,b) ->
+ begin match l with
+ | Ref x -> noref ~op:"valid sub-range of" x
+ | Loc l -> M.valid sigma.mem acs (Rrange(l,elt,a,b))
+ | Val(m,x,p) ->
+ match a,b with
+ | Some ka,Some kb ->
+ begin
+ try
+ F.p_imply (F.p_leq ka kb)
+ (valid_range_path sigma acs m x p (elt,ka,kb))
with ShiftMismatch ->
if is_heap_allocated m then
- M.valid sigma.mem acs (Rloc(obj,mloc_of_loc l))
- else
- shift_mismatch l
- end
- | Rrange(l,elt,a,b) ->
- begin match l with
- | Ref x -> noref ~op:"valid sub-range of" x
- | Loc l -> M.valid sigma.mem acs (Rrange(l,elt,a,b))
- | Val(m,x,p) ->
- match a,b with
- | Some ka,Some kb ->
- begin
- try
- F.p_imply (F.p_leq ka kb)
- (valid_range_path sigma acs m x p (elt,ka,kb))
- with ShiftMismatch ->
- if is_heap_allocated m then
- let l = mloc_of_loc l in
- M.valid sigma.mem acs (Rrange(l,elt,a,b))
- else shift_mismatch l
- end
- | _ ->
- Warning.error "Validity of infinite range @[%a.(%a..%a)@]"
- pretty l Vset.pp_bound a Vset.pp_bound b
- end
+ let l = mloc_of_loc l in
+ M.valid sigma.mem acs (Rrange(l,elt,a,b))
+ else shift_mismatch l
+ end
+ | _ ->
+ Warning.error "Validity of infinite range @[%a.(%a..%a)@]"
+ pretty l Vset.pp_bound a Vset.pp_bound b
+ end
(* -------------------------------------------------------------------------- *)
(* --- Invalidity --- *)
@@ -1056,38 +1056,38 @@ struct
let invalid sigma = function
| Rloc(obj,l) ->
- begin match l with
- | Ref _ -> p_false
- | Loc l -> M.invalid sigma.mem (Rloc(obj,l))
- | Val(m,x,p) ->
- try invalid_offset_path sigma m x p
+ begin match l with
+ | Ref _ -> p_false
+ | Loc l -> M.invalid sigma.mem (Rloc(obj,l))
+ | Val(m,x,p) ->
+ try invalid_offset_path sigma m x p
+ with ShiftMismatch ->
+ if is_heap_allocated m then
+ M.invalid sigma.mem (Rloc(obj,mloc_of_loc l))
+ else
+ shift_mismatch l
+ end
+ | Rrange(l,elt,a,b) ->
+ begin match l with
+ | Ref x -> noref ~op:"invalid sub-range of" x
+ | Loc l -> M.invalid sigma.mem (Rrange(l,elt,a,b))
+ | Val(m,x,p) ->
+ match a,b with
+ | Some ka,Some kb ->
+ begin
+ try
+ F.p_imply (F.p_leq ka kb)
+ (invalid_range_path sigma m x p (elt,ka,kb))
with ShiftMismatch ->
if is_heap_allocated m then
- M.invalid sigma.mem (Rloc(obj,mloc_of_loc l))
- else
- shift_mismatch l
- end
- | Rrange(l,elt,a,b) ->
- begin match l with
- | Ref x -> noref ~op:"invalid sub-range of" x
- | Loc l -> M.invalid sigma.mem (Rrange(l,elt,a,b))
- | Val(m,x,p) ->
- match a,b with
- | Some ka,Some kb ->
- begin
- try
- F.p_imply (F.p_leq ka kb)
- (invalid_range_path sigma m x p (elt,ka,kb))
- with ShiftMismatch ->
- if is_heap_allocated m then
- let l = mloc_of_loc l in
- M.invalid sigma.mem (Rrange(l,elt,a,b))
- else shift_mismatch l
- end
- | _ ->
- Warning.error "Invalidity of infinite range @[%a.(%a..%a)@]"
- pretty l Vset.pp_bound a Vset.pp_bound b
- end
+ let l = mloc_of_loc l in
+ M.invalid sigma.mem (Rrange(l,elt,a,b))
+ else shift_mismatch l
+ end
+ | _ ->
+ Warning.error "Invalidity of infinite range @[%a.(%a..%a)@]"
+ pretty l Vset.pp_bound a Vset.pp_bound b
+ end
(* -------------------------------------------------------------------------- *)
(* --- Initialized --- *)
@@ -1096,24 +1096,24 @@ struct
let rec initialized_loc sigma obj x ofs =
match obj with
| C_int _ | C_float _ | C_pointer _ ->
- p_bool (access_init (get_init_term sigma x) ofs)
+ p_bool (access_init (get_init_term sigma x) ofs)
| C_array { arr_flat=flat ; arr_element = te } ->
- let size = match flat with
- | None -> unsized_array ()
- | Some { arr_size } -> arr_size in
- let elt = Ctypes.object_of te in
- initialized_range sigma elt x ofs (e_int 0) (e_int (size-1))
+ let size = match flat with
+ | None -> unsized_array ()
+ | Some { arr_size } -> arr_size in
+ let elt = Ctypes.object_of te in
+ initialized_range sigma elt x ofs (e_int 0) (e_int (size-1))
| C_comp { cfields = None } ->
- Lang.F.p_equal
- (access_init (get_init_term sigma x) ofs)
- (Cvalues.initialized_obj obj)
+ Lang.F.p_equal
+ (access_init (get_init_term sigma x) ofs)
+ (Cvalues.initialized_obj obj)
| C_comp { cfields = Some fields } ->
- let init_field fd =
- let obj_fd = Ctypes.object_of fd.ftype in
- let ofs_fd = ofs @ [Field fd] in
- initialized_loc sigma obj_fd x ofs_fd
- in
- Lang.F.p_conj (List.map init_field fields)
+ let init_field fd =
+ let obj_fd = Ctypes.object_of fd.ftype in
+ let ofs_fd = ofs @ [Field fd] in
+ initialized_loc sigma obj_fd x ofs_fd
+ in
+ Lang.F.p_conj (List.map init_field fields)
and initialized_range sigma elt x ofs lo up =
let i = Lang.freshvar ~basename:"i" Lang.t_int in
@@ -1126,49 +1126,49 @@ struct
let initialized sigma l =
match l with
| Rloc(obj,l) ->
- begin match l with
- | Ref _ -> p_true
- | Loc l -> M.initialized sigma.mem (Rloc(obj,l))
- | Val(m,x,p) ->
- if is_heap_allocated m then
- M.initialized sigma.mem (Rloc(obj,mloc_of_loc l))
- else if Cvalues.always_initialized x then
- try valid_offset RD (vobject m x) p
- with ShiftMismatch -> shift_mismatch l
- else
- initialized_loc sigma obj x p
- end
+ begin match l with
+ | Ref _ -> p_true
+ | Loc l -> M.initialized sigma.mem (Rloc(obj,l))
+ | Val(m,x,p) ->
+ if is_heap_allocated m then
+ M.initialized sigma.mem (Rloc(obj,mloc_of_loc l))
+ else if Cvalues.always_initialized x then
+ try valid_offset RD (vobject m x) p
+ with ShiftMismatch -> shift_mismatch l
+ else
+ initialized_loc sigma obj x p
+ end
| Rrange(l,elt, Some a, Some b) ->
- begin match l with
- | Ref _ -> p_true
- | Loc l -> M.initialized sigma.mem (Rrange(l,elt,Some a, Some b))
- | Val(m,x,p) ->
- try
- if is_heap_allocated m then
- let l = mloc_of_loc l in
- M.initialized sigma.mem (Rrange(l,elt,Some a, Some b))
- else
- let rec normalize obj = function
- | [] -> [], a, b
- | [Shift(elt, i)] when Ctypes.equal obj elt ->
- [], F.e_add a i, F.e_add b i
- | f :: ofs ->
- let l, a, b = normalize obj ofs in f :: l, a, b
- in
- let p, a, b = normalize elt p in
- let in_array = valid_range RD (vobject m x) p (elt, a, b) in
- let initialized =
- if Cvalues.always_initialized x then p_true
- else initialized_range sigma elt x p a b
- in
- F.p_imply (F.p_leq a b) (p_and in_array initialized)
- with ShiftMismatch ->
- shift_mismatch l
- end
+ begin match l with
+ | Ref _ -> p_true
+ | Loc l -> M.initialized sigma.mem (Rrange(l,elt,Some a, Some b))
+ | Val(m,x,p) ->
+ try
+ if is_heap_allocated m then
+ let l = mloc_of_loc l in
+ M.initialized sigma.mem (Rrange(l,elt,Some a, Some b))
+ else
+ let rec normalize obj = function
+ | [] -> [], a, b
+ | [Shift(elt, i)] when Ctypes.equal obj elt ->
+ [], F.e_add a i, F.e_add b i
+ | f :: ofs ->
+ let l, a, b = normalize obj ofs in f :: l, a, b
+ in
+ let p, a, b = normalize elt p in
+ let in_array = valid_range RD (vobject m x) p (elt, a, b) in
+ let initialized =
+ if Cvalues.always_initialized x then p_true
+ else initialized_range sigma elt x p a b
+ in
+ F.p_imply (F.p_leq a b) (p_and in_array initialized)
+ with ShiftMismatch ->
+ shift_mismatch l
+ end
| Rrange(l, _,a,b) ->
- Warning.error
- "Initialization of infinite range @[%a.(%a..%a)@]"
- pretty l Vset.pp_bound a Vset.pp_bound b
+ Warning.error
+ "Initialization of infinite range @[%a.(%a..%a)@]"
+ pretty l Vset.pp_bound a Vset.pp_bound b
(* -------------------------------------------------------------------------- *)
@@ -1181,15 +1181,15 @@ struct
-> F.p_true
| TPtr _ | TFun _ -> phi v
| TComp({ cfields = None },_) ->
- F.p_true
+ F.p_true
| TComp({ cfields = Some fields },_) ->
- F.p_all
- (fun fd ->
- forall_pointers phi (e_getfield v (Cfield (fd, KValue))) fd.ftype)
- fields
+ F.p_all
+ (fun fd ->
+ forall_pointers phi (e_getfield v (Cfield (fd, KValue))) fd.ftype)
+ fields
| TArray(elt,_,_) ->
- let k = Lang.freshvar Qed.Logic.Int in
- F.p_forall [k] (forall_pointers phi (e_get v (e_var k)) elt)
+ let k = Lang.freshvar Qed.Logic.Int in
+ F.p_forall [k] (forall_pointers phi (e_get v (e_var k)) elt)
let frame sigma =
let hs = ref [] in
@@ -1246,14 +1246,14 @@ struct
match scope with
| Leave -> []
| Enter ->
- let init_status v =
- if v.vdefined || Cvalues.always_initialized v || not@@ is_mvar_alloc v
- then None
- else
- let i = Cvalues.uninitialized_obj (Ctypes.object_of v.vtype) in
- Some (Lang.F.p_equal (access_init (get_init_term seq.post v) []) i)
- in
- List.filter_map init_status xs
+ let init_status v =
+ if v.vdefined || Cvalues.always_initialized v || not@@ is_mvar_alloc v
+ then None
+ else
+ let i = Cvalues.uninitialized_obj (Ctypes.object_of v.vtype) in
+ Some (Lang.F.p_equal (access_init (get_init_term seq.post v) []) i)
+ in
+ List.filter_map init_status xs
let is_nullable m v =
let addr = nullable_address v in
@@ -1295,40 +1295,40 @@ struct
(*TODO: optimized version for terminal [Field _] and [Index _] *)
| Field f :: ofs ->
- let cf = Cfield (f, kind) in
- let af = e_getfield a cf in
- let bf = e_getfield b cf in
- let hs = assigned_path kind hs xs ys af bf ofs in
- List.fold_left
- (fun hs g ->
- if Fieldinfo.equal f g then hs else
- let cg = Cfield (g, kind) in
- let ag = e_getfield a cg in
- let bg = e_getfield b cg in
- let eqg = p_forall ys (p_equal ag bg) in
- eqg :: hs
- ) hs
- (* Note: we have field accesses, everything here is thus complete *)
- (Option.get f.fcomp.cfields)
+ let cf = Cfield (f, kind) in
+ let af = e_getfield a cf in
+ let bf = e_getfield b cf in
+ let hs = assigned_path kind hs xs ys af bf ofs in
+ List.fold_left
+ (fun hs g ->
+ if Fieldinfo.equal f g then hs else
+ let cg = Cfield (g, kind) in
+ let ag = e_getfield a cg in
+ let bg = e_getfield b cg in
+ let eqg = p_forall ys (p_equal ag bg) in
+ eqg :: hs
+ ) hs
+ (* Note: we have field accesses, everything here is thus complete *)
+ (Option.get f.fcomp.cfields)
| Shift(_,e) :: ofs ->
- let y = Lang.freshvar ~basename:"k" Qed.Logic.Int in
- let k = e_var y in
- let ak = e_get a k in
- let bk = e_get b k in
- if List.exists (fun x -> F.occurs x e) xs then
- (* index [e] is covered by [xs]:
- must explore deeper the remaining path. *)
- assigned_path kind hs xs (y::ys) ak bk ofs
- else
- (* index [e] is not covered by [xs]:
- any index different from e is disjoint.
- explore also deeply with index [e]. *)
- let ae = e_get a e in
- let be = e_get b e in
- let ek = p_neq e k in
- let eqk = p_forall (y::ys) (p_imply ek (p_equal ak bk)) in
- assigned_path kind (eqk :: hs) xs ys ae be ofs
+ let y = Lang.freshvar ~basename:"k" Qed.Logic.Int in
+ let k = e_var y in
+ let ak = e_get a k in
+ let bk = e_get b k in
+ if List.exists (fun x -> F.occurs x e) xs then
+ (* index [e] is covered by [xs]:
+ must explore deeper the remaining path. *)
+ assigned_path kind hs xs (y::ys) ak bk ofs
+ else
+ (* index [e] is not covered by [xs]:
+ any index different from e is disjoint.
+ explore also deeply with index [e]. *)
+ let ae = e_get a e in
+ let be = e_get b e in
+ let ek = p_neq e k in
+ let eqk = p_forall (y::ys) (p_imply ek (p_equal ak bk)) in
+ assigned_path kind (eqk :: hs) xs ys ae be ofs
let assigned_genset s xs mem x ofs p =
let valid = valid_offset_path s.post Sigs.RW mem x ofs in
@@ -1371,88 +1371,88 @@ struct
| C_array { arr_element=t } when Cil.isStructOrUnionType t -> p_true
| C_int _ | C_float _ | C_pointer _ ->
- p_imply
- (p_bool (access_init (get_init_term seq.pre x) ofs))
- (p_bool (access_init (get_init_term seq.post x) ofs))
+ p_imply
+ (p_bool (access_init (get_init_term seq.pre x) ofs))
+ (p_bool (access_init (get_init_term seq.post x) ofs))
| C_array { arr_flat=flat ; arr_element=t } ->
- let size = match flat with
- | None -> unsized_array ()
- | Some { arr_size } -> arr_size
- in
- let v = Lang.freshvar ~basename:"i" Lang.t_int in
- let obj = Ctypes.object_of t in
- let ofs = ofs @ [ Shift(obj, e_var v) ] in
- let low = Some (e_int 0) in
- let up = Some (e_int (size-1)) in
- let hyp = Vset.in_range (e_var v) low up in
- let in_range = monotonic_initialized seq obj x ofs in
- Lang.F.p_forall [v] (p_imply hyp in_range)
+ let size = match flat with
+ | None -> unsized_array ()
+ | Some { arr_size } -> arr_size
+ in
+ let v = Lang.freshvar ~basename:"i" Lang.t_int in
+ let obj = Ctypes.object_of t in
+ let ofs = ofs @ [ Shift(obj, e_var v) ] in
+ let low = Some (e_int 0) in
+ let up = Some (e_int (size-1)) in
+ let hyp = Vset.in_range (e_var v) low up in
+ let in_range = monotonic_initialized seq obj x ofs in
+ Lang.F.p_forall [v] (p_imply hyp in_range)
let assigned_loc seq obj = function
| Ref x -> noref ~op:"assigns to" x
| Val((CVAL|CREF),x,[]) ->
- [ Assert (monotonic_initialized seq obj x []) ]
+ [ Assert (monotonic_initialized seq obj x []) ]
| Val((CVAL|CREF),x,ofs) ->
- let value = Lang.freshvar ~basename:"v" (tau_of_object obj) in
- memvar_stored KValue seq x ofs (e_var value) ::
- if Cil.isStructOrUnionType x.vtype then []
- else begin
- let init = Lang.freshvar ~basename:"v" (init_of_object obj) in
- Assert(monotonic_initialized seq obj x ofs) ::
- [ memvar_stored KInit seq x ofs (e_var init) ]
- end
+ let value = Lang.freshvar ~basename:"v" (tau_of_object obj) in
+ memvar_stored KValue seq x ofs (e_var value) ::
+ if Cil.isStructOrUnionType x.vtype then []
+ else begin
+ let init = Lang.freshvar ~basename:"v" (init_of_object obj) in
+ Assert(monotonic_initialized seq obj x ofs) ::
+ [ memvar_stored KInit seq x ofs (e_var init) ]
+ end
| Val((HEAP|CTXT _|CARR _) as m,x,ofs) ->
- M.assigned (mseq_of_seq seq) obj (Sloc (mloc_of_path m x ofs))
+ M.assigned (mseq_of_seq seq) obj (Sloc (mloc_of_path m x ofs))
| Loc l ->
- M.assigned (mseq_of_seq seq) obj (Sloc l)
+ M.assigned (mseq_of_seq seq) obj (Sloc l)
let assigned_array seq obj l elt n =
match l with
| Ref x -> noref ~op:"assigns to" x
| Val((CVAL|CREF),x,[]) ->
- if Ctypes.is_compound elt then []
- else
- (* Note that 'obj' above corresponds to the elements *)
- let obj = Ctypes.object_of x.vtype in
- [ Assert (monotonic_initialized seq obj x []) ]
+ if Ctypes.is_compound elt then []
+ else
+ (* Note that 'obj' above corresponds to the elements *)
+ let obj = Ctypes.object_of x.vtype in
+ [ Assert (monotonic_initialized seq obj x []) ]
| Val((CVAL|CREF),x,ofs) ->
- let f_array t =
- e_var (Lang.freshvar ~basename:"v" Qed.Logic.(Array(Int, t))) in
- [ memvar_stored KValue seq x ofs (f_array @@ Lang.tau_of_object elt) ;
- memvar_stored KInit seq x ofs (f_array @@ Lang.init_of_object elt) ]
+ let f_array t =
+ e_var (Lang.freshvar ~basename:"v" Qed.Logic.(Array(Int, t))) in
+ [ memvar_stored KValue seq x ofs (f_array @@ Lang.tau_of_object elt) ;
+ memvar_stored KInit seq x ofs (f_array @@ Lang.init_of_object elt) ]
| Val((HEAP|CTXT _|CARR _) as m,x,ofs) ->
- let l = mloc_of_path m x ofs in
- M.assigned (mseq_of_seq seq) obj (Sarray(l,elt,n))
+ let l = mloc_of_path m x ofs in
+ M.assigned (mseq_of_seq seq) obj (Sarray(l,elt,n))
| Loc l ->
- M.assigned (mseq_of_seq seq) obj (Sarray(l,elt,n))
+ M.assigned (mseq_of_seq seq) obj (Sarray(l,elt,n))
let assigned_range seq obj l elt a b =
match l with
| Ref x -> noref ~op:"assigns to" x
| Loc l ->
- M.assigned (mseq_of_seq seq) obj (Srange(l,elt,a,b))
+ M.assigned (mseq_of_seq seq) obj (Srange(l,elt,a,b))
| Val((HEAP|CTXT _|CARR _) as m,x,ofs) ->
- M.assigned (mseq_of_seq seq) obj (Srange(mloc_of_path m x ofs,elt,a,b))
+ M.assigned (mseq_of_seq seq) obj (Srange(mloc_of_path m x ofs,elt,a,b))
| Val((CVAL|CREF) as m,x,ofs) ->
- let k = Lang.freshvar ~basename:"k" Qed.Logic.Int in
- let p = Vset.in_range (e_var k) a b in
- let ofs = ofs_shift elt (e_var k) ofs in
- (* (monotonic_initialized_genset seq [k] m x ofs p) @*)
- (assigned_genset seq [k] m x ofs p)
+ let k = Lang.freshvar ~basename:"k" Qed.Logic.Int in
+ let p = Vset.in_range (e_var k) a b in
+ let ofs = ofs_shift elt (e_var k) ofs in
+ (* (monotonic_initialized_genset seq [k] m x ofs p) @*)
+ (assigned_genset seq [k] m x ofs p)
let assigned_descr seq obj xs l p =
match l with
| Ref x -> noref ~op:"assigns to" x
| Loc l ->
- M.assigned (mseq_of_seq seq) obj (Sdescr(xs,l,p))
+ M.assigned (mseq_of_seq seq) obj (Sdescr(xs,l,p))
| Val((HEAP|CTXT _|CARR _) as m,x,ofs) ->
- M.assigned (mseq_of_seq seq) obj (Sdescr(xs,mloc_of_path m x ofs,p))
+ M.assigned (mseq_of_seq seq) obj (Sdescr(xs,mloc_of_path m x ofs,p))
| Val((CVAL|CREF) as m,x,ofs) ->
- (* (monotonic_initialized_genset seq xs m x ofs p) @ *)
- (assigned_genset seq xs m x ofs p)
+ (* (monotonic_initialized_genset seq xs m x ofs p) @ *)
+ (assigned_genset seq xs m x ofs p)
let assigned seq obj = function
| Sloc l -> assigned_loc seq obj l
@@ -1483,12 +1483,12 @@ struct
let rec dstartof dim = function
| C_array arr ->
- let n = match arr.arr_flat with None -> 1 | Some a -> a.arr_dim in
- if n > dim then
- let u = Some e_zero in
- let elt = Ctypes.object_of arr.arr_element in
- Drange(u,u) :: dstartof dim elt
- else []
+ let n = match arr.arr_flat with None -> 1 | Some a -> a.arr_dim in
+ if n > dim then
+ let u = Some e_zero in
+ let elt = Ctypes.object_of arr.arr_element in
+ Drange(u,u) :: dstartof dim elt
+ else []
| _ -> []
let rec doffset obj host = function
@@ -1501,7 +1501,7 @@ struct
match ofs with
| [] -> [ Drange(a,b) ]
| [Shift(elt,k)] when Ctypes.equal elt obj ->
- [ Drange( Vset.bound_shift a k , Vset.bound_shift b k ) ]
+ [ Drange( Vset.bound_shift a k , Vset.bound_shift b k ) ]
| d :: ofs -> dofs d :: range ofs obj a b
let locseg = function
@@ -1511,23 +1511,23 @@ struct
| Rloc(obj,Loc l) -> Lseg (Rloc(obj,l))
| Rloc(obj,Val((CVAL|CREF),x,ofs)) ->
- Fseg(x,delta obj x ofs)
+ Fseg(x,delta obj x ofs)
| Rrange(Loc l,obj,a,b) -> Lseg (Rrange(l,obj,a,b))
| Rrange(Val((CVAL|CREF),x,ofs),obj,a,b) ->
- Fseg(x,range ofs obj a b)
+ Fseg(x,range ofs obj a b)
(* Nullable: force M without symbolic access *)
| Rloc(obj,Val((CTXT Nullable|CARR Nullable) as m,x,ofs)) ->
- Lseg(Rloc(obj, mloc_of_path m x ofs))
+ Lseg(Rloc(obj, mloc_of_path m x ofs))
| Rrange(Val((CTXT Nullable|CARR Nullable) as m,x,ofs),obj,a,b) ->
- Lseg(Rrange(mloc_of_path m x ofs, obj, a, b))
+ Lseg(Rrange(mloc_of_path m x ofs, obj, a, b))
(* Otherwise: use M with symbolic access *)
| Rloc(obj,Val((CTXT Valid|CARR Valid|HEAP) as m,x,ofs)) ->
- Mseg(Rloc(obj,mloc_of_path m x ofs),x,delta obj x ofs)
+ Mseg(Rloc(obj,mloc_of_path m x ofs),x,delta obj x ofs)
| Rrange(Val((CTXT Valid|CARR Valid|HEAP) as m,x,ofs),obj,a,b) ->
- Mseg(Rrange(mloc_of_path m x ofs,obj,a,b),x,range ofs obj a b)
+ Mseg(Rrange(mloc_of_path m x ofs,obj,a,b),x,range ofs obj a b)
(* -------------------------------------------------------------------------- *)
(* --- Segment Inclusion --- *)
@@ -1538,14 +1538,14 @@ struct
| _ , [] -> p_true
| [] , _ -> p_false
| u :: d1 , v :: d2 ->
- match u , v with
- | Dfield f , Dfield g when Fieldinfo.equal f g ->
- included_delta d1 d2
- | Dfield _ , _ | _ , Dfield _ -> p_false
- | Drange(a1,b1) , Drange(a2,b2) ->
- p_conj [ Vset.ordered ~strict:false ~limit:true a2 a1 ;
- Vset.ordered ~strict:false ~limit:true b1 b2 ;
- included_delta d1 d2 ]
+ match u , v with
+ | Dfield f , Dfield g when Fieldinfo.equal f g ->
+ included_delta d1 d2
+ | Dfield _ , _ | _ , Dfield _ -> p_false
+ | Drange(a1,b1) , Drange(a2,b2) ->
+ p_conj [ Vset.ordered ~strict:false ~limit:true a2 a1 ;
+ Vset.ordered ~strict:false ~limit:true b1 b2 ;
+ included_delta d1 d2 ]
let included s1 s2 =
match locseg s1 , locseg s2 with
@@ -1554,7 +1554,7 @@ struct
| Fseg(x1,d1) , Fseg(x2,d2)
| Mseg(_,x1,d1) , Mseg(_,x2,d2) ->
- if Varinfo.equal x1 x2 then included_delta d1 d2 else p_false
+ if Varinfo.equal x1 x2 then included_delta d1 d2 else p_false
| Fseg _ , _ | _ , Fseg _ -> p_false
@@ -1568,14 +1568,14 @@ struct
match d1 , d2 with
| [] , _ | _ , [] -> p_false
| u :: d1 , v :: d2 ->
- match u , v with
- | Dfield f , Dfield g when Fieldinfo.equal f g
- -> separated_delta d1 d2
- | Dfield _ , _ | _ , Dfield _ -> p_true
- | Drange(a1,b1) , Drange(a2,b2) ->
- p_disj [ Vset.ordered ~strict:true ~limit:false b1 a2 ;
- Vset.ordered ~strict:true ~limit:false b2 a1 ;
- separated_delta d1 d2 ]
+ match u , v with
+ | Dfield f , Dfield g when Fieldinfo.equal f g
+ -> separated_delta d1 d2
+ | Dfield _ , _ | _ , Dfield _ -> p_true
+ | Drange(a1,b1) , Drange(a2,b2) ->
+ p_disj [ Vset.ordered ~strict:true ~limit:false b1 a2 ;
+ Vset.ordered ~strict:true ~limit:false b2 a1 ;
+ separated_delta d1 d2 ]
let separated r1 r2 =
match locseg r1 , locseg r2 with
@@ -1584,7 +1584,7 @@ struct
| Fseg(x1,d1) , Fseg(x2,d2)
| Mseg(_,x1,d1) , Mseg(_,x2,d2) ->
- if Varinfo.equal x1 x2 then separated_delta d1 d2 else p_true
+ if Varinfo.equal x1 x2 then separated_delta d1 d2 else p_true
| Fseg _ , _ | _ , Fseg _ -> p_true
| (Lseg s1|Mseg(s1,_,_)) , (Lseg s2|Mseg(s2,_,_)) -> M.separated s1 s2
@@ -1596,14 +1596,14 @@ struct
let domain obj l =
match l with
| Ref x | Val((CVAL|CREF),x,_) ->
- let init =
- if not @@ Cvalues.always_initialized x then [ Init x ] else []
- in
- Heap.Set.of_list ((Var x) :: init)
+ let init =
+ if not @@ Cvalues.always_initialized x then [ Init x ] else []
+ in
+ Heap.Set.of_list ((Var x) :: init)
| Loc _ | Val((CTXT _|CARR _|HEAP),_,_) ->
- M.Heap.Set.fold
- (fun m s -> Heap.Set.add (Mem m) s)
- (M.domain obj (mloc_of_loc l)) Heap.Set.empty
+ M.Heap.Set.fold
+ (fun m s -> Heap.Set.add (Mem m) s)
+ (M.domain obj (mloc_of_loc l)) Heap.Set.empty
let is_well_formed sigma =
let cstrs = ref [] in
diff --git a/src/plugins/wp/MemZeroAlias.ml b/src/plugins/wp/MemZeroAlias.ml
index 4ba69ca09b78975e00476fbf2c4ac0285045700b..7317d3811be95b6efe5f85289883cdd41f7a8766 100644
--- a/src/plugins/wp/MemZeroAlias.ml
+++ b/src/plugins/wp/MemZeroAlias.ml
@@ -233,8 +233,8 @@ let rec ipath lv = function
| S::w -> ipath (Mval lv,[]) w
| I::_ -> raise Not_found
| F f::w ->
- let (host,path) = lv in
- ipath (host, path @ [Mfield f]) w
+ let (host,path) = lv in
+ ipath (host, path @ [Mfield f]) w
let ilval (x,p) = ipath (Mvar x,[]) p
let heap domain state =
@@ -254,10 +254,10 @@ let updates seq domain =
match v1,v2 with
| _,None -> ()
| None,Some v ->
- pool := Bag.add (Mstore(ilval c,v)) !pool
+ pool := Bag.add (Mstore(ilval c,v)) !pool
| Some v1,Some v2 ->
- if v2 != v1 then
- pool := Bag.add (Mstore (ilval c,v2)) !pool
+ if v2 != v1 then
+ pool := Bag.add (Mstore (ilval c,v2)) !pool
with Not_found -> ()
) pre post ;
!pool
diff --git a/src/plugins/wp/MemoryContext.ml b/src/plugins/wp/MemoryContext.ml
index 1b1066105cb0354d9d327f72617a2a2d9b911fbf..2bd1854e35d1900cd6d5ee9ac69064ba27259b64 100644
--- a/src/plugins/wp/MemoryContext.ml
+++ b/src/plugins/wp/MemoryContext.ml
@@ -78,31 +78,31 @@ let set x p w =
| NotUsed -> w
| ByAddr -> { w with by_addr = Var x :: w.by_addr }
| ByRef ->
- if Cil.isFunctionType x.vtype then w else
- { w with context = Ptr x :: w.context }
+ if Cil.isFunctionType x.vtype then w else
+ { w with context = Ptr x :: w.context }
| InContext v ->
- if Cil.isFunctionType x.vtype then w else
- begin match v with
- | Nullable -> { w with nullable = Ptr x :: w.nullable }
- | Valid -> { w with context = Ptr x :: w.context }
- end
+ if Cil.isFunctionType x.vtype then w else
+ begin match v with
+ | Nullable -> { w with nullable = Ptr x :: w.nullable }
+ | Valid -> { w with context = Ptr x :: w.context }
+ end
| InArray v ->
- if Cil.isFunctionType x.vtype then w else
- begin match v with
- | Nullable -> { w with nullable = Arr x :: w.nullable }
- | Valid -> { w with context = Arr x :: w.context }
- end
+ if Cil.isFunctionType x.vtype then w else
+ begin match v with
+ | Nullable -> { w with nullable = Arr x :: w.nullable }
+ | Valid -> { w with context = Arr x :: w.context }
+ end
| ByValue | ByShift ->
- if x.vghost then w else
- if Cil.isFunctionType x.vtype then w else
- if x.vglob && (x.vstorage <> Static || x.vaddrof) then
- let z = if Cil.isArrayType x.vtype then Arr x else Var x in
- { w with globals = z :: w.globals }
- else
- if x.vformal && Cil.isPointerType x.vtype then
- let z = if p = ByShift then Arr x else Ptr x in
- { w with to_heap = z :: w.to_heap }
- else w
+ if x.vghost then w else
+ if Cil.isFunctionType x.vtype then w else
+ if x.vglob && (x.vstorage <> Static || x.vaddrof) then
+ let z = if Cil.isArrayType x.vtype then Arr x else Var x in
+ { w with globals = z :: w.globals }
+ else
+ if x.vformal && Cil.isPointerType x.vtype then
+ let z = if p = ByShift then Arr x else Ptr x in
+ { w with to_heap = z :: w.to_heap }
+ else w
(* -------------------------------------------------------------------------- *)
(* --- Building Annotations --- *)
@@ -113,32 +113,32 @@ open Logic_const
let rec ptr_of = function
| Ctype t -> Ctype (TPtr(t, []))
| t when Logic_typing.is_set_type t ->
- let t = Logic_typing.type_of_set_elem t in
- Logic_const.make_set_type (ptr_of t)
+ let t = Logic_typing.type_of_set_elem t in
+ Logic_const.make_set_type (ptr_of t)
| _ -> assert false
let rec addr_of_lval ?loc term =
let typ = ptr_of term.term_type in
match term.term_node with
| TLval lv ->
- Logic_utils.mk_logic_AddrOf ?loc lv typ
+ Logic_utils.mk_logic_AddrOf ?loc lv typ
| TCastE (_, t) | TLogic_coerce (_, t) ->
- addr_of_lval ?loc t
+ addr_of_lval ?loc t
| Tif(c, t, e) ->
- let t = addr_of_lval ?loc t in
- let e = addr_of_lval ?loc e in
- Logic_const.term ?loc (Tif(c, t, e)) typ
+ let t = addr_of_lval ?loc t in
+ let e = addr_of_lval ?loc e in
+ Logic_const.term ?loc (Tif(c, t, e)) typ
| Tat( _, _) ->
- term
+ term
| Tunion l ->
- let l = List.map (addr_of_lval ?loc) l in
- Logic_const.term ?loc (Tunion l) typ
+ let l = List.map (addr_of_lval ?loc) l in
+ Logic_const.term ?loc (Tunion l) typ
| Tinter l ->
- let l = List.map (addr_of_lval ?loc) l in
- Logic_const.term ?loc (Tinter l) typ
+ let l = List.map (addr_of_lval ?loc) l in
+ Logic_const.term ?loc (Tinter l) typ
| Tcomprehension (t, qs, p) ->
- let t = addr_of_lval ?loc t in
- Logic_const.term ?loc (Tcomprehension (t,qs,p)) typ
+ let t = addr_of_lval ?loc t in
+ Logic_const.term ?loc (Tcomprehension (t,qs,p)) typ
| _ -> term
let type_of_zone = function
@@ -168,35 +168,35 @@ let zone_to_term ?(to_char=false) loc zone =
| Var vi -> loc_range (term ~loc (TAddrOf(lval vi)) typ)
| Ptr vi -> loc_range (term ~loc (TLval(lval vi)) typ)
| Arr vi ->
- let ptr =
- if Cil.isArrayType vi.vtype
- then term ~loc (TStartOf (lval vi)) typ
- else term ~loc (TLval(lval vi)) typ
- in
- let ptr =
- if not to_char then ptr
- else Logic_utils.mk_cast ~loc Cil.charPtrType ptr
- in
- let range = trange ~loc (None, None) in
- term ~loc (TBinOp(PlusPI, ptr, range)) ptr.term_type
+ let ptr =
+ if Cil.isArrayType vi.vtype
+ then term ~loc (TStartOf (lval vi)) typ
+ else term ~loc (TLval(lval vi)) typ
+ in
+ let ptr =
+ if not to_char then ptr
+ else Logic_utils.mk_cast ~loc Cil.charPtrType ptr
+ in
+ let range = trange ~loc (None, None) in
+ term ~loc (TBinOp(PlusPI, ptr, range)) ptr.term_type
let region_to_term loc = function
| [] -> term ~loc Tempty_set (Ctype Cil.charPtrType)
| [z] -> zone_to_term loc z
| x :: tl as l ->
- let fst = type_of_zone x in
- let tl = List.map type_of_zone tl in
- let to_char = not (List.for_all (Cil_datatype.Typ.equal fst) tl) in
- let set_typ =
- make_set_type (Ctype (if to_char then Cil.charPtrType else fst))
- in
- term ~loc (Tunion (List.map (zone_to_term ~to_char loc) l)) set_typ
+ let fst = type_of_zone x in
+ let tl = List.map type_of_zone tl in
+ let to_char = not (List.for_all (Cil_datatype.Typ.equal fst) tl) in
+ let set_typ =
+ make_set_type (Ctype (if to_char then Cil.charPtrType else fst))
+ in
+ term ~loc (Tunion (List.map (zone_to_term ~to_char loc) l)) set_typ
let separated_list ?loc = function
| [] | [ _ ] -> ptrue
| l ->
- let comp = Cil_datatype.Term.compare in
- pseparated ?loc (List.sort comp l)
+ let comp = Cil_datatype.Term.compare in
+ pseparated ?loc (List.sort comp l)
let term_separated_from_regions loc assigned l =
separated_list ~loc (assigned :: List.map (region_to_term loc) l)
@@ -237,13 +237,13 @@ let welltyped zones =
let rec partition_by_type t acc l =
match l, acc with
| [], _ ->
- acc
+ acc
| x :: l, [] ->
- partition_by_type (type_of_zone x) [[x]] l
+ partition_by_type (type_of_zone x) [[x]] l
| x :: l, p :: acc' when Cil_datatype.Typ.equal t (type_of_zone x) ->
- partition_by_type t ((x :: p) :: acc') l
+ partition_by_type t ((x :: p) :: acc') l
| x :: l, acc ->
- partition_by_type (type_of_zone x) ([x] :: acc) l
+ partition_by_type (type_of_zone x) ([x] :: acc) l
in
let compare_zone a b =
Cil_datatype.Typ.compare (type_of_zone a) (type_of_zone b) in
@@ -290,18 +290,18 @@ let main_separation loc globals context nullable heaps =
(* trivial cases *)
| [] -> [] | [_] -> []
| p :: l ->
- let acc_sep q = List.cons @@ separated_nullable (p, q) in
- List.fold_right acc_sep l @@ collect_pairs l
+ let acc_sep q = List.cons @@ separated_nullable (p, q) in
+ List.fold_right acc_sep l @@ collect_pairs l
in
collect_pairs nullable
in
match nullable with
| [] -> List.map no_nullable l_zones
| nullable ->
- let t_nullable = regions_to_terms nullable in
- let sep_nullable = nullable_inter t_nullable in
- let fold n = List.fold_right (acc_with_nullable n) l_zones in
- List.fold_right fold t_nullable sep_nullable
+ let t_nullable = regions_to_terms nullable in
+ let sep_nullable = nullable_inter t_nullable in
+ let fold n = List.fold_right (acc_with_nullable n) l_zones in
+ List.fold_right fold t_nullable sep_nullable
(* Filter assigns *)
let assigned_locations kf filter =
@@ -319,16 +319,16 @@ let assigned_via_pointers kf =
let rec assigned_via_pointer t =
match t.term_node with
| TLval (TMem _, _) ->
- true
+ true
| TCastE (_, t) | TLogic_coerce (_, t)
| Tcomprehension(t, _, _) | Tat (t, _) ->
- assigned_via_pointer t
+ assigned_via_pointer t
| Tunion l | Tinter l ->
- List.exists assigned_via_pointer l
+ List.exists assigned_via_pointer l
| Tif (_, t1, t2) ->
- assigned_via_pointer t1 || assigned_via_pointer t2
+ assigned_via_pointer t1 || assigned_via_pointer t2
| _ ->
- false
+ false
in
assigned_locations kf assigned_via_pointer
@@ -410,15 +410,15 @@ let compute_behavior kf name hypotheses_computer =
match reqs, ens with
| [], [] -> None
| reqs, ens ->
- Some {
- b_name = Annotations.fresh_behavior_name kf ("wp_" ^ name) ;
- b_requires = reqs ;
- b_assumes = [] ;
- b_post_cond = ens ;
- b_assigns = WritesAny ;
- b_allocation = FreeAllocAny ;
- b_extended = []
- }
+ Some {
+ b_name = Annotations.fresh_behavior_name kf ("wp_" ^ name) ;
+ b_requires = reqs ;
+ b_assumes = [] ;
+ b_post_cond = ens ;
+ b_assigns = WritesAny ;
+ b_allocation = FreeAllocAny ;
+ b_extended = []
+ }
(* -------------------------------------------------------------------------- *)
(* --- Memoization --- *)
@@ -472,11 +472,11 @@ let warn kf name hyp_computer =
match get_behavior kf name hyp_computer with
| None -> ()
| Some bhv ->
- Wp_parameters.warning
- ~current:false ~once:true ~source:(fst(Kernel_function.get_location kf))
- "@[<hv 0>Memory model hypotheses for function '%s':@ %t@]"
- (Kernel_function.get_name kf)
- (print_memory_context kf bhv)
+ Wp_parameters.warning
+ ~current:false ~once:true ~source:(fst(Kernel_function.get_location kf))
+ "@[<hv 0>Memory model hypotheses for function '%s':@ %t@]"
+ (Kernel_function.get_name kf)
+ (print_memory_context kf bhv)
let emitter =
Emitter.(create "Wp.Hypotheses" [Funspec] ~correctness:[] ~tuning:[])
diff --git a/src/plugins/wp/Passive.ml b/src/plugins/wp/Passive.ml
index 90f0d8dd947345d777ad4efdee2dbd1a2a29d955..1907622e2f33aa6b847c70a1d83d82dc561d44b4 100644
--- a/src/plugins/wp/Passive.ml
+++ b/src/plugins/wp/Passive.ml
@@ -60,9 +60,9 @@ let pretty fmt =
List.iter
begin function
| Bind(x,y) ->
- Format.fprintf fmt "@ @[%a:=%a@]"
- F.pp_var x F.pp_var y
+ Format.fprintf fmt "@ @[%a:=%a@]"
+ F.pp_var x F.pp_var y
| Join(x,y) ->
- Format.fprintf fmt "@ @[%a==%a@]"
- F.pp_var x F.pp_var y
+ Format.fprintf fmt "@ @[%a==%a@]"
+ F.pp_var x F.pp_var y
end
diff --git a/src/plugins/wp/Pcfg.ml b/src/plugins/wp/Pcfg.ml
index dba54030518e397e49fe63eccbdace8f68b37656..7024a9bd7acfbbab5bb622c095dd79fd1237ba2e 100644
--- a/src/plugins/wp/Pcfg.ml
+++ b/src/plugins/wp/Pcfg.ml
@@ -91,13 +91,13 @@ let rec find env e =
and lookup env e = function
| [] -> Term
| lbl :: others ->
- try match Mstate.lookup lbl.state e with
- | Sigs.Mterm -> raise Not_found
- | Sigs.Maddr lv -> Addr lv
- | Sigs.Mlval (lv, KValue) -> Lval(lv,flag lbl)
- | Sigs.Mlval (lv, KInit) -> Init(lv,flag lbl)
- | Sigs.Mchunk (m, _) -> Chunk(m,flag lbl)
- with Not_found -> lookup env e others
+ try match Mstate.lookup lbl.state e with
+ | Sigs.Mterm -> raise Not_found
+ | Sigs.Maddr lv -> Addr lv
+ | Sigs.Mlval (lv, KValue) -> Lval(lv,flag lbl)
+ | Sigs.Mlval (lv, KInit) -> Init(lv,flag lbl)
+ | Sigs.Mchunk (m, _) -> Chunk(m,flag lbl)
+ with Not_found -> lookup env e others
let is_ref x k = (k == F.e_zero) && Cil.isPointerType x.vtype
let is_atomic = function
@@ -109,11 +109,11 @@ let iter f lbl = Mstate.iter f lbl.state
let is_copy env lbl = function
| Sigs.Mstore( lv , value ) ->
- begin
- match find env value with
- | Lval(lv0,lbl0) -> lbl0 == lbl && Mstate.equal lv lv0
- | _ -> false
- end
+ begin
+ match find env value with
+ | Lval(lv0,lbl0) -> lbl0 == lbl && Mstate.equal lv lv0
+ | _ -> false
+ end
let updates env seq vars =
Bag.filter
@@ -132,8 +132,8 @@ let sequence_point a b =
if a != b then
match a,b with
| Some p , Some q ->
- if not (List.memq q p.next) then p.next <- q :: p.next ;
- if not (List.memq p q.prev) then q.prev <- p :: q.prev ;
+ if not (List.memq q p.next) then p.next <- q :: p.next ;
+ if not (List.memq p q.prev) then q.prev <- p :: q.prev ;
| None , _ | _ , None -> ()
let rec control env prev sequence next =
@@ -142,29 +142,29 @@ let rec control env prev sequence next =
and ctrl env prev steps next = match steps with
| [] -> next
| s :: others ->
- let open Conditions in
- match s.condition with
- | Type _ | Have _ | When _ | Core _ | Init _ ->
- (* Sequence of Labels on Hyp *)
- ctrl env prev others next
- | Branch(_,cthen,celse) ->
- let next = ctrl env None others next in
- control env prev cthen next ;
- control env prev celse next ;
- None
- | Either cases ->
- let next = ctrl env None others next in
- List.iter (fun s -> control env prev s next) cases ;
- None
- | State _ ->
- try
- let here = Some (at env ~id:s.id) in
- sequence_point prev here ;
- let next = ctrl env here others next in
- sequence_point here next ;
- here
- with Not_found ->
- ctrl env prev others next
+ let open Conditions in
+ match s.condition with
+ | Type _ | Have _ | When _ | Core _ | Init _ ->
+ (* Sequence of Labels on Hyp *)
+ ctrl env prev others next
+ | Branch(_,cthen,celse) ->
+ let next = ctrl env None others next in
+ control env prev cthen next ;
+ control env prev celse next ;
+ None
+ | Either cases ->
+ let next = ctrl env None others next in
+ List.iter (fun s -> control env prev s next) cases ;
+ None
+ | State _ ->
+ try
+ let here = Some (at env ~id:s.id) in
+ sequence_point prev here ;
+ let next = ctrl env here others next in
+ sequence_point here next ;
+ here
+ with Not_found ->
+ ctrl env prev others next
(* -------------------------------------------------------------------------- *)
(* --- Priority Queue --- *)
@@ -185,8 +185,8 @@ let register seq =
let open Conditions in
match s with
| { id ; stmt ; descr ; condition = State m } ->
- let label = label env ~id ?stmt ?descr m in
- let r = pool descr in r := label :: !r
+ let label = label env ~id ?stmt ?descr m in
+ let r = pool descr in r := label :: !r
| { condition = Type _ | Have _ | When _ | Core _ | Init _ } -> ()
| { condition = Branch(_,cthen,celse) } -> push cthen ; push celse
| { condition = Either cases } -> List.iter push cases
@@ -224,19 +224,19 @@ class virtual engine =
method pp_lval fmt = function
| Mvar x , [] ->
- Format.pp_print_string fmt x.vname
+ Format.pp_print_string fmt x.vname
| Mvar x , [Mindex k] when is_ref x k ->
- Format.fprintf fmt "*%s" x.vname
+ Format.fprintf fmt "*%s" x.vname
| Mvar x , ofs ->
- Format.fprintf fmt "@[<hov 2>%s%a@]" x.vname self#pp_offset ofs
+ Format.fprintf fmt "@[<hov 2>%s%a@]" x.vname self#pp_offset ofs
| host , [] ->
- Format.fprintf fmt "*%a" self#pp_host host
+ Format.fprintf fmt "*%a" self#pp_host host
| host , Mfield fd :: ofs ->
- Format.fprintf fmt "@[<hov 2>%a@,->%s%a@]"
- self#pp_host host fd.fname self#pp_offset ofs
+ Format.fprintf fmt "@[<hov 2>%a@,->%s%a@]"
+ self#pp_host host fd.fname self#pp_offset ofs
| host , ((Mindex _ :: _) as ofs) ->
- Format.fprintf fmt "@[<hov 2>%a@,%a@]"
- self#pp_host host self#pp_offset ofs
+ Format.fprintf fmt "@[<hov 2>%a@,%a@]"
+ self#pp_host host self#pp_offset ofs
method pp_init fmt lv =
Format.fprintf fmt "initialized(%a)" self#pp_lval lv
@@ -245,7 +245,7 @@ class virtual engine =
| Mvar x , [] -> Format.fprintf fmt "&%s" x.vname
| Mmem p , [] -> self#pp_atom fmt p
| Mmem p , [Mindex k] ->
- Format.fprintf fmt "%a + %a" self#pp_atom p self#pp_atom k
+ Format.fprintf fmt "%a + %a" self#pp_atom p self#pp_atom k
| lv -> Format.fprintf fmt "&(%a)" self#pp_lval lv
method pp_label fmt lbl =
diff --git a/src/plugins/wp/Pcond.ml b/src/plugins/wp/Pcond.ml
index eab22c58d4b6952d1b672ac18c5dc8ccd171c100..3250b73d347f30dfb4c74cb9e1842b9de321c4cb 100644
--- a/src/plugins/wp/Pcond.ml
+++ b/src/plugins/wp/Pcond.ml
@@ -38,13 +38,13 @@ let rec alloc_hyp pool f seq =
if not (Vars.subset step.vars (Plang.alloc_domain pool)) then
match step.condition with
| State _ ->
- Plang.alloc_xs pool f step.vars
+ Plang.alloc_xs pool f step.vars
| Have p | When p | Type p | Init p | Core p ->
- Plang.alloc_p pool f p
+ Plang.alloc_p pool f p
| Branch(p,sa,sb) ->
- Plang.alloc_p pool f p ;
- alloc_hyp pool f sa ;
- alloc_hyp pool f sb ;
+ Plang.alloc_p pool f p ;
+ alloc_hyp pool f sa ;
+ alloc_hyp pool f sb ;
| Either cases -> List.iter (alloc_hyp pool f) cases
) seq
@@ -92,20 +92,20 @@ class state =
begin fun ?lbl pp fmt w ->
match context , lbl with
| NoWhere , None ->
- context <- InAddr ;
- Format.fprintf fmt "« %a »" pp w ;
- context <- NoWhere ;
+ context <- InAddr ;
+ Format.fprintf fmt "« %a »" pp w ;
+ context <- NoWhere ;
| NoWhere , Some l ->
- context <- AtLabel l ;
- Format.fprintf fmt "« %a »%a" pp w self#pp_at l ;
- context <- NoWhere ;
+ context <- AtLabel l ;
+ Format.fprintf fmt "« %a »%a" pp w self#pp_at l ;
+ context <- NoWhere ;
| InAddr , None -> pp fmt w
| AtLabel _ , None -> pp fmt w
| AtLabel l0 , Some l when l == l0 -> pp fmt w
| (InAddr | AtLabel _) as here , Some l ->
- context <- AtLabel l ;
- Format.fprintf fmt "( %a )%a" pp w self#pp_at l ;
- context <- here ;
+ context <- AtLabel l ;
+ Format.fprintf fmt "( %a )%a" pp w self#pp_at l ;
+ context <- here ;
end
method private atflow : 'a. ?lbl:Pcfg.label ->
@@ -113,16 +113,16 @@ class state =
begin fun ?lbl pp fmt w ->
match context , lbl with
| NoWhere , None ->
- context <- InAddr ;
- pp fmt w ;
- context <- NoWhere ;
+ context <- InAddr ;
+ pp fmt w ;
+ context <- NoWhere ;
| InAddr , None -> pp fmt w
| AtLabel _ , None -> pp fmt w
| AtLabel l0 , Some l when l == l0 -> pp fmt w
| (InAddr | AtLabel _ | NoWhere) as here , Some l ->
- context <- AtLabel l ;
- Format.fprintf fmt "%a%a" pp w self#pp_at l ;
- context <- here ;
+ context <- AtLabel l ;
+ Format.fprintf fmt "%a%a" pp w self#pp_at l ;
+ context <- here ;
end
method pp_at fmt lbl = Format.fprintf fmt "@@%a" self#pp_label lbl
@@ -137,19 +137,19 @@ class state =
match Pcfg.find env e with
| Pcfg.Term -> super#pp_repr fmt e
| Pcfg.Addr lv ->
- if self#is_atomic_lv lv
- then self#atflow self#pp_addr fmt lv
- else self#at self#pp_addr fmt lv
+ if self#is_atomic_lv lv
+ then self#atflow self#pp_addr fmt lv
+ else self#at self#pp_addr fmt lv
| Pcfg.Lval(lv,lbl) ->
- if self#is_atomic_lv lv
- then self#atflow ~lbl self#pp_lval fmt lv
- else self#at ~lbl self#pp_lval fmt lv
+ if self#is_atomic_lv lv
+ then self#atflow ~lbl self#pp_lval fmt lv
+ else self#at ~lbl self#pp_lval fmt lv
| Pcfg.Init(lv,lbl) ->
- if self#is_atomic_lv lv
- then self#atflow ~lbl self#pp_init fmt lv
- else self#at ~lbl self#pp_init fmt lv
+ if self#is_atomic_lv lv
+ then self#atflow ~lbl self#pp_init fmt lv
+ else self#at ~lbl self#pp_init fmt lv
| Pcfg.Chunk(m,lbl) ->
- self#atflow ~lbl self#pp_chunk fmt m
+ self#atflow ~lbl self#pp_chunk fmt m
end
method pp_value fmt e = force <- true ; super#pp_sort fmt e
@@ -232,37 +232,37 @@ class engine (lang : #Plang.engine) =
| Have p -> self#pp_intro ~step ~clause:"Have:" fmt p
| When p -> self#pp_intro ~step ~clause:"When:" fmt p
| Branch(p,sa,sb) ->
- begin
- self#pp_intro ~step ~clause:"If" ~dot:"" fmt p ;
- if not (Conditions.is_true sa)
- then self#sequence ~clause:"Then" fmt sa ;
- if not (Conditions.is_true sb)
- then self#sequence ~clause:"Else" fmt sb ;
- end
+ begin
+ self#pp_intro ~step ~clause:"If" ~dot:"" fmt p ;
+ if not (Conditions.is_true sa)
+ then self#sequence ~clause:"Then" fmt sa ;
+ if not (Conditions.is_true sb)
+ then self#sequence ~clause:"Else" fmt sb ;
+ end
| Either cases ->
- begin
- pp_open_block self#pp_clause fmt "Either" "{" ;
- List.iter
- (fun seq ->
- Format.fprintf fmt "@ @[<hv 2>%a" self#pp_clause "Case:" ;
- self#block fmt seq ;
- Format.fprintf fmt "@]" ;
- ) cases ;
- pp_close_block fmt "}" ;
- end
+ begin
+ pp_open_block self#pp_clause fmt "Either" "{" ;
+ List.iter
+ (fun seq ->
+ Format.fprintf fmt "@ @[<hv 2>%a" self#pp_clause "Case:" ;
+ self#block fmt seq ;
+ Format.fprintf fmt "@]" ;
+ ) cases ;
+ pp_close_block fmt "}" ;
+ end
method pp_step fmt step =
match step.condition with
| State _ ->
- self#pp_condition ~step fmt step.condition
+ self#pp_condition ~step fmt step.condition
| _ ->
- begin
- ( match step.descr with None -> () | Some s ->
- spaced self#pp_comment fmt s ) ;
- Warning.Set.iter (spaced self#pp_warning fmt) step.warn ;
- List.iter (spaced self#pp_property fmt) step.deps ;
- spaced (self#pp_condition ~step) fmt step.condition ;
- end
+ begin
+ ( match step.descr with None -> () | Some s ->
+ spaced self#pp_comment fmt s ) ;
+ Warning.Set.iter (spaced self#pp_warning fmt) step.warn ;
+ List.iter (spaced self#pp_property fmt) step.deps ;
+ spaced (self#pp_condition ~step) fmt step.condition ;
+ end
method private sequence ~clause fmt seq =
Format.pp_print_space fmt () ; self#pp_block ~clause fmt seq
@@ -339,52 +339,52 @@ class seqengine (lang : #state) =
method private label step = function
| State _ ->
- (try Some (lang#label_at ~id:step.id)
- with Not_found -> None)
+ (try Some (lang#label_at ~id:step.id)
+ with Not_found -> None)
| _ -> None
method private updates fmt = function
| None -> ()
| Some( lbl , upd ) ->
- if not (Bag.is_empty upd) then
- Bag.iter ((spaced (lang#pp_update lbl)) fmt) upd
+ if not (Bag.is_empty upd) then
+ Bag.iter ((spaced (lang#pp_update lbl)) fmt) upd
method! pp_condition ~step fmt cond =
match self#label step cond with
| None -> super#pp_condition ~step fmt cond
| Some lbl ->
- let before = match Pcfg.prev lbl with
- | [ pre ] when (Pcfg.branching pre) ->
- let seq = Sigs.{ pre ; post = lbl } in
- let upd = lang#updates seq in
- Some(pre,upd)
- | _ -> None in
- let after = match Pcfg.next lbl with
- | [ post ] ->
- let seq = Sigs.{ pre = lbl ; post } in
- let upd = lang#updates seq in
- Some(lbl,upd)
- | _ -> None in
- if Pcfg.visible lbl || not (is_nop before) || not (is_nop after)
- || Wp_parameters.debug_atleast 1
- then
- lang#with_mode Qed.Engine.Mterm
- (fun _mode ->
- begin
- Format.fprintf fmt "@ @[<hv 0>@[<hv 2>%a {" self#pp_stmt "Stmt" ;
- self#updates fmt before ;
- if Pcfg.visible lbl then
- Format.fprintf fmt "@ %a:" lang#pp_label lbl ;
- if Wp_parameters.debug_atleast 1 then
- begin
- if not (Pcfg.visible lbl) then
- Format.fprintf fmt "@ label %a:" lang#pp_label lbl ;
- List.iter
- (fun lbl -> Format.fprintf fmt "@ from %a;" lang#pp_label lbl)
- (Pcfg.prev lbl) ;
- List.iter
- (fun lbl -> Format.fprintf fmt "@ goto %a;" lang#pp_label lbl)
- (Pcfg.next lbl) ;
+ let before = match Pcfg.prev lbl with
+ | [ pre ] when (Pcfg.branching pre) ->
+ let seq = Sigs.{ pre ; post = lbl } in
+ let upd = lang#updates seq in
+ Some(pre,upd)
+ | _ -> None in
+ let after = match Pcfg.next lbl with
+ | [ post ] ->
+ let seq = Sigs.{ pre = lbl ; post } in
+ let upd = lang#updates seq in
+ Some(lbl,upd)
+ | _ -> None in
+ if Pcfg.visible lbl || not (is_nop before) || not (is_nop after)
+ || Wp_parameters.debug_atleast 1
+ then
+ lang#with_mode Qed.Engine.Mterm
+ (fun _mode ->
+ begin
+ Format.fprintf fmt "@ @[<hv 0>@[<hv 2>%a {" self#pp_stmt "Stmt" ;
+ self#updates fmt before ;
+ if Pcfg.visible lbl then
+ Format.fprintf fmt "@ %a:" lang#pp_label lbl ;
+ if Wp_parameters.debug_atleast 1 then
+ begin
+ if not (Pcfg.visible lbl) then
+ Format.fprintf fmt "@ label %a:" lang#pp_label lbl ;
+ List.iter
+ (fun lbl -> Format.fprintf fmt "@ from %a;" lang#pp_label lbl)
+ (Pcfg.prev lbl) ;
+ List.iter
+ (fun lbl -> Format.fprintf fmt "@ goto %a;" lang#pp_label lbl)
+ (Pcfg.next lbl) ;
(*
Pcfg.iter
(fun _m v ->
@@ -393,10 +393,10 @@ class seqengine (lang : #state) =
lang#pp_term v lang#pp_value v
) lbl ;
*)
- end ;
- self#updates fmt after ;
- Format.fprintf fmt " @]@ }@]" ;
- end)
+ end ;
+ self#updates fmt after ;
+ Format.fprintf fmt " @]@ }@]" ;
+ end)
val mutable active = true
method set_state s = active <- s
diff --git a/src/plugins/wp/Plang.ml b/src/plugins/wp/Plang.ml
index d7db964ede9e406c71deaafb7a2f7d4a7c6a63be..65e25283c18b4203c71e29fdda2db253662cf7df 100644
--- a/src/plugins/wp/Plang.ml
+++ b/src/plugins/wp/Plang.ml
@@ -131,19 +131,19 @@ class engine =
| Q.MINF -> Format.pp_print_string fmt "(-1/.0)"
| Q.UNDEF -> Format.pp_print_string fmt "(.0/.0)"
| Q.NZERO ->
- match rformat with
- | `Ratio ->
- let { Q.num = num ; Q.den = den } = q in
- if Z.equal den Z.one then
- Format.fprintf fmt "%s.0" (Z.to_string num)
- else
- Format.fprintf fmt "(%s.0/%s)"
- (Z.to_string num)
- (Z.to_string den)
- | `Float ->
- Format.fprintf fmt "%sf" (Cfloat.float_lit Ctypes.Float32 q)
- | `Double ->
- Format.fprintf fmt "%sd" (Cfloat.float_lit Ctypes.Float64 q)
+ match rformat with
+ | `Ratio ->
+ let { Q.num = num ; Q.den = den } = q in
+ if Z.equal den Z.one then
+ Format.fprintf fmt "%s.0" (Z.to_string num)
+ else
+ Format.fprintf fmt "(%s.0/%s)"
+ (Z.to_string num)
+ (Z.to_string den)
+ | `Float ->
+ Format.fprintf fmt "%sf" (Cfloat.float_lit Ctypes.Float32 q)
+ | `Double ->
+ Format.fprintf fmt "%sd" (Cfloat.float_lit Ctypes.Float64 q)
(* --- Atomicity --- *)
@@ -216,15 +216,15 @@ class engine =
(fun i (f,v) ->
( match i , base with
| (Isingle | Ifirst) , Some r ->
- fprintf fmt "@ %a with" self#pp_flow r
+ fprintf fmt "@ %a with" self#pp_flow r
| _ -> () ) ;
( match i with
| Ifirst | Imiddle ->
- fprintf fmt "@ @[<hov 2>%s = %a ;@]"
- (self#field f) self#pp_flow v
+ fprintf fmt "@ @[<hov 2>%s = %a ;@]"
+ (self#field f) self#pp_flow v
| Isingle | Ilast ->
- fprintf fmt "@ @[<hov 2>%s = %a@]"
- (self#field f) self#pp_flow v )
+ fprintf fmt "@ @[<hov 2>%s = %a@]"
+ (self#field f) self#pp_flow v )
) fvs ;
fprintf fmt "@ }@]" ;
end
@@ -252,16 +252,16 @@ class engine =
method pp_forall tau fmt = function
| [] -> ()
| x::xs ->
- fprintf fmt "@[<hov 2>forall %a" self#pp_var x ;
- List.iter (fun x -> fprintf fmt ",@,%a" self#pp_var x) xs ;
- fprintf fmt "@ : %a.@]" self#pp_tau tau ;
+ fprintf fmt "@[<hov 2>forall %a" self#pp_var x ;
+ List.iter (fun x -> fprintf fmt ",@,%a" self#pp_var x) xs ;
+ fprintf fmt "@ : %a.@]" self#pp_tau tau ;
method pp_exists tau fmt = function
| [] -> ()
| x::xs ->
- fprintf fmt "@[<hov 2>exists %a" self#pp_var x ;
- List.iter (fun x -> fprintf fmt ",@,%a" self#pp_var x) xs ;
- fprintf fmt "@ : %a.@]" self#pp_tau tau ;
+ fprintf fmt "@[<hov 2>exists %a" self#pp_var x ;
+ List.iter (fun x -> fprintf fmt ",@,%a" self#pp_var x) xs ;
+ fprintf fmt "@ : %a.@]" self#pp_tau tau ;
method pp_let fmt _ x e =
fprintf fmt "@[<hov 4>let %s = %a in@]@ " x self#pp_flow e
diff --git a/src/plugins/wp/ProofEngine.ml b/src/plugins/wp/ProofEngine.ml
index ff5c98207f25eded765ef2ff506a99a991af50cd..d2583eba7b57637776fa030f5357345bea08b8df 100644
--- a/src/plugins/wp/ProofEngine.ml
+++ b/src/plugins/wp/ProofEngine.ml
@@ -81,9 +81,9 @@ let pool tree =
match tree.pool with
| Some pool -> pool
| None ->
- let _,sequent = Wpo.compute tree.main in
- let pool = Lang.new_pool ~vars:(Conditions.vars_seq sequent) () in
- tree.pool <- Some pool ; pool
+ let _,sequent = Wpo.compute tree.main in
+ let pool = Lang.new_pool ~vars:(Conditions.vars_seq sequent) () in
+ tree.pool <- Some pool ; pool
(* -------------------------------------------------------------------------- *)
(* --- Constructors --- *)
@@ -138,8 +138,8 @@ let iteri f tree =
match tree.root with
| None -> ()
| Some r ->
- let k = ref 0 in
- walk (fun node -> f !k node ; incr k) r
+ let k = ref 0 in
+ walk (fun node -> f !k node ; incr k) r
(* -------------------------------------------------------------------------- *)
(* --- Consolidating --- *)
@@ -168,13 +168,13 @@ let validate ?(incomplete=false) tree =
match tree.root with
| None -> ()
| Some root ->
- if not (Wpo.is_proved tree.main) then
- if incomplete then
- let result = consolidate root in
- Wpo.set_result tree.main VCS.Tactical result
- else
- if not (has_pending root) then
- Wpo.set_result tree.main VCS.Tactical VCS.valid
+ if not (Wpo.is_proved tree.main) then
+ if incomplete then
+ let result = consolidate root in
+ Wpo.set_result tree.main VCS.Tactical result
+ else
+ if not (has_pending root) then
+ Wpo.set_result tree.main VCS.Tactical VCS.valid
(* -------------------------------------------------------------------------- *)
(* --- Accessors --- *)
@@ -217,16 +217,16 @@ type status = [
let status t : status =
match t.root with
| None ->
- if Wpo.is_proved t.main
- then if Wpo.is_smoke_test t.main then `Invalid else `Proved
- else if Wpo.is_smoke_test t.main then `Passed else `Unproved
+ if Wpo.is_proved t.main
+ then if Wpo.is_smoke_test t.main then `Invalid else `Proved
+ else if Wpo.is_smoke_test t.main then `Passed else `Unproved
| Some root ->
- match root.script with
- | Opened | Script _ ->
- if Wpo.is_smoke_test t.main then `Passed else `Unproved
- | Tactic _ ->
- let n = pending root in
- if Wpo.is_smoke_test t.main then `StillResist n else `Pending n
+ match root.script with
+ | Opened | Script _ ->
+ if Wpo.is_smoke_test t.main then `Passed else `Unproved
+ | Tactic _ ->
+ let n = pending root in
+ if Wpo.is_smoke_test t.main then `StillResist n else `Pending n
(* -------------------------------------------------------------------------- *)
(* --- Navigation --- *)
@@ -237,19 +237,19 @@ type current = [ `Main | `Internal of node | `Leaf of int * node ]
let current t : current =
match t.head with
| Some h ->
- let p = ref (`Internal h) in
- iteri (fun i n -> if n == h then p := `Leaf(i,n)) t ; !p
+ let p = ref (`Internal h) in
+ iteri (fun i n -> if n == h then p := `Leaf(i,n)) t ; !p
| None -> `Main
type position = [ `Main | `Node of node | `Leaf of int ]
let goto t = function
| `Main ->
- t.head <- t.root
+ t.head <- t.root
| `Node n ->
- if n.tree == t.main then t.head <- Some n
+ if n.tree == t.main then t.head <- Some n
| `Leaf k ->
- t.head <- t.root ;
- iteri (fun i n -> if i = k then t.head <- Some n) t
+ t.head <- t.root ;
+ iteri (fun i n -> if i = k then t.head <- Some n) t
let fetch t node =
try
@@ -261,26 +261,26 @@ let rec forward t =
match t.head with
| None -> t.head <- t.root
| Some hd ->
- if not (fetch t hd) then
- begin
- t.head <- hd.parent ;
- forward t ;
- end
+ if not (fetch t hd) then
+ begin
+ t.head <- hd.parent ;
+ forward t ;
+ end
let cancel t =
match t.head with
| None -> ()
| Some node ->
- begin
- Wpo.clear_results node.goal ;
- match node.script with
- | Opened ->
- t.head <- node.parent ;
- if t.head = None then t.root <- None ;
- | Tactic _ | Script _ ->
- (*TODO: save the current script *)
- node.script <- Opened ;
- end
+ begin
+ Wpo.clear_results node.goal ;
+ match node.script with
+ | Opened ->
+ t.head <- node.parent ;
+ if t.head = None then t.root <- None ;
+ | Tactic _ | Script _ ->
+ (*TODO: save the current script *)
+ node.script <- Opened ;
+ end
(* -------------------------------------------------------------------------- *)
(* --- Sub-Goal --- *)
@@ -377,12 +377,12 @@ let anchor tree ?node () =
match node with
| Some n -> n
| None ->
- match tree.head with
+ match tree.head with
+ | Some n -> n
+ | None ->
+ match tree.root with
| Some n -> n
- | None ->
- match tree.root with
- | Some n -> n
- | None -> mk_root tree
+ | None -> mk_root tree
let commit fork =
List.iter (fun (_,wp) -> ignore (Wpo.resolve wp)) fork.Fork.goals ;
@@ -406,7 +406,7 @@ let rec script_node (node : node) =
match node.script with
| Script s -> List.filter ProofScript.is_tactic s
| Tactic( tactic , children ) ->
- [ ProofScript.a_tactic tactic (List.map subscript_node children) ]
+ [ ProofScript.a_tactic tactic (List.map subscript_node children) ]
| Opened -> []
in
provers @ scripts
@@ -421,11 +421,11 @@ let script tree =
let bind node script =
match node.script with
| Tactic _ ->
- (*TODO: saveback the thrown script *)
- ()
+ (*TODO: saveback the thrown script *)
+ ()
| Opened | Script _ ->
- (*TODO: saveback the previous script *)
- node.script <- Script script
+ (*TODO: saveback the previous script *)
+ node.script <- Script script
let bound node =
match node.script with
diff --git a/src/plugins/wp/ProofScript.ml b/src/plugins/wp/ProofScript.ml
index 531175ba1eec83466e6fb7d5df905a926b41a4af..aa7312249b16c2a74a9c0f5fe20c7c2a789a48cb 100644
--- a/src/plugins/wp/ProofScript.ml
+++ b/src/plugins/wp/ProofScript.ml
@@ -31,18 +31,18 @@ let around f k n =
match f k with
| Some s -> s
| None ->
- let rec scan f k i n =
- match f (k-i) with
+ let rec scan f k i n =
+ match f (k-i) with
+ | Some s -> s
+ | None ->
+ match f (k+i) with
| Some s -> s
| None ->
- match f (k+i) with
- | Some s -> s
- | None ->
- let j = succ i in
- if k+j < n || j <= k then
- scan f k j n
- else raise Not_found
- in scan f k 1 n
+ let j = succ i in
+ if k+j < n || j <= k then
+ scan f k j n
+ else raise Not_found
+ in scan f k 1 n
let s_kind s = match s.condition with
| Have _ | When _ | Core _ -> "have"
@@ -122,23 +122,23 @@ let rec json_of_selection = function
| Compose code -> json_of_compose code
| Clause (Goal p) ->
- `Assoc[ j_goal ; j_pred p ; j_ppattern p ]
+ `Assoc[ j_goal ; j_pred p ; j_ppattern p ]
| Clause (Step s) ->
- let p = Conditions.head s in
- `Assoc[ j_step ; j_at s ; j_kind s ; j_pred p ; j_ppattern p ]
+ let p = Conditions.head s in
+ `Assoc[ j_step ; j_at s ; j_kind s ; j_pred p ; j_ppattern p ]
| Inside(Goal p,e) ->
- let n,m = occur p e in
- `Assoc [ j_ingoal ; j_occur n ; j_term e ; j_pattern m ]
+ let n,m = occur p e in
+ `Assoc [ j_ingoal ; j_occur n ; j_term e ; j_pattern m ]
| Inside(Step s,e) ->
- let n,m = occur (Conditions.head s) e in
- `Assoc [ j_instep ; j_at s ; j_kind s ; j_occur n ;
- j_term e ; j_pattern m ]
+ let n,m = occur (Conditions.head s) e in
+ `Assoc [ j_instep ; j_at s ; j_kind s ; j_occur n ;
+ j_term e ; j_pattern m ]
| Multi es ->
- `Assoc (j_multi :: j_args es)
+ `Assoc (j_multi :: j_args es)
and j_args = function
| [] -> []
@@ -171,26 +171,26 @@ let rec selection_of_json ((hs,g) as s : sequent) js =
let key = js >? "select" |> Json.string in
match key with
| "clause-goal" ->
- check_pattern ~pattern:(j_pattern js) g ;
- Clause (Goal g)
+ check_pattern ~pattern:(j_pattern js) g ;
+ Clause (Goal g)
| "clause-step" ->
- let pattern = j_pattern js in
- let s = locate_step ~at:(j_at js) ~kind:(j_kind js) ~pattern hs in
- Clause (Step s)
+ let pattern = j_pattern js in
+ let s = locate_step ~at:(j_at js) ~kind:(j_kind js) ~pattern hs in
+ Clause (Step s)
| "inside-goal" ->
- let occur = j_occur js , j_pattern js in
- Inside(Goal g , lookup_occur ~occur g )
+ let occur = j_occur js , j_pattern js in
+ Inside(Goal g , lookup_occur ~occur g )
| "inside-step" ->
- let occur = j_occur js , j_pattern js in
- let s,e = locate_inside ~at:(j_at js) ~kind:(j_kind js) ~occur hs in
- Inside(Step s,e)
+ let occur = j_occur js , j_pattern js in
+ let s,e = locate_inside ~at:(j_at js) ~kind:(j_kind js) ~occur hs in
+ Inside(Step s,e)
| "compose" ->
- let id = j_id js in
- let args = j_args js in
- Tactical.compose id (List.map (selection_of_json s) args)
+ let id = j_id js in
+ let args = j_args js in
+ Tactical.compose id (List.map (selection_of_json s) args)
| "multi" ->
- let args = j_args js in
- Tactical.multi @@ List.map (selection_of_json s) args
+ let args = j_args js in
+ Tactical.multi @@ List.map (selection_of_json s) args
| "kint" -> Tactical.cint (j_val js)
| "range" -> Tactical.range (j_min js) (j_max js)
| _ -> raise Not_found
@@ -202,11 +202,11 @@ let selection_target js = js >? "target" |> Json.string
let json_of_named = function
| None -> `Null
| Some a ->
- `Assoc Tactical.[
- "id" , `String a.vid ;
- "title" , `String a.title ;
- "descr" , `String a.descr ;
- ]
+ `Assoc Tactical.[
+ "id" , `String a.vid ;
+ "title" , `String a.title ;
+ "descr" , `String a.descr ;
+ ]
let named_of_json find js =
try
@@ -226,45 +226,45 @@ let json_of_param (tac : tactical) = function
| Spinner(fd,_) -> ident fd , Json.of_int (tac#get_field fd)
| Composer(fd,_) -> ident fd , json_of_selection (tac#get_field fd)
| Selector(fd,options,equal) ->
- ident fd , `String
- begin
- try
- let a = tac#get_field fd in
- let v = List.find (fun v -> equal v.value a) options in
- v.vid
- with _ -> "default"
- end
+ ident fd , `String
+ begin
+ try
+ let a = tac#get_field fd in
+ let v = List.find (fun v -> equal v.value a) options in
+ v.vid
+ with _ -> "default"
+ end
| Search(fd,_,_) ->
- ident fd , json_of_named (tac#get_field fd)
+ ident fd , json_of_named (tac#get_field fd)
let param_of_json (tac : tactical) seq js = function
| Checkbox fd ->
- tac#set_field fd
- (try Json.bool (Json.field (ident fd) js)
- with _ -> default fd)
+ tac#set_field fd
+ (try Json.bool (Json.field (ident fd) js)
+ with _ -> default fd)
| Spinner(fd,_) ->
- tac#set_field fd
- (try Json.int (Json.field (ident fd) js)
- with _ -> default fd)
+ tac#set_field fd
+ (try Json.int (Json.field (ident fd) js)
+ with _ -> default fd)
| Composer(fd,_) ->
- let sel = (try selection_of_json seq (Json.field (ident fd) js)
- with _ -> default fd) in
- tac#set_field fd sel
+ let sel = (try selection_of_json seq (Json.field (ident fd) js)
+ with _ -> default fd) in
+ tac#set_field fd sel
| Selector(fd,options,_) ->
- tac#set_field fd
- begin
- try
- let jid = Json.string (Json.field (ident fd) js) in
- let v = List.find (fun v -> v.vid = jid) options in
- v.value
- with _ -> default fd
- end
+ tac#set_field fd
+ begin
+ try
+ let jid = Json.string (Json.field (ident fd) js) in
+ let v = List.find (fun v -> v.vid = jid) options in
+ v.value
+ with _ -> default fd
+ end
| Search(fd,_,find) ->
- tac#set_field fd
- begin
- try named_of_json find (Json.field (ident fd) js)
- with _ -> None
- end
+ tac#set_field fd
+ begin
+ try named_of_json find (Json.field (ident fd) js)
+ with _ -> None
+ end
let json_of_parameters (tac : tactical) =
`Assoc (List.map (json_of_param tac) tac#params)
@@ -302,9 +302,9 @@ let json_of_tactic t js =
let children_of_json = function
| `List js ->
- Wp_parameters.warning ~current:false ~once:true
- "Deprecated script(s) found ; consider using prover 'tip'" ;
- List.map (fun j -> "",j) js
+ Wp_parameters.warning ~current:false ~once:true
+ "Deprecated script(s) found ; consider using prover 'tip'" ;
+ List.map (fun j -> "",j) js
| `Assoc fs -> fs
| _ -> []
@@ -380,8 +380,8 @@ let rec pending_any = function
| [] -> 1
| [a] -> pending a
| a::s ->
- let n = pending a in
- if n = 0 then 0 else min n (pending_any s)
+ let n = pending a in
+ if n = 0 then 0 else min n (pending_any s)
let rec subgoals n = function
| [] -> n
@@ -407,10 +407,10 @@ and alternative js =
match prover_of_json js with
| Some prover -> Prover(prover,result_of_json js)
| None ->
- match tactic_of_json js with
- | Some(tactic, children) ->
- a_tactic tactic (List.map subscript children)
- | None -> Error("Invalid Tactic",js)
+ match tactic_of_json js with
+ | Some(tactic, children) ->
+ a_tactic tactic (List.map subscript children)
+ | None -> Error("Invalid Tactic",js)
let rec encode script = `List (alternatives script)
diff --git a/src/plugins/wp/ProofSession.ml b/src/plugins/wp/ProofSession.ml
index c1c8af78ef229da15cb6dc6b87d70545410cfc0c..4f05c42c5767c6fc25c0c81ab8b81f659a0e27b8 100644
--- a/src/plugins/wp/ProofSession.ml
+++ b/src/plugins/wp/ProofSession.ml
@@ -74,24 +74,24 @@ let load wpo =
match get wpo with
| NoScript -> `Null
| Script f | Deprecated f ->
- if Sys.file_exists f then Json.load_file f else `Null
+ if Sys.file_exists f then Json.load_file f else `Null
let remove wpo =
match get wpo with
| NoScript -> ()
| Script f ->
- begin
- Extlib.safe_remove f ;
- Hashtbl.replace files f NoScript ;
- end
+ begin
+ Extlib.safe_remove f ;
+ Hashtbl.replace files f NoScript ;
+ end
| Deprecated f0 ->
- begin
- Wp_parameters.feedback
- "Removed deprecated script for '%s'" wpo.po_sid ;
- Extlib.safe_remove f0 ;
- let f = filename ~force:false wpo in
- Hashtbl.replace files f NoScript ;
- end
+ begin
+ Wp_parameters.feedback
+ "Removed deprecated script for '%s'" wpo.po_sid ;
+ Extlib.safe_remove f0 ;
+ let f = filename ~force:false wpo in
+ Hashtbl.replace files f NoScript ;
+ end
let save wpo js =
let empty =
@@ -101,19 +101,19 @@ let save wpo js =
if empty then remove wpo else
match get wpo with
| Script f ->
- Json.save_file f js
+ Json.save_file f js
| NoScript ->
- begin
- let f = filename ~force:true wpo in
- Json.save_file f js ;
- Hashtbl.replace files f (Script f) ;
- end
+ begin
+ let f = filename ~force:true wpo in
+ Json.save_file f js ;
+ Hashtbl.replace files f (Script f) ;
+ end
| Deprecated f0 ->
- begin
- Wp_parameters.feedback
- "Upgraded script for '%s'" wpo.po_sid ;
- Extlib.safe_remove f0 ;
- let f = filename ~force:true wpo in
- Json.save_file f js ;
- Hashtbl.replace files f (Script f) ;
- end
+ begin
+ Wp_parameters.feedback
+ "Upgraded script for '%s'" wpo.po_sid ;
+ Extlib.safe_remove f0 ;
+ let f = filename ~force:true wpo in
+ Json.save_file f js ;
+ Hashtbl.replace files f (Script f) ;
+ end
diff --git a/src/plugins/wp/ProverScript.ml b/src/plugins/wp/ProverScript.ml
index 9b4df821321a90605ab696180861dc73c5037a7d..1eb88b257028474091fdab21f39c5ece7a9800d3 100644
--- a/src/plugins/wp/ProverScript.ml
+++ b/src/plugins/wp/ProverScript.ml
@@ -65,19 +65,19 @@ let jconfigure (console : #Tactical.feedback) jtactic goal =
match ProofScript.configure jtactic sequent with
| None -> None
| Some(tactical,selection) ->
- console#set_title "%s" tactical#title ;
- let verdict =
- try Lang.local ~pool:console#pool (tactical#select console) selection
- with Not_found | Exit -> Not_applicable
- in
- begin
- match verdict with
- | Applicable process when not console#has_error ->
- let title = tactical#title in
- let script = ProofScript.jtactic ~title tactical selection in
- Some (script , process)
- | _ -> None
- end
+ console#set_title "%s" tactical#title ;
+ let verdict =
+ try Lang.local ~pool:console#pool (tactical#select console) selection
+ with Not_found | Exit -> Not_applicable
+ in
+ begin
+ match verdict with
+ | Applicable process when not console#has_error ->
+ let title = tactical#title in
+ let script = ProofScript.jtactic ~title tactical selection in
+ Some (script , process)
+ | _ -> None
+ end
let jfork tree ?node jtactic =
let console = new ProofScript.console
@@ -90,13 +90,13 @@ let jfork tree ?node jtactic =
match WpContext.on_context ctxt (jconfigure console jtactic) goal with
| None -> None
| Some (script,process) ->
- Some (ProofEngine.fork tree ~anchor script process)
+ Some (ProofEngine.fork tree ~anchor script process)
with
| Exit | Not_found | Invalid_argument _ ->
- console#set_error "Can not configure tactic" ; None
+ console#set_error "Can not configure tactic" ; None
| e ->
- console#set_error "Exception <%s>" (Printexc.to_string e) ;
- raise e
+ console#set_error "Exception <%s>" (Printexc.to_string e) ;
+ raise e
(* -------------------------------------------------------------------------- *)
(* --- Running Alternatives --- *)
@@ -201,20 +201,20 @@ struct
match env.backtracking with
| None -> None
| Some point ->
- let n = backtracking env in
- let anchor = point.bk_node in
- if n < point.bk_pending then
- begin
- point.bk_best <- fst (ProofEngine.get_strategies anchor) ;
- point.bk_pending <- n ;
- end ;
- match ProverSearch.backtrack env.tree ~anchor ~loop:false () with
- | Some fork ->
- env.backtracking <- None ; Some (point.bk_depth,fork)
- | None -> (* end of backtrack *)
- env.backtracking <- None ;
- match ProverSearch.index env.tree ~anchor ~index:point.bk_best
- with None -> None | Some fork -> Some (point.bk_depth,fork)
+ let n = backtracking env in
+ let anchor = point.bk_node in
+ if n < point.bk_pending then
+ begin
+ point.bk_best <- fst (ProofEngine.get_strategies anchor) ;
+ point.bk_pending <- n ;
+ end ;
+ match ProverSearch.backtrack env.tree ~anchor ~loop:false () with
+ | Some fork ->
+ env.backtracking <- None ; Some (point.bk_depth,fork)
+ | None -> (* end of backtrack *)
+ env.backtracking <- None ;
+ match ProverSearch.index env.tree ~anchor ~index:point.bk_best
+ with None -> None | Some fork -> Some (point.bk_depth,fork)
let provers env = env.provers
@@ -241,33 +241,33 @@ let rec zip order nodes scripts =
match nodes , scripts with
| _ , [] | [] , _ -> (*TODO: saveback forgiven scripts *) ()
| node :: o_nodes , script :: o_scripts ->
- let cmp = order node script in
- if cmp < 0 then zip order o_nodes scripts else
- if cmp > 0 then zip order nodes o_scripts else
- (ProofEngine.bind (snd node) (snd script) ;
- zip order o_nodes o_scripts)
+ let cmp = order node script in
+ if cmp < 0 then zip order o_nodes scripts else
+ if cmp > 0 then zip order nodes o_scripts else
+ (ProofEngine.bind (snd node) (snd script) ;
+ zip order o_nodes o_scripts)
let reconcile nodes scripts =
match nodes , scripts with
| [] , [] -> ()
| [_,n] , [_,s] -> ProofEngine.bind n s
| _ ->
- if List.for_all (fun (k,_) -> k = "") scripts
- then zip fst_order nodes scripts
- else zip key_order
- (List.stable_sort key_order nodes)
- (List.stable_sort key_order scripts)
+ if List.for_all (fun (k,_) -> k = "") scripts
+ then zip fst_order nodes scripts
+ else zip key_order
+ (List.stable_sort key_order nodes)
+ (List.stable_sort key_order scripts)
let rec forall phi = function
| x::xs ->
- phi x >>= fun ok ->
- if ok then forall phi xs else Task.return false
+ phi x >>= fun ok ->
+ if ok then forall phi xs else Task.return false
| [] -> Task.return true
let rec exists phi = function
| x::xs ->
- phi x >>= fun ok ->
- if ok then Task.return true else exists phi xs
+ phi x >>= fun ok ->
+ if ok then Task.return true else exists phi xs
| [] -> Task.return false
let prove_node env node prv =
@@ -291,10 +291,10 @@ let rec auto env ?(depth=0) node : bool Task.task =
if ok then Task.return true else
match Env.backtrack env with
| Some (depth,fork) ->
- Env.progress env "Backtracking" ;
- autofork env ~depth fork
+ Env.progress env "Backtracking" ;
+ autofork env ~depth fork
| None ->
- Task.return false
+ Task.return false
end
and autosearch env ~depth node : bool Task.task =
@@ -322,12 +322,12 @@ let apply env node jtactic subscripts =
match jfork (Env.tree env) ?node jtactic with
| None -> failwith "Selector not found"
| Some fork ->
- let _,children = ProofEngine.commit fork in
- reconcile children subscripts ; (*TODO: saveback forgiven script ? *)
- let ok = List.for_all
- (fun (_,node) -> ProofEngine.proved node)
- children in
- if ok then [] else children
+ let _,children = ProofEngine.commit fork in
+ reconcile children subscripts ; (*TODO: saveback forgiven script ? *)
+ let ok = List.for_all
+ (fun (_,node) -> ProofEngine.proved node)
+ children in
+ if ok then [] else children
(* -------------------------------------------------------------------------- *)
(* --- Script Crawling --- *)
@@ -336,56 +336,56 @@ let apply env node jtactic subscripts =
let rec crawl env on_child node = function
| [] ->
- let node = ProofEngine.anchor (Env.tree env) ?node () in
- auto env node >>= fun ok ->
- if ok then Env.validate env else Env.stuck env ;
- Task.return ()
+ let node = ProofEngine.anchor (Env.tree env) ?node () in
+ auto env node >>= fun ok ->
+ if ok then Env.validate env else Env.stuck env ;
+ Task.return ()
| Error(msg,json) :: alternative ->
- Wp_parameters.warning "@[<hov 2>Script Error: on goal %a@\n%S: %a@]@."
- WpPropId.pretty (Env.goal env node).po_pid
- msg Json.pp json ;
- crawl env on_child node alternative
+ Wp_parameters.warning "@[<hov 2>Script Error: on goal %a@\n%S: %a@]@."
+ WpPropId.pretty (Env.goal env node).po_pid
+ msg Json.pp json ;
+ crawl env on_child node alternative
| Prover( prv , res ) :: alternative ->
- begin
- let task =
- if Env.play env prv res then
- let wpo = Env.goal env node in
- let config = VCS.configure res in
- Env.prove env wpo ~config prv
- else Task.return false in
- let continue ok =
- if ok
- then (Env.validate env ; Task.return ())
- else crawl env on_child node alternative
- in
- task >>= continue
- end
+ begin
+ let task =
+ if Env.play env prv res then
+ let wpo = Env.goal env node in
+ let config = VCS.configure res in
+ Env.prove env wpo ~config prv
+ else Task.return false in
+ let continue ok =
+ if ok
+ then (Env.validate env ; Task.return ())
+ else crawl env on_child node alternative
+ in
+ task >>= continue
+ end
| Tactic( _ , jtactic , subscripts ) :: alternative ->
- begin
- try
- let residual = apply env node jtactic subscripts in
- if residual = [] then
- Env.validate env
- else
- List.iter (fun (_,n) -> on_child n) residual ;
- Task.return ()
- with exn when Wp_parameters.protect exn ->
- Wp_parameters.warning
- "Script Error: on goal %a@\n\
- can not apply '%s'@\n\
- exception %S@\n\
- @[<hov 2>Params: %a@]@\n\
- @[<hov 2>Select: %a@]@."
- WpPropId.pretty (Env.goal env node).po_pid
- jtactic.tactic
- (Printexc.to_string exn)
- Json.pp jtactic.params
- Json.pp jtactic.select ;
- crawl env on_child node alternative
- end
+ begin
+ try
+ let residual = apply env node jtactic subscripts in
+ if residual = [] then
+ Env.validate env
+ else
+ List.iter (fun (_,n) -> on_child n) residual ;
+ Task.return ()
+ with exn when Wp_parameters.protect exn ->
+ Wp_parameters.warning
+ "Script Error: on goal %a@\n\
+ can not apply '%s'@\n\
+ exception %S@\n\
+ @[<hov 2>Params: %a@]@\n\
+ @[<hov 2>Select: %a@]@."
+ WpPropId.pretty (Env.goal env node).po_pid
+ jtactic.tactic
+ (Printexc.to_string exn)
+ Json.pp jtactic.params
+ Json.pp jtactic.select ;
+ crawl env on_child node alternative
+ end
(* -------------------------------------------------------------------------- *)
(* --- Main Process --- *)
diff --git a/src/plugins/wp/ProverSearch.ml b/src/plugins/wp/ProverSearch.ml
index a1fc5c156eff8d4ac5b5c0d763aed49821958f53..dea432e045a5b0e460543eedabee52b2fc4b58fa 100644
--- a/src/plugins/wp/ProverSearch.ml
+++ b/src/plugins/wp/ProverSearch.ml
@@ -34,9 +34,9 @@ let configure (console : #Tactical.feedback) strategy =
in
match Lang.local ~pool:console#pool verdict () with
| Applicable process when not console#has_error ->
- let title = tactical#title in
- let script = ProofScript.jtactic ~title tactical selection in
- Some (script , process)
+ let title = tactical#title in
+ let script = ProofScript.jtactic ~title tactical selection in
+ Some (script , process)
| _ -> None
let fork tree anchor strategy =
@@ -48,13 +48,13 @@ let fork tree anchor strategy =
match WpContext.on_context context (configure console) strategy with
| None -> None
| Some (script,process) ->
- Some (ProofEngine.fork tree ~anchor script process)
+ Some (ProofEngine.fork tree ~anchor script process)
with
| Exit | Not_found | Invalid_argument _ ->
- console#set_error "Can not configure strategy" ; None
+ console#set_error "Can not configure strategy" ; None
| e ->
- console#set_error "Exception <%s>" (Printexc.to_string e) ;
- raise e
+ console#set_error "Exception <%s>" (Printexc.to_string e) ;
+ raise e
let rec lookup tree anchor k hs =
let n = Array.length hs in
@@ -62,15 +62,15 @@ let rec lookup tree anchor k hs =
match fork tree anchor hs.(k) with
| Some fork -> Some fork,k,hs
| None ->
- if k = 0 then
- lookup tree anchor 0 (Array.sub hs 1 (n-1))
+ if k = 0 then
+ lookup tree anchor 0 (Array.sub hs 1 (n-1))
+ else
+ let slice = Array.sub hs 0 (n-1) in
+ if k < n-1 then
+ ( Array.blit hs (succ k) slice k (n-k-1) ;
+ lookup tree anchor k slice )
else
- let slice = Array.sub hs 0 (n-1) in
- if k < n-1 then
- ( Array.blit hs (succ k) slice k (n-k-1) ;
- lookup tree anchor k slice )
- else
- lookup tree anchor 0 hs
+ lookup tree anchor 0 hs
let index tree ~anchor ~index =
if index < 0 then None else
diff --git a/src/plugins/wp/ProverTask.ml b/src/plugins/wp/ProverTask.ml
index cb0989a0c924cd1133d9837c78ebbb812dd920e7..ec094b294e794b6b5bd68dbcf0040c2f47a8fd73 100644
--- a/src/plugins/wp/ProverTask.ml
+++ b/src/plugins/wp/ProverTask.ml
@@ -110,11 +110,11 @@ let validate_buffer buffer validers =
let dump_buffer buffer = function
| None -> ()
| Some log ->
- let n = Buffer.length buffer in
- if n > 0 then
- Command.write_file log (fun out -> Buffer.output_buffer out buffer)
- else if Wp_parameters.has_out () then
- Extlib.safe_remove log
+ let n = Buffer.length buffer in
+ if n > 0 then
+ Command.write_file log (fun out -> Buffer.output_buffer out buffer)
+ else if Wp_parameters.has_out () then
+ Extlib.safe_remove log
let echo_buffer buffer =
let n = Buffer.length buffer in
@@ -134,9 +134,9 @@ let location file line = {
let timeout ~smoke = function
| None ->
- if smoke
- then Wp_parameters.SmokeTimeout.get ()
- else Wp_parameters.Timeout.get ()
+ if smoke
+ then Wp_parameters.SmokeTimeout.get ()
+ else Wp_parameters.Timeout.get ()
| Some t -> t
let stepout = function
@@ -175,17 +175,17 @@ let is_opt a = String.length a > 0 && a.[0] = '-'
let rec pp_args fmt = function
| [] -> ()
| a::b::c::w when is_opt a && not (is_opt b) && not (is_opt c) ->
- Format.fprintf fmt "@ @[<hov 2>%s@ %S@ %S@]" a b c ;
- pp_args fmt w
+ Format.fprintf fmt "@ @[<hov 2>%s@ %S@ %S@]" a b c ;
+ pp_args fmt w
| a::b::w when is_opt a && not (is_opt b) ->
- Format.fprintf fmt "@ @[<hov 2>%s@ %S@]" a b ;
- pp_args fmt w
+ Format.fprintf fmt "@ @[<hov 2>%s@ %S@]" a b ;
+ pp_args fmt w
| a::w when is_opt a ->
- Format.fprintf fmt "@ %s" a ;
- pp_args fmt w
+ Format.fprintf fmt "@ %s" a ;
+ pp_args fmt w
| a::w->
- Format.fprintf fmt "@ %S" a ;
- pp_args fmt w
+ Format.fprintf fmt "@ %S" a ;
+ pp_args fmt w
class command name =
object
@@ -257,23 +257,23 @@ class command name =
begin match st with
| Task.Result 0 | Task.Canceled | Task.Timeout _ -> ()
| Task.Result 127 ->
- begin
- Wp_parameters.error "Command '%s' not found (exit status 127)@." cmd ;
- echo_buffer stdout ;
- echo_buffer stderr ;
- end
+ begin
+ Wp_parameters.error "Command '%s' not found (exit status 127)@." cmd ;
+ echo_buffer stdout ;
+ echo_buffer stderr ;
+ end
| Task.Result s ->
- begin
- Wp_parameters.error "Command '%s' exits with status [%d]@." cmd s ;
- echo_buffer stdout ;
- echo_buffer stderr ;
- end
+ begin
+ Wp_parameters.error "Command '%s' exits with status [%d]@." cmd s ;
+ echo_buffer stdout ;
+ echo_buffer stderr ;
+ end
| Task.Failed exn ->
- begin
- Wp_parameters.error "Command '%s' fails: %s@." cmd (Task.error exn) ;
- echo_buffer stdout ;
- echo_buffer stderr ;
- end
+ begin
+ Wp_parameters.error "Command '%s' fails: %s@." cmd (Task.error exn) ;
+ echo_buffer stdout ;
+ echo_buffer stderr ;
+ end
end ;
let t = !time in
List.iter (fun phi -> phi t) timers ;
@@ -294,15 +294,15 @@ let getprocs = function Some n -> n | None -> Wp_parameters.Procs.get ()
let server ?procs () =
match !server with
| Some s ->
- let np = getprocs procs in
- Task.set_procs s np ;
- Why3Provers.set_procs np ;
- s
+ let np = getprocs procs in
+ Task.set_procs s np ;
+ Why3Provers.set_procs np ;
+ s
| None ->
- let np = getprocs procs in
- let s = Task.server ~procs:np () in
- Why3Provers.set_procs np ;
- server := Some s ; s
+ let np = getprocs procs in
+ let s = Task.server ~procs:np () in
+ Why3Provers.set_procs np ;
+ server := Some s ; s
(* -------------------------------------------------------------------------- *)
(* --- Task Composition --- *)
diff --git a/src/plugins/wp/ProverWhy3.ml b/src/plugins/wp/ProverWhy3.ml
index e89b87890f82921162f173f4fec10d8bfd3b42c8..ab06b211905db287922919c0e8337807f78223c0 100644
--- a/src/plugins/wp/ProverWhy3.ml
+++ b/src/plugins/wp/ProverWhy3.ml
@@ -116,7 +116,7 @@ let t_app' ~cnv ~f ~l ~p tl ty =
let fold_map map fold = function
| [] -> assert false (** absurd: forbidden by qed *)
| a::tl ->
- List.fold_left (fun acc a -> fold acc (map a)) (map a) tl
+ List.fold_left (fun acc a -> fold acc (map a)) (map a) tl
let empty_context name : context = {
th = Why3.Theory.create_theory (Why3.Ident.id_fresh name);
@@ -147,7 +147,7 @@ let coerce ~cnv sort expected r =
match sort, expected with
| Qed.Logic.Bool, Qed.Logic.Prop -> Why3.Term.(t_equ r t_bool_true)
| Qed.Logic.Int, Qed.Logic.Real ->
- t_app ~cnv ~f:["real"] ~l:"FromInt" ~p:["from_int"] [r]
+ t_app ~cnv ~f:["real"] ~l:"FromInt" ~p:["from_int"] [r]
| _ -> r
let name_of_adt = function
@@ -184,11 +184,11 @@ let shareable e =
let subterms f e =
match Lang.F.repr e with
| Rdef fts ->
- begin
- match Lang.F.record_with fts with
- | None -> Lang.F.lc_iter f e
- | Some(a,fts) -> f a ; List.iter (fun (_,e) -> f e) fts
- end
+ begin
+ match Lang.F.record_with fts with
+ | None -> Lang.F.lc_iter f e
+ | Some(a,fts) -> f a ; List.iter (fun (_,e) -> f e) fts
+ end
| _ -> Lang.F.lc_iter f e
(* path splitting *)
@@ -203,10 +203,10 @@ let wp_why3_lib library =
| [] -> [library]
| [ lib ] -> Str.split_delim regexp_dot lib
| l ->
- let pp_sep fmt () = Format.pp_print_string fmt ", " in
- Wp_parameters.fatal
- "too many bindings for WP-specific Why3 theory file %s:@\n%a"
- library Format.(pp_print_list ~pp_sep pp_print_string) l
+ let pp_sep fmt () = Format.pp_print_string fmt ", " in
+ Wp_parameters.fatal
+ "too many bindings for WP-specific Why3 theory file %s:@\n%a"
+ library Format.(pp_print_list ~pp_sep pp_print_string) l
(* conversion *)
@@ -217,8 +217,8 @@ let rec of_tau ~cnv (t:Lang.F.tau) =
| Int -> Some Why3.Ty.ty_int
| Real -> Some Why3.Ty.ty_real
| Array(k,v) ->
- let ts = get_ts ~cnv ~f:["map"] ~l:"Map" ~p:["map"] in
- Some (Why3.Ty.ty_app ts [Why3.Opt.get (of_tau ~cnv k); Why3.Opt.get (of_tau ~cnv v)])
+ let ts = get_ts ~cnv ~f:["map"] ~l:"Map" ~p:["map"] in
+ Some (Why3.Ty.ty_app ts [Why3.Opt.get (of_tau ~cnv k); Why3.Opt.get (of_tau ~cnv v)])
| Data(adt,l) -> begin
let s = name_of_adt adt in
let find s =
@@ -229,11 +229,11 @@ let rec of_tau ~cnv (t:Lang.F.tau) =
match find s with
| ts -> Some (Why3.Ty.ty_app ts (List.map (fun e -> Why3.Opt.get (of_tau ~cnv e)) l))
| exception Not_found ->
- why3_failure "Can't find type '%s' in why3 namespace" s
+ why3_failure "Can't find type '%s' in why3 namespace" s
end
| Tvar i -> Some (Why3.Ty.ty_var (tvar i))
| Record _ ->
- why3_failure "Type %a not (yet) convertible" Lang.F.pp_tau t
+ why3_failure "Type %a not (yet) convertible" Lang.F.pp_tau t
module Literal =
struct
@@ -289,10 +289,10 @@ struct
let const_float ~cnv tau (repr:Lang.F.QED.repr) =
match repr with
| Fun(f, [x]) when Lang.Fun.(equal f Cfloat.fq32 || equal f Cfloat.fq64) ->
- begin match Lang.F.repr x with
- | Kreal q -> float_literal_from_q ~cnv tau q
- | _ -> raise Not_found
- end
+ begin match Lang.F.repr x with
+ | Kreal q -> float_literal_from_q ~cnv tau q
+ | _ -> raise Not_found
+ end
| _ -> raise Not_found
let is_float_literal ~cnv tau repr =
@@ -311,9 +311,9 @@ let rec full_trigger = function
let rec full_triggers = function
| [] -> []
| ts :: tgs ->
- match List.filter full_trigger ts with
- | [] -> full_triggers tgs
- | ts -> ts :: full_triggers tgs
+ match List.filter full_trigger ts with
+ | [] -> full_triggers tgs
+ | ts -> ts :: full_triggers tgs
let rec of_trigger ~cnv t =
match t with
@@ -323,24 +323,24 @@ let rec of_trigger ~cnv t =
with Not_found -> why3_failure "Unbound variable %a" Lang.F.pp_var v
end
| Qed.Engine.TgGet(m,k) ->
- t_app ~cnv ~f:["map"] ~l:"Map" ~p:["get"] [of_trigger cnv m;of_trigger cnv k]
+ t_app ~cnv ~f:["map"] ~l:"Map" ~p:["get"] [of_trigger cnv m;of_trigger cnv k]
| TgSet(m,k,v) ->
- t_app ~cnv ~f:["map"] ~l:"Map" ~p:["set"] [of_trigger cnv m;of_trigger cnv k;of_trigger cnv v]
+ t_app ~cnv ~f:["map"] ~l:"Map" ~p:["set"] [of_trigger cnv m;of_trigger cnv k;of_trigger cnv v]
| TgFun (f,l) -> begin
match lfun_name f with
| F_call s ->
- let ls = Why3.Theory.(ns_find_ls (get_namespace cnv.th) (cut_path s)) in
- Why3.Term.t_app_infer ls (List.map (fun e -> of_trigger cnv e) l)
+ let ls = Why3.Theory.(ns_find_ls (get_namespace cnv.th) (cut_path s)) in
+ Why3.Term.t_app_infer ls (List.map (fun e -> of_trigger cnv e) l)
| _ -> why3_failure "can not convert extented calls in triggers"
end
| TgProp (f,l) ->
- begin
- match lfun_name f with
- | F_call s ->
- let ls = Why3.Theory.(ns_find_ls (get_namespace cnv.th) (cut_path s)) in
- Why3.Term.t_app_infer ls (List.map (fun e -> of_trigger cnv e) l)
- | _ -> why3_failure "can not convert extented calls in triggers"
- end
+ begin
+ match lfun_name f with
+ | F_call s ->
+ let ls = Why3.Theory.(ns_find_ls (get_namespace cnv.th) (cut_path s)) in
+ Why3.Term.t_app_infer ls (List.map (fun e -> of_trigger cnv e) l)
+ | _ -> why3_failure "can not convert extented calls in triggers"
+ end
let rec of_term ~cnv expected t : Why3.Term.term =
Wp_parameters.debug ~dkey:dkey_api
@@ -375,112 +375,112 @@ let rec of_term ~cnv expected t : Why3.Term.term =
| Kint z, Int, _ -> coerce ~cnv sort expected $ Literal.const_int z
| Kreal q, Real, _ -> coerce ~cnv sort expected $ Literal.const_real ~cnv q
| repr, t, _ when Literal.is_float_literal ~cnv t repr ->
- coerce ~cnv sort expected $ Literal.const_float ~cnv t repr
+ coerce ~cnv sort expected $ Literal.const_float ~cnv t repr
| Times(z,t), Int, _ ->
- coerce ~cnv sort expected $
- t_app ~cnv ~f:["int"] ~l:"Int" ~p:["infix *"] [Literal.const_int z; of_term cnv sort t]
+ coerce ~cnv sort expected $
+ t_app ~cnv ~f:["int"] ~l:"Int" ~p:["infix *"] [Literal.const_int z; of_term cnv sort t]
| Times(z,t), Real, _ ->
- coerce ~cnv sort expected $
- t_app ~cnv ~f:["real"] ~l:"Real" ~p:["infix *"]
- [Literal.const_real ~cnv (Q.of_bigint z); of_term cnv sort t]
+ coerce ~cnv sort expected $
+ t_app ~cnv ~f:["real"] ~l:"Real" ~p:["infix *"]
+ [Literal.const_real ~cnv (Q.of_bigint z); of_term cnv sort t]
| Add l, Int, _ ->
- coerce ~cnv sort expected $
- t_app_fold ~f:["int"] ~l:"Int" ~p:["infix +"] ~cnv sort l
+ coerce ~cnv sort expected $
+ t_app_fold ~f:["int"] ~l:"Int" ~p:["infix +"] ~cnv sort l
| Add l, Real, _ ->
- coerce ~cnv sort expected $
- t_app_fold ~f:["real"] ~l:"Real" ~p:["infix +"] ~cnv sort l
+ coerce ~cnv sort expected $
+ t_app_fold ~f:["real"] ~l:"Real" ~p:["infix +"] ~cnv sort l
| Mul l, Int, _ ->
- coerce ~cnv sort expected $
- t_app_fold ~f:["int"] ~l:"Int" ~p:["infix *"] ~cnv sort l
+ coerce ~cnv sort expected $
+ t_app_fold ~f:["int"] ~l:"Int" ~p:["infix *"] ~cnv sort l
| Mul l, Real, _ ->
- coerce ~cnv sort expected $
- t_app_fold ~f:["real"] ~l:"Real" ~p:["infix *"] ~cnv sort l
+ coerce ~cnv sort expected $
+ t_app_fold ~f:["real"] ~l:"Real" ~p:["infix *"] ~cnv sort l
| Leq (a,b), _, Prop ->
- int_or_real ~cnv
- ~fint:["int"] ~lint:"Int" ~pint:["infix <="]
- ~freal:["real"] ~lreal:"Real" ~preal:["infix <="]
- a b
+ int_or_real ~cnv
+ ~fint:["int"] ~lint:"Int" ~pint:["infix <="]
+ ~freal:["real"] ~lreal:"Real" ~preal:["infix <="]
+ a b
| Div(a,b), Int, _ ->
- coerce ~cnv sort expected $
- t_app ~cnv ~f:["int"] ~l:"ComputerDivision" ~p:["div"]
- [of_term ~cnv sort a; of_term ~cnv sort b]
+ coerce ~cnv sort expected $
+ t_app ~cnv ~f:["int"] ~l:"ComputerDivision" ~p:["div"]
+ [of_term ~cnv sort a; of_term ~cnv sort b]
| Mod(a,b), Int, _ ->
- coerce ~cnv sort expected $
- t_app ~cnv ~f:["int"] ~l:"ComputerDivision" ~p:["mod"]
- [of_term ~cnv sort a; of_term ~cnv sort b]
+ coerce ~cnv sort expected $
+ t_app ~cnv ~f:["int"] ~l:"ComputerDivision" ~p:["mod"]
+ [of_term ~cnv sort a; of_term ~cnv sort b]
| Div(a,b), Real, _ ->
- coerce ~cnv sort expected $
- t_app ~cnv ~f:["real"] ~l:"Real" ~p:["infix /"]
- [of_term ~cnv sort a; of_term ~cnv sort b]
+ coerce ~cnv sort expected $
+ t_app ~cnv ~f:["real"] ~l:"Real" ~p:["infix /"]
+ [of_term ~cnv sort a; of_term ~cnv sort b]
| Lt (a,b), _, Prop ->
- int_or_real ~cnv
- ~fint:["int"] ~lint:"Int" ~pint:["infix <"]
- ~freal:["real"] ~lreal:"Real" ~preal:["infix <"]
- a b
+ int_or_real ~cnv
+ ~fint:["int"] ~lint:"Int" ~pint:["infix <"]
+ ~freal:["real"] ~lreal:"Real" ~preal:["infix <"]
+ a b
| Leq (a,b), _, Bool ->
- int_or_real ~cnv
- ~fint:(wp_why3_lib "qed") ~lint:"Qed" ~pint:["zleq"]
- ~freal:(wp_why3_lib "qed") ~lreal:"Qed" ~preal:["rleq"]
- a b
+ int_or_real ~cnv
+ ~fint:(wp_why3_lib "qed") ~lint:"Qed" ~pint:["zleq"]
+ ~freal:(wp_why3_lib "qed") ~lreal:"Qed" ~preal:["rleq"]
+ a b
| Lt (a,b), _, Bool ->
- int_or_real ~cnv
- ~fint:(wp_why3_lib "qed") ~lint:"Qed" ~pint:["zlt"]
- ~freal:(wp_why3_lib "qed") ~lreal:"Qed" ~preal:["rlt"]
- a b
+ int_or_real ~cnv
+ ~fint:(wp_why3_lib "qed") ~lint:"Qed" ~pint:["zlt"]
+ ~freal:(wp_why3_lib "qed") ~lreal:"Qed" ~preal:["rlt"]
+ a b
| And l, _, Bool ->
- t_app_fold ~f:["bool"] ~l:"Bool" ~p:["andb"] ~cnv expected l
+ t_app_fold ~f:["bool"] ~l:"Bool" ~p:["andb"] ~cnv expected l
| And l, _, Prop ->
- fold_map (of_term ~cnv expected) Why3.Term.t_and l
+ fold_map (of_term ~cnv expected) Why3.Term.t_and l
| Or l, _, Bool ->
- t_app_fold ~f:["bool"] ~l:"Bool" ~p:["orb"] ~cnv expected l
+ t_app_fold ~f:["bool"] ~l:"Bool" ~p:["orb"] ~cnv expected l
| Or l, _, Prop ->
- fold_map (of_term ~cnv expected) Why3.Term.t_or l
+ fold_map (of_term ~cnv expected) Why3.Term.t_or l
| Not e, _, Bool ->
- let cnv = {cnv with polarity = Cvalues.negate cnv.polarity} in
- t_app ~cnv ~f:["bool"] ~l:"Bool" ~p:["notb"] [of_term ~cnv expected e]
+ let cnv = {cnv with polarity = Cvalues.negate cnv.polarity} in
+ t_app ~cnv ~f:["bool"] ~l:"Bool" ~p:["notb"] [of_term ~cnv expected e]
| Not e, _, Prop ->
- let cnv = {cnv with polarity = Cvalues.negate cnv.polarity} in
- Why3.Term.t_not (of_term cnv expected e)
+ let cnv = {cnv with polarity = Cvalues.negate cnv.polarity} in
+ Why3.Term.t_not (of_term cnv expected e)
| Imply (l,e), _, _ ->
- let e = (of_term ~cnv expected) e in
- let cnv' = {cnv with polarity = Cvalues.negate cnv.polarity} in
- let fold acc a =
- let a = of_term ~cnv:cnv' expected a in
- match expected with
- | Prop -> Why3.Term.t_implies a acc
- | _ (* Bool *) ->
- t_app ~cnv:cnv' ~f:["bool"] ~l:"Bool" ~p:["implb"] [a;acc]
- in
- List.fold_left fold e (List.rev l)
+ let e = (of_term ~cnv expected) e in
+ let cnv' = {cnv with polarity = Cvalues.negate cnv.polarity} in
+ let fold acc a =
+ let a = of_term ~cnv:cnv' expected a in
+ match expected with
+ | Prop -> Why3.Term.t_implies a acc
+ | _ (* Bool *) ->
+ t_app ~cnv:cnv' ~f:["bool"] ~l:"Bool" ~p:["implb"] [a;acc]
+ in
+ List.fold_left fold e (List.rev l)
| Eq (a,b), _, Prop -> begin
match Lang.F.typeof a with
| Prop | Bool ->
- Why3.Term.t_iff (of_term cnv Prop a) (of_term cnv Prop b)
+ Why3.Term.t_iff (of_term cnv Prop a) (of_term cnv Prop b)
| tau ->
- match List.find (fun spe -> spe.Lang.For_export.for_tau tau) !specific_equalities with
- | spe when cnv.polarity = `Positive -> of_term cnv expected (spe.mk_new_eq a b)
- | exception Not_found -> Why3.Term.t_equ (of_term' cnv a) (of_term' cnv b)
- | _ -> Why3.Term.t_equ (of_term' cnv a) (of_term' cnv b)
+ match List.find (fun spe -> spe.Lang.For_export.for_tau tau) !specific_equalities with
+ | spe when cnv.polarity = `Positive -> of_term cnv expected (spe.mk_new_eq a b)
+ | exception Not_found -> Why3.Term.t_equ (of_term' cnv a) (of_term' cnv b)
+ | _ -> Why3.Term.t_equ (of_term' cnv a) (of_term' cnv b)
end
| Neq (a,b), _, Prop ->
- begin
- match Lang.F.typeof a with
- | Prop | Bool ->
- Why3.Term.t_not (Why3.Term.t_iff (of_term cnv Prop a) (of_term cnv Prop b))
- | tau ->
- match List.find (fun spe -> spe.Lang.For_export.for_tau tau) !specific_equalities with
- | spe when cnv.polarity = `Negative ->
- Why3.Term.t_not (of_term cnv expected (spe.mk_new_eq a b))
- | exception Not_found -> Why3.Term.t_neq (of_term' cnv a) (of_term' cnv b)
- | _ -> Why3.Term.t_neq (of_term' cnv a) (of_term' cnv b)
- end
+ begin
+ match Lang.F.typeof a with
+ | Prop | Bool ->
+ Why3.Term.t_not (Why3.Term.t_iff (of_term cnv Prop a) (of_term cnv Prop b))
+ | tau ->
+ match List.find (fun spe -> spe.Lang.For_export.for_tau tau) !specific_equalities with
+ | spe when cnv.polarity = `Negative ->
+ Why3.Term.t_not (of_term cnv expected (spe.mk_new_eq a b))
+ | exception Not_found -> Why3.Term.t_neq (of_term' cnv a) (of_term' cnv b)
+ | _ -> Why3.Term.t_neq (of_term' cnv a) (of_term' cnv b)
+ end
| Eq (a,b), _, Bool ->
- t_app ~cnv ~f:(wp_why3_lib "qed") ~l:"Qed" ~p:["eqb"] [of_term' cnv a; of_term' cnv b]
+ t_app ~cnv ~f:(wp_why3_lib "qed") ~l:"Qed" ~p:["eqb"] [of_term' cnv a; of_term' cnv b]
| Neq (a,b), _, Bool ->
- t_app ~cnv ~f:(wp_why3_lib "qed") ~l:"Qed" ~p:["neqb"] [of_term' cnv a; of_term' cnv b]
+ t_app ~cnv ~f:(wp_why3_lib "qed") ~l:"Qed" ~p:["neqb"] [of_term' cnv a; of_term' cnv b]
| If(a,b,c), _, _ ->
- let cnv' = {cnv with polarity = `NoPolarity} in
- Why3.Term.t_if (of_term cnv' Prop a) (of_term cnv expected b) (of_term cnv expected c)
+ let cnv' = {cnv with polarity = `NoPolarity} in
+ Why3.Term.t_if (of_term cnv' Prop a) (of_term cnv expected b) (of_term cnv expected c)
| Aget(m,k), _, _ -> begin
coerce ~cnv sort expected $
let mtau = Lang.F.typeof m in
@@ -490,11 +490,11 @@ let rec of_term ~cnv expected t : Why3.Term.term =
t_app ~cnv ~f:["map"] ~l:"Map" ~p:["get"] [of_term cnv mtau m;of_term cnv ksort k]
end
| Aset(m,k,v), Array(ksort,vsort), _ ->
- coerce ~cnv sort expected $
- t_app ~cnv ~f:["map"] ~l:"Map" ~p:["set"] [of_term cnv sort m;of_term cnv ksort k;of_term cnv vsort v]
+ coerce ~cnv sort expected $
+ t_app ~cnv ~f:["map"] ~l:"Map" ~p:["set"] [of_term cnv sort m;of_term cnv ksort k;of_term cnv vsort v]
| Acst(_,v), Array(_,vsort), _ ->
- coerce ~cnv sort expected $
- t_app' ~cnv ~f:["map"] ~l:"Const" ~p:["const"] [of_term cnv vsort v] (of_tau cnv sort)
+ coerce ~cnv sort expected $
+ t_app' ~cnv ~f:["map"] ~l:"Const" ~p:["const"] [of_term cnv vsort v] (of_tau cnv sort)
(* Generic *)
| Fun (f,l), _, _ -> begin
let t_app ls l r =
@@ -508,11 +508,11 @@ let rec of_term ~cnv expected t : Why3.Term.term =
in
match find s, expected with
| ls, (Prop | Bool) ->
- coerce ~cnv sort expected $
- t_app ls l (of_tau cnv sort)
+ coerce ~cnv sort expected $
+ t_app ls l (of_tau cnv sort)
| ls, _ ->
- coerce ~cnv sort expected $
- t_app ls l (of_tau cnv sort)
+ coerce ~cnv sort expected $
+ t_app ls l (of_tau cnv sort)
| exception Not_found -> why3_failure "Can't find '%s' in why3 namespace" s
in
let apply_from_ns' s l =
@@ -522,46 +522,46 @@ let rec of_term ~cnv expected t : Why3.Term.term =
| F_call s, _ -> apply_from_ns' s l sort
| Qed.Engine.F_subst (s, _), _ -> apply_from_ns' s l sort
| Qed.Engine.F_left s, _ | Qed.Engine.F_assoc s, _ ->
- let rec aux = function
- | [] -> why3_failure "Empty application"
- | [a] -> of_term cnv expected a
- | a::l ->
- apply_from_ns s [of_term' cnv a; aux l] sort
- in
- aux l
+ let rec aux = function
+ | [] -> why3_failure "Empty application"
+ | [a] -> of_term cnv expected a
+ | a::l ->
+ apply_from_ns s [of_term' cnv a; aux l] sort
+ in
+ aux l
| Qed.Engine.F_right s, _ ->
- let rec aux = function
- | [] -> why3_failure "Empty application"
- | [a] -> of_term cnv expected a
- | a::l ->
- apply_from_ns s [aux l;of_term' cnv a] sort
- in
- aux (List.rev l)
+ let rec aux = function
+ | [] -> why3_failure "Empty application"
+ | [a] -> of_term cnv expected a
+ | a::l ->
+ apply_from_ns s [aux l;of_term' cnv a] sort
+ in
+ aux (List.rev l)
| Qed.Engine.F_list (fcons,fnil), _ ->
- let rec aux = function
- | [] -> apply_from_ns fnil [] sort
- | a::l ->
- apply_from_ns fcons [of_term' cnv a;aux l] sort
- in
- aux l
+ let rec aux = function
+ | [] -> apply_from_ns fnil [] sort
+ | a::l ->
+ apply_from_ns fcons [of_term' cnv a;aux l] sort
+ in
+ aux l
| Qed.Engine.F_bool_prop (s,_), Bool | Qed.Engine.F_bool_prop (_,s), Prop ->
- apply_from_ns' s l expected
+ apply_from_ns' s l expected
| Qed.Engine.F_bool_prop (_,_), _ ->
- why3_failure "badly expected type %a for term %a"
- Lang.F.pp_tau expected Lang.F.pp_term t
+ why3_failure "badly expected type %a for term %a"
+ Lang.F.pp_tau expected Lang.F.pp_term t
end
| Rget(a, (Cfield(_,KInit) as f)), _ , tau -> begin
let s = Lang.name_of_field f in
match Why3.Theory.(ns_find_ls (get_namespace cnv.th) (cut_path s)) with
| ls ->
- begin match tau with
- | Prop ->
- Why3.Term.t_equ
- (Why3.Term.t_app ls [of_term' cnv a] (Some Why3.Ty.ty_bool))
- (Why3.Term.t_bool_true)
- | _ ->
- Why3.Term.t_app ls [of_term' cnv a] (of_tau ~cnv tau)
- end
+ begin match tau with
+ | Prop ->
+ Why3.Term.t_equ
+ (Why3.Term.t_app ls [of_term' cnv a] (Some Why3.Ty.ty_bool))
+ (Why3.Term.t_bool_true)
+ | _ ->
+ Why3.Term.t_app ls [of_term' cnv a] (of_tau ~cnv tau)
+ end
| exception Not_found -> why3_failure "Can't find '%s' in why3 namespace" s
end
@@ -579,8 +579,8 @@ let rec of_term ~cnv expected t : Why3.Term.term =
in
match Why3.Theory.(ns_find_ls (get_namespace cnv.th) (cut_path s)) with
| ls ->
- let l = List.map (fun (_,t) -> of_term' cnv t) l in
- Why3.Term.t_app ls l (of_tau cnv expected)
+ let l = List.map (fun (_,t) -> of_term' cnv t) l in
+ Why3.Term.t_app ls l (of_tau cnv expected)
| exception Not_found -> why3_failure "Can't find '%s' in why3 namespace" s
end
| (Rdef _, Data ((Mtype _|Mrecord (_, _)|Atype _), _), _)
@@ -607,9 +607,9 @@ let rec of_term ~cnv expected t : Why3.Term.term =
| (Bind (Lambda, _, _), _, _)
| Apply _ , _, _
| Rdef _, Record _, _ ->
- why3_failure
- "Can't convert to why3 the qed term %a of type %a"
- Lang.F.pp_term t Lang.F.pp_tau sort
+ why3_failure
+ "Can't convert to why3 the qed term %a of type %a"
+ Lang.F.pp_term t Lang.F.pp_tau sort
in
r
@@ -639,36 +639,36 @@ and mk_lets cnv l =
match e'.t_ty with
| None -> ({cnv with subst = Lang.F.Tmap.add e e' cnv.subst},lets)
| Some ty ->
- let x = Why3.Ident.id_fresh (Lang.F.basename e) in
- let x = Why3.Term.create_vsymbol x ty in
- (* Format.printf "lets %a = %a : %a@."
- * Why3.Pretty.print_vsty x
- * Why3.Pretty.print_term e'
- * Why3.Pretty.print_ty (Why3.Term.t_type e'); *)
- let cnv = {cnv with subst = Lang.F.Tmap.add e (Why3.Term.t_var x) cnv.subst } in
- let lets = (x,e')::lets in
- cnv,lets
+ let x = Why3.Ident.id_fresh (Lang.F.basename e) in
+ let x = Why3.Term.create_vsymbol x ty in
+ (* Format.printf "lets %a = %a : %a@."
+ * Why3.Pretty.print_vsty x
+ * Why3.Pretty.print_term e'
+ * Why3.Pretty.print_ty (Why3.Term.t_type e'); *)
+ let cnv = {cnv with subst = Lang.F.Tmap.add e (Why3.Term.t_var x) cnv.subst } in
+ let lets = (x,e')::lets in
+ cnv,lets
) (cnv,[]) l
and successive_binders cnv q t =
match Lang.F.repr t with
| Bind((Forall|Exists) as q',tau,t) when q' = q ->
- let x = Lang.F.fresh cnv.pool tau in
- let x' = Why3.Ident.id_fresh (Lang.F.Tau.basename tau) in
- let x' = Why3.Term.create_vsymbol x' (Why3.Opt.get (of_tau cnv tau)) in
- let cnv = {cnv with subst = Lang.F.Tmap.add (Lang.F.e_var x) (Why3.Term.t_var x') cnv.subst} in
- let t = Lang.F.QED.e_unbind x t in
- let why3_vars, t = successive_binders cnv q t in
- x'::why3_vars, t
+ let x = Lang.F.fresh cnv.pool tau in
+ let x' = Why3.Ident.id_fresh (Lang.F.Tau.basename tau) in
+ let x' = Why3.Term.create_vsymbol x' (Why3.Opt.get (of_tau cnv tau)) in
+ let cnv = {cnv with subst = Lang.F.Tmap.add (Lang.F.e_var x) (Why3.Term.t_var x') cnv.subst} in
+ let t = Lang.F.QED.e_unbind x t in
+ let why3_vars, t = successive_binders cnv q t in
+ x'::why3_vars, t
| _ ->
- [], share cnv Prop t
+ [], share cnv Prop t
and int_or_real ~cnv ~fint ~lint ~pint ~freal ~lreal ~preal a b =
match (Lang.F.typeof a), (Lang.F.typeof b) with
| Int, Int ->
- t_app_fold ~f:fint ~l:lint ~p:pint ~cnv Int [a; b]
+ t_app_fold ~f:fint ~l:lint ~p:pint ~cnv Int [a; b]
| Real, Int | Real, Real | Int, Real ->
- t_app_fold ~f:freal ~l:lreal ~p:preal ~cnv Real [a; b]
+ t_app_fold ~f:freal ~l:lreal ~p:preal ~cnv Real [a; b]
| _ -> assert false
let convert cnv expected t =
@@ -682,12 +682,12 @@ let mk_binders cnv l =
match of_tau cnv (Lang.F.tau_of_var v) with
| None -> why3_failure "Quantification on prop"
| Some ty ->
- let x = Why3.Ident.id_fresh (Lang.F.Var.basename v) in
- let x = Why3.Term.create_vsymbol x ty in
- let e = Lang.F.e_var v in
- let cnv = {cnv with subst = Lang.F.Tmap.add e (Why3.Term.t_var x) cnv.subst } in
- let lets = x::lets in
- cnv,lets
+ let x = Why3.Ident.id_fresh (Lang.F.Var.basename v) in
+ let x = Why3.Term.create_vsymbol x ty in
+ let e = Lang.F.e_var v in
+ let cnv = {cnv with subst = Lang.F.Tmap.add e (Why3.Term.t_var x) cnv.subst } in
+ let lets = x::lets in
+ cnv,lets
) (cnv,[]) (List.rev l)
(** visit definitions and add them in the task *)
@@ -764,8 +764,8 @@ class visitor (ctx:context) c =
match Str.split_delim regexp_dot thy with
| [] -> why3_failure "[driver] empty import option"
| l ->
- let file, thy = Why3.Lists.chop_last l in
- self#add_import_use file thy (Why3.Opt.get_def thy was) ~import:true
+ let file, thy = Why3.Lists.chop_last l in
+ self#add_import_use file thy (Why3.Opt.get_def thy was) ~import:true
method add_import_file file thy =
self#add_import_use ~import:true file thy thy
@@ -800,16 +800,16 @@ class visitor (ctx:context) c =
let iter_file opt =
match Str.split_delim regexp_col opt with
| [file] ->
- let filenoext = filenoext file in
- copy_file file;
- self#add_import_file [filenoext]
- (String.capitalize_ascii filenoext);
+ let filenoext = filenoext file in
+ copy_file file;
+ self#add_import_file [filenoext]
+ (String.capitalize_ascii filenoext);
| [file;lib] ->
- copy_file file;
- self#add_import_file [filenoext file] lib;
+ copy_file file;
+ self#add_import_file [filenoext file] lib;
| [file;lib;name] ->
- copy_file file;
- self#add_import_file_as [filenoext file] lib name;
+ copy_file file;
+ self#add_import_file_as [filenoext file] lib name;
| _ -> why3_failure
"[driver] incorrect why3.file %S for library '%s'"
opt thy
@@ -834,63 +834,63 @@ class visitor (ctx:context) c =
method on_type lt def =
match def with
| Tabs ->
- let id = Why3.Ident.id_fresh (Lang.type_id lt) in
- let map i _ = tvar i in
- let tv_args = List.mapi map lt.lt_params in
- let id = Why3.Ty.create_tysymbol id tv_args NoDef in
- let decl = Why3.Decl.create_ty_decl id in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let id = Why3.Ident.id_fresh (Lang.type_id lt) in
+ let map i _ = tvar i in
+ let tv_args = List.mapi map lt.lt_params in
+ let id = Why3.Ty.create_tysymbol id tv_args NoDef in
+ let decl = Why3.Decl.create_ty_decl id in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
| Tdef t ->
- let id = Why3.Ident.id_fresh (Lang.type_id lt) in
- let map i _ = tvar i in
- let tv_args = List.mapi map lt.lt_params in
- let cnv = empty_cnv ctx in
- let t = Why3.Opt.get (of_tau ~cnv t) in
- let id = Why3.Ty.create_tysymbol id tv_args (Alias t) in
- let decl = Why3.Decl.create_ty_decl id in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let id = Why3.Ident.id_fresh (Lang.type_id lt) in
+ let map i _ = tvar i in
+ let tv_args = List.mapi map lt.lt_params in
+ let cnv = empty_cnv ctx in
+ let t = Why3.Opt.get (of_tau ~cnv t) in
+ let id = Why3.Ty.create_tysymbol id tv_args (Alias t) in
+ let decl = Why3.Decl.create_ty_decl id in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
| Tsum cases ->
- let name = Lang.type_id lt in
- let id = Why3.Ident.id_fresh name in
- let map i _ = tvar i in
- let tv_args = List.mapi map lt.lt_params in
- let tys = Why3.Ty.create_tysymbol id tv_args NoDef in
- let cnv = empty_cnv ctx in
- Hashtbl.add cnv.incomplete_types name tys ;
- let tv_args = List.map Why3.Ty.ty_var tv_args in
- let return_ty = Why3.Ty.ty_app tys tv_args in
- let constr = List.length cases in
- let cases = List.map (fun (c,targs) ->
- let name = match c with | Lang.CTOR c -> Lang.ctor_id c | _ -> assert false in
- let id = Why3.Ident.id_fresh name in
- let targs = List.map (fun t -> Why3.Opt.get (of_tau ~cnv t)) targs in
- let ls = Why3.Term.create_fsymbol ~constr id targs return_ty in
- let proj = List.map (fun _ -> None) targs in
- (ls,proj)
- ) cases in
- let decl = Why3.Decl.create_data_decl [tys,cases] in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let name = Lang.type_id lt in
+ let id = Why3.Ident.id_fresh name in
+ let map i _ = tvar i in
+ let tv_args = List.mapi map lt.lt_params in
+ let tys = Why3.Ty.create_tysymbol id tv_args NoDef in
+ let cnv = empty_cnv ctx in
+ Hashtbl.add cnv.incomplete_types name tys ;
+ let tv_args = List.map Why3.Ty.ty_var tv_args in
+ let return_ty = Why3.Ty.ty_app tys tv_args in
+ let constr = List.length cases in
+ let cases = List.map (fun (c,targs) ->
+ let name = match c with | Lang.CTOR c -> Lang.ctor_id c | _ -> assert false in
+ let id = Why3.Ident.id_fresh name in
+ let targs = List.map (fun t -> Why3.Opt.get (of_tau ~cnv t)) targs in
+ let ls = Why3.Term.create_fsymbol ~constr id targs return_ty in
+ let proj = List.map (fun _ -> None) targs in
+ (ls,proj)
+ ) cases in
+ let decl = Why3.Decl.create_data_decl [tys,cases] in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
| Trec fields ->
- let name = Lang.type_id lt in
- let id = Why3.Ident.id_fresh name in
- let map i _ = tvar i in
- let tv_args = List.mapi map lt.lt_params in
- let tys = Why3.Ty.create_tysymbol id tv_args NoDef in
- let cnv = empty_cnv ctx in
- Hashtbl.add cnv.incomplete_types name tys ;
- let tv_args = List.map Why3.Ty.ty_var tv_args in
- let return_ty = Why3.Ty.ty_app tys tv_args in
- let fields,args = List.split @@ List.map (fun (f,ty) ->
- let name = Lang.name_of_field f in
- let id = Why3.Ident.id_fresh name in
- let ty = Why3.Opt.get (of_tau ~cnv ty) in
- let ls = Why3.Term.create_fsymbol id [return_ty] ty in
- Some ls,ty
- ) fields in
- let id = Why3.Ident.id_fresh (Lang.type_id lt) in
- let cstr = Why3.Term.create_fsymbol ~constr:1 id args return_ty in
- let decl = Why3.Decl.create_data_decl [tys,[cstr,fields]] in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let name = Lang.type_id lt in
+ let id = Why3.Ident.id_fresh name in
+ let map i _ = tvar i in
+ let tv_args = List.mapi map lt.lt_params in
+ let tys = Why3.Ty.create_tysymbol id tv_args NoDef in
+ let cnv = empty_cnv ctx in
+ Hashtbl.add cnv.incomplete_types name tys ;
+ let tv_args = List.map Why3.Ty.ty_var tv_args in
+ let return_ty = Why3.Ty.ty_app tys tv_args in
+ let fields,args = List.split @@ List.map (fun (f,ty) ->
+ let name = Lang.name_of_field f in
+ let id = Why3.Ident.id_fresh name in
+ let ty = Why3.Opt.get (of_tau ~cnv ty) in
+ let ls = Why3.Term.create_fsymbol id [return_ty] ty in
+ Some ls,ty
+ ) fields in
+ let id = Why3.Ident.id_fresh (Lang.type_id lt) in
+ let cstr = Why3.Term.create_fsymbol ~constr:1 id args return_ty in
+ let decl = Why3.Decl.create_data_decl [tys,[cstr,fields]] in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
method private on_comp_gen kind c fts =
begin
@@ -919,10 +919,10 @@ class visitor (ctx:context) c =
let decl = match fields with
| None -> Why3.Decl.create_ty_decl ts
| Some fields ->
- let constr =
- Why3.Term.create_fsymbol ~constr:1 id (List.map snd fields) ty
- in
- Why3.Decl.create_data_decl [ts,[constr,List.map fst fields]]
+ let constr =
+ Why3.Term.create_fsymbol ~constr:1 id (List.map snd fields) ty
+ in
+ Why3.Decl.create_data_decl [ts,[constr,List.map fst fields]]
in
ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
end
@@ -956,100 +956,100 @@ class visitor (ctx:context) c =
begin
match d.d_definition with
| Logic t ->
- let id = Why3.Ident.id_fresh (Qed.Export.link_name (lfun_name d.d_lfun)) in
- let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
- let ty_args = List.map map d.d_params in
- let id = Why3.Term.create_lsymbol id ty_args (of_tau ~cnv t) in
- let decl = Why3.Decl.create_param_decl id in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let id = Why3.Ident.id_fresh (Qed.Export.link_name (lfun_name d.d_lfun)) in
+ let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
+ let ty_args = List.map map d.d_params in
+ let id = Why3.Term.create_lsymbol id ty_args (of_tau ~cnv t) in
+ let decl = Why3.Decl.create_param_decl id in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
| Function(t,mu,v) -> begin
match mu with
| Rec -> (* transform recursive function into an axioms *)
- let name = Qed.Export.link_name (lfun_name d.d_lfun) in
- let id = Why3.Ident.id_fresh name in
- let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
- let ty_args = List.map map d.d_params in
- let result = of_tau ~cnv t in
- let id = Why3.Term.create_lsymbol id ty_args result in
- let decl = Why3.Decl.create_param_decl id in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
- let cnv = empty_cnv ctx in
- List.iter (Lang.F.add_var cnv.pool) d.d_params;
- let cnv, vars = mk_binders cnv d.d_params in
- let t = share cnv t v in
- let t =
- Why3.Term.t_forall_close vars []
- (Why3.Term.t_equ
- (Why3.Term.t_app id (List.map Why3.Term.t_var vars) result)
- t)
- in
- let decl =
- Why3.Decl.create_prop_decl Why3.Decl.Paxiom
- (Why3.Decl.create_prsymbol (Why3.Ident.id_fresh (name^"_def")))
- t in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let name = Qed.Export.link_name (lfun_name d.d_lfun) in
+ let id = Why3.Ident.id_fresh name in
+ let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
+ let ty_args = List.map map d.d_params in
+ let result = of_tau ~cnv t in
+ let id = Why3.Term.create_lsymbol id ty_args result in
+ let decl = Why3.Decl.create_param_decl id in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let cnv = empty_cnv ctx in
+ List.iter (Lang.F.add_var cnv.pool) d.d_params;
+ let cnv, vars = mk_binders cnv d.d_params in
+ let t = share cnv t v in
+ let t =
+ Why3.Term.t_forall_close vars []
+ (Why3.Term.t_equ
+ (Why3.Term.t_app id (List.map Why3.Term.t_var vars) result)
+ t)
+ in
+ let decl =
+ Why3.Decl.create_prop_decl Why3.Decl.Paxiom
+ (Why3.Decl.create_prsymbol (Why3.Ident.id_fresh (name^"_def")))
+ t in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
| Def ->
- let id = Why3.Ident.id_fresh (Qed.Export.link_name (lfun_name d.d_lfun)) in
- let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
- let ty_args = List.map map d.d_params in
- let result = of_tau ~cnv t in
- let id = Why3.Term.create_lsymbol id ty_args result in
- let cnv, vars = mk_binders cnv d.d_params in
- let t = share cnv t v in
- let decl = Why3.Decl.make_ls_defn id vars t in
- let decl = Why3.Decl.create_logic_decl [decl] in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl
+ let id = Why3.Ident.id_fresh (Qed.Export.link_name (lfun_name d.d_lfun)) in
+ let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
+ let ty_args = List.map map d.d_params in
+ let result = of_tau ~cnv t in
+ let id = Why3.Term.create_lsymbol id ty_args result in
+ let cnv, vars = mk_binders cnv d.d_params in
+ let t = share cnv t v in
+ let decl = Why3.Decl.make_ls_defn id vars t in
+ let decl = Why3.Decl.create_logic_decl [decl] in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl
end
| Predicate(mu,p) -> begin
match mu with
| Rec ->
- let name = Qed.Export.link_name (lfun_name d.d_lfun) in
- let id = Why3.Ident.id_fresh name in
- let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
- let ty_args = List.map map d.d_params in
- let result = None in
- let id = Why3.Term.create_lsymbol id ty_args result in
- let decl = Why3.Decl.create_param_decl id in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
- let cnv = empty_cnv ctx in
- List.iter (Lang.F.add_var cnv.pool) d.d_params;
- let cnv, vars = mk_binders cnv d.d_params in
- let t = share cnv Prop (Lang.F.e_prop p) in
- let t =
- Why3.Term.t_forall_close vars []
- (Why3.Term.t_iff t
- (Why3.Term.t_app id (List.map Why3.Term.t_var vars) result))
- in
- let decl =
- Why3.Decl.create_prop_decl Why3.Decl.Paxiom
- (Why3.Decl.create_prsymbol (Why3.Ident.id_fresh (name^"_def")))
- t in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let name = Qed.Export.link_name (lfun_name d.d_lfun) in
+ let id = Why3.Ident.id_fresh name in
+ let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
+ let ty_args = List.map map d.d_params in
+ let result = None in
+ let id = Why3.Term.create_lsymbol id ty_args result in
+ let decl = Why3.Decl.create_param_decl id in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
+ let cnv = empty_cnv ctx in
+ List.iter (Lang.F.add_var cnv.pool) d.d_params;
+ let cnv, vars = mk_binders cnv d.d_params in
+ let t = share cnv Prop (Lang.F.e_prop p) in
+ let t =
+ Why3.Term.t_forall_close vars []
+ (Why3.Term.t_iff t
+ (Why3.Term.t_app id (List.map Why3.Term.t_var vars) result))
+ in
+ let decl =
+ Why3.Decl.create_prop_decl Why3.Decl.Paxiom
+ (Why3.Decl.create_prsymbol (Why3.Ident.id_fresh (name^"_def")))
+ t in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl;
| Def ->
- let id = Why3.Ident.id_fresh (Qed.Export.link_name (lfun_name d.d_lfun)) in
- let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
- let ty_args = List.map map d.d_params in
- let id = Why3.Term.create_lsymbol id ty_args None in
- let cnv, vars = mk_binders cnv d.d_params in
- let t = share cnv Prop (Lang.F.e_prop p) in
- let decl = Why3.Decl.make_ls_defn id vars t in
- let decl = Why3.Decl.create_logic_decl [decl] in
- ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl
+ let id = Why3.Ident.id_fresh (Qed.Export.link_name (lfun_name d.d_lfun)) in
+ let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
+ let ty_args = List.map map d.d_params in
+ let id = Why3.Term.create_lsymbol id ty_args None in
+ let cnv, vars = mk_binders cnv d.d_params in
+ let t = share cnv Prop (Lang.F.e_prop p) in
+ let decl = Why3.Decl.make_ls_defn id vars t in
+ let decl = Why3.Decl.create_logic_decl [decl] in
+ ctx.th <- Why3.Theory.add_decl ~warn:false ctx.th decl
end
| Inductive dl ->
- (* create predicate symbol *)
- let fname = Qed.Export.link_name (lfun_name d.d_lfun) in
- let id = Why3.Ident.id_fresh fname in
- let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
- let ty_args = List.map map d.d_params in
- let fid = Why3.Term.create_lsymbol id ty_args None in
- let make_case (l:Definitions.dlemma) =
- let cnv = empty_cnv ctx in
- Hashtbl.add cnv.incomplete_symbols fname fid ;
- self#make_lemma cnv l
- in
- let ind_decl = (fid, List.map make_case dl) in
- ctx.th <- Why3.Theory.add_ind_decl ctx.th Why3.Decl.Ind [ind_decl]
+ (* create predicate symbol *)
+ let fname = Qed.Export.link_name (lfun_name d.d_lfun) in
+ let id = Why3.Ident.id_fresh fname in
+ let map e = Why3.Opt.get (of_tau ~cnv (Lang.F.tau_of_var e)) in
+ let ty_args = List.map map d.d_params in
+ let fid = Why3.Term.create_lsymbol id ty_args None in
+ let make_case (l:Definitions.dlemma) =
+ let cnv = empty_cnv ctx in
+ Hashtbl.add cnv.incomplete_symbols fname fid ;
+ self#make_lemma cnv l
+ in
+ let ind_decl = (fid, List.map make_case dl) in
+ ctx.th <- Why3.Theory.add_ind_decl ctx.th Why3.Decl.Ind [ind_decl]
end
end
@@ -1099,17 +1099,17 @@ let task_of_wpo wpo =
let pid = wpo.Wpo.po_pid in
match wpo.Wpo.po_formula with
| Wpo.GoalAnnot v ->
- let pid = wpo.Wpo.po_pid in
- let axioms = v.Wpo.VC_Annot.axioms in
- let prop = Wpo.GOAL.compute_proof ~pid v.Wpo.VC_Annot.goal in
- (* Format.printf "Goal: %a@." Lang.F.pp_pred prop; *)
- prove_prop ~pid prop ?axioms
+ let pid = wpo.Wpo.po_pid in
+ let axioms = v.Wpo.VC_Annot.axioms in
+ let prop = Wpo.GOAL.compute_proof ~pid v.Wpo.VC_Annot.goal in
+ (* Format.printf "Goal: %a@." Lang.F.pp_pred prop; *)
+ prove_prop ~pid prop ?axioms
| Wpo.GoalLemma v ->
- let lemma = v.Wpo.VC_Lemma.lemma in
- let depends = v.Wpo.VC_Lemma.depends in
- let prop = Lang.F.p_forall lemma.l_forall lemma.l_lemma in
- let axioms = Some(lemma.l_cluster,depends) in
- prove_prop ~pid prop ?axioms
+ let lemma = v.Wpo.VC_Lemma.lemma in
+ let depends = v.Wpo.VC_Lemma.depends in
+ let prop = Lang.F.p_forall lemma.l_forall lemma.l_lemma in
+ let axioms = Some(lemma.l_cluster,depends) in
+ prove_prop ~pid prop ?axioms
(* -------------------------------------------------------------------------- *)
(* --- Prover Task --- *)
@@ -1157,53 +1157,53 @@ let ping_prover_call p =
match Why3.Call_provers.query_call p.call with
| NoUpdates
| ProverStarted ->
- let () =
- if p.timeout > 0 then
- match p.timeover with
- | None ->
- let started = Unix.time () in
- p.timeover <- Some (started +. 2.0 +. float p.timeout)
- | Some timeout ->
- let time = Unix.time () in
- if time > timeout then
- begin
- Wp_parameters.debug ~dkey
- "Hard Kill (late why3server timeout)" ;
- p.interrupted <- true ;
- Why3.Call_provers.interrupt_call p.call ;
- end
- in Task.Wait 100
+ let () =
+ if p.timeout > 0 then
+ match p.timeover with
+ | None ->
+ let started = Unix.time () in
+ p.timeover <- Some (started +. 2.0 +. float p.timeout)
+ | Some timeout ->
+ let time = Unix.time () in
+ if time > timeout then
+ begin
+ Wp_parameters.debug ~dkey
+ "Hard Kill (late why3server timeout)" ;
+ p.interrupted <- true ;
+ Why3.Call_provers.interrupt_call p.call ;
+ end
+ in Task.Wait 100
| InternalFailure exn ->
- let msg = Format.asprintf "@[<hov 2>%a@]"
- Why3.Exn_printer.exn_printer exn in
- Task.Return (Task.Result (VCS.failed msg))
+ let msg = Format.asprintf "@[<hov 2>%a@]"
+ Why3.Exn_printer.exn_printer exn in
+ Task.Return (Task.Result (VCS.failed msg))
| ProverInterrupted -> Task.(Return Canceled)
| ProverFinished _ when p.killed -> Task.(Return Canceled)
| ProverFinished pr ->
- let r =
- match pr.pr_answer with
- | Timeout -> VCS.timeout (int_of_float pr.pr_time)
- | Valid -> VCS.result ~time:pr.pr_time ~steps:pr.pr_steps VCS.Valid
- | Invalid -> VCS.result ~time:pr.pr_time ~steps:pr.pr_steps VCS.Invalid
- | OutOfMemory -> VCS.failed "out of memory"
- | StepLimitExceeded -> VCS.result ?steps:p.steps VCS.Stepout
- | Unknown _ -> VCS.unknown
- | _ when p.interrupted -> VCS.timeout p.timeout
- | Failure s -> VCS.failed s
- | HighFailure ->
- let alt_ergo_hack =
- p.prover.prover_name = "Alt-Ergo" &&
- Str.string_match altergo_step_limit pr.pr_output 0
- in
- if alt_ergo_hack then VCS.result ?steps:p.steps VCS.Stepout
- else VCS.failed "Unknown error"
- in
- Wp_parameters.debug ~dkey
- "@[@[Why3 result for %a:@] @[%a@] and @[%a@]@."
- Why3.Whyconf.print_prover p.prover
- (Why3.Call_provers.print_prover_result ~json:false) pr
- VCS.pp_result r;
- Task.Return (Task.Result r)
+ let r =
+ match pr.pr_answer with
+ | Timeout -> VCS.timeout (int_of_float pr.pr_time)
+ | Valid -> VCS.result ~time:pr.pr_time ~steps:pr.pr_steps VCS.Valid
+ | Invalid -> VCS.result ~time:pr.pr_time ~steps:pr.pr_steps VCS.Invalid
+ | OutOfMemory -> VCS.failed "out of memory"
+ | StepLimitExceeded -> VCS.result ?steps:p.steps VCS.Stepout
+ | Unknown _ -> VCS.unknown
+ | _ when p.interrupted -> VCS.timeout p.timeout
+ | Failure s -> VCS.failed s
+ | HighFailure ->
+ let alt_ergo_hack =
+ p.prover.prover_name = "Alt-Ergo" &&
+ Str.string_match altergo_step_limit pr.pr_output 0
+ in
+ if alt_ergo_hack then VCS.result ?steps:p.steps VCS.Stepout
+ else VCS.failed "Unknown error"
+ in
+ Wp_parameters.debug ~dkey
+ "@[@[Why3 result for %a:@] @[%a@] and @[%a@]@."
+ Why3.Whyconf.print_prover p.prover
+ (Why3.Call_provers.print_prover_result ~json:false) pr
+ VCS.pp_result r;
+ Task.Return (Task.Result r)
let call_prover_task ~timeout ~steps prover call =
Wp_parameters.debug ~dkey "Why3 run prover %a with timeout %d, steps %d@."
@@ -1219,9 +1219,9 @@ let call_prover_task ~timeout ~steps prover call =
} in
let ping = function
| Task.Kill ->
- pcall.killed <- true ;
- Why3.Call_provers.interrupt_call call ;
- Task.Yield
+ pcall.killed <- true ;
+ Why3.Call_provers.interrupt_call call ;
+ Task.Yield
| Task.Coin -> ping_prover_call pcall
in
Task.async ping
@@ -1332,30 +1332,30 @@ let interactive ~mode wpo pconf driver prover task =
match prepare ~mode wpo driver task with
| None -> Task.return VCS.unknown
| Some (script, merge) ->
- match mode with
- | VCS.Batch ->
- compile ~script ~timeout wpo pconf driver prover task
- | VCS.Update ->
- if merge then updatescript ~script driver task ;
- compile ~script ~timeout wpo pconf driver prover task
- | VCS.Edit ->
- let open Task in
- editor ~script ~merge wpo pconf driver prover task >>= fun _ ->
- compile ~script ~timeout wpo pconf driver prover task
- | VCS.Fix ->
- let open Task in
- compile ~script ~timeout wpo pconf driver prover task >>= fun r ->
- if VCS.is_valid r then return r else
- editor ~script ~merge wpo pconf driver prover task >>= fun _ ->
- compile ~script ~timeout wpo pconf driver prover task
- | VCS.FixUpdate ->
- let open Task in
- if merge then updatescript ~script driver task ;
- compile ~script ~timeout wpo pconf driver prover task >>= fun r ->
- if VCS.is_valid r then return r else
- let merge = false in
- editor ~script ~merge wpo pconf driver prover task >>= fun _ ->
- compile ~script ~timeout wpo pconf driver prover task
+ match mode with
+ | VCS.Batch ->
+ compile ~script ~timeout wpo pconf driver prover task
+ | VCS.Update ->
+ if merge then updatescript ~script driver task ;
+ compile ~script ~timeout wpo pconf driver prover task
+ | VCS.Edit ->
+ let open Task in
+ editor ~script ~merge wpo pconf driver prover task >>= fun _ ->
+ compile ~script ~timeout wpo pconf driver prover task
+ | VCS.Fix ->
+ let open Task in
+ compile ~script ~timeout wpo pconf driver prover task >>= fun r ->
+ if VCS.is_valid r then return r else
+ editor ~script ~merge wpo pconf driver prover task >>= fun _ ->
+ compile ~script ~timeout wpo pconf driver prover task
+ | VCS.FixUpdate ->
+ let open Task in
+ if merge then updatescript ~script driver task ;
+ compile ~script ~timeout wpo pconf driver prover task >>= fun r ->
+ if VCS.is_valid r then return r else
+ let merge = false in
+ editor ~script ~merge wpo pconf driver prover task >>= fun _ ->
+ compile ~script ~timeout wpo pconf driver prover task
(* -------------------------------------------------------------------------- *)
(* --- Prove WPO --- *)
diff --git a/src/plugins/wp/RefUsage.ml b/src/plugins/wp/RefUsage.ml
index 44d5f5f5b44182122a62a4be701a673ac6673444..51dcccea8eb87a6fa2c8d6d1948ce46be2f6c028 100644
--- a/src/plugins/wp/RefUsage.ml
+++ b/src/plugins/wp/RefUsage.ml
@@ -183,7 +183,7 @@ let m_vcup =
let m_vcup m = vcup (e_value m) in
function
| E old as m -> (* better sharing than vcup (e_value m) b *)
- share_vcup m ~old
+ share_vcup m ~old
| _ as m -> m_vcup m
let m_fcup f =
@@ -215,10 +215,10 @@ let field = function
let load = function
| Loc_var x -> Val_var x (* E.access x ByValue E.bot *)
| Loc_shift(x,e) ->
- if Cil.isArithmeticOrPointerType x.vtype then
- E (E.access x ByAddr e)
- else
- E (E.access x ByValue e)
+ if Cil.isArithmeticOrPointerType x.vtype then
+ E (E.access x ByAddr e)
+ else
+ E (E.access x ByValue e)
| Val_var x -> E (E.access x ByRef E.bot)
| Val_comp(x,e) -> E (E.access x ByRef e)
| Val_shift(x,e) -> E (E.access x ByArray e)
@@ -251,11 +251,11 @@ let cast_obj tgt src =
match tgt , src with
| (C_int _ | C_float _) , (C_int _ | C_float _) -> Convert
| C_pointer tr , C_pointer te ->
- let obj_r = Ctypes.object_of tr in
- let obj_e = Ctypes.object_of te in
- if Ctypes.compare obj_r obj_e = 0
- then Identity
- else Cast
+ let obj_r = Ctypes.object_of tr in
+ let obj_e = Ctypes.object_of te in
+ if Ctypes.compare obj_r obj_e = 0
+ then Identity
+ else Cast
| _ -> if Ctypes.equal tgt src then Identity else Cast
let cast_ctyp tgt src =
@@ -427,10 +427,10 @@ and term (env:ctx) (t:term) : model = match t.term_node with
| TLval tlv -> term_lval env tlv
| TAddrOf tlv | TStartOf tlv -> addr_lval env tlv
| TUpdate(s,ofs,t) ->
- let v = term env s in
- let k = term_indices env E.bot ofs in
- let e = vterm env t in
- m_vcup (m_vcup v k) e
+ let v = term env s in
+ let k = term_indices env E.bot ofs in
+ let e = vterm env t in
+ m_vcup (m_vcup v k) e
(* Operators *)
| Tat(t,_) -> term env t
@@ -445,30 +445,30 @@ and term (env:ctx) (t:term) : model = match t.term_node with
| Tcomprehension(t,_xs,None) -> mterm env t
| Tcomprehension(t,_xs,Some p) -> m_vcup (term env t) (pred env p)
| Tlet({l_var_info; l_body = LBterm def},t) ->
- let m_def = term env def in
- add_tlet env.local l_var_info m_def;
- let m = term env t in
- rem_tlet env.local l_var_info;
- m
+ let m_def = term env def in
+ add_tlet env.local l_var_info m_def;
+ let m = term env t in
+ rem_tlet env.local l_var_info;
+ m
| Tlet(_,_t) ->
- Wp_parameters.not_yet_implemented "unknown \\let construct"
+ Wp_parameters.not_yet_implemented "unknown \\let construct"
(* No escape *)
| Tblock_length(_, t) ->
- E (unescape ((term env) t))
+ E (unescape ((term env) t))
(* Call *)
| Tapp({l_var_info=({lv_origin=None; lv_kind=LVLocal} as lvar)},[],[]) ->
- (* var bound by a \\let *)
- get_tlet env.local lvar
+ (* var bound by a \\let *)
+ get_tlet env.local lvar
| Tapp(phi,_,ts) -> v_model (v_lphi env phi ts)
(* --- Lvalues --- *)
and term_lval env (h,ofs) = match h with
| TResult _ | TVar{lv_name="\\exit_status"} -> nothing
| TVar( {lv_origin=None ; lv_kind=LVLocal} as lvar) ->
- (* var bound by a \\let *)
- load (term_offset env (get_tlet env.local lvar) ofs)
+ (* var bound by a \\let *)
+ load (term_offset env (get_tlet env.local lvar) ofs)
| TVar( {lv_origin=None} ) -> (* logic variable *) nothing
| TVar( {lv_origin=Some x} ) -> load (term_offset env (Loc_var x) ofs)
| TMem t -> load (term_offset env (load (term env t)) ofs)
@@ -487,12 +487,12 @@ and term_offset env (l:model) = function
and addr_lval env (h,ofs) = match h with
| TResult _ -> Wp_parameters.abort ~current:true "Address of \\result"
| TVar{lv_name="\\exit_status"} ->
- Wp_parameters.abort ~current:true "Address of \\exit_status"
+ Wp_parameters.abort ~current:true "Address of \\exit_status"
| TMem t -> term_offset env (term env t) ofs
| TVar( {lv_origin=Some x} ) -> term_offset env (Loc_var x) ofs
| TVar( {lv_origin=None} as x ) ->
- Wp_parameters.abort ~current:true
- "Address of logic variable (%a)" Logic_var.pretty x
+ Wp_parameters.abort ~current:true
+ "Address of logic variable (%a)" Logic_var.pretty x
(* --- Predicates --- *)
and pred (env:ctx) p : value = match p.pred_content with
@@ -511,22 +511,22 @@ and pred (env:ctx) p : value = match p.pred_content with
(* Binders *)
| Pforall(_,p) | Pexists(_,p) -> (pred env) p
| Plet({l_var_info; l_body = LBterm def},p) ->
- let m_def = term env def in
- add_tlet env.local l_var_info m_def;
- let e = pred env p in
- rem_tlet env.local l_var_info; e
+ let m_def = term env def in
+ add_tlet env.local l_var_info m_def;
+ let e = pred env p in
+ rem_tlet env.local l_var_info; e
| Plet({l_var_info; l_body = LBpred def},p) ->
- let e_def = pred env def in
- add_plet env.local l_var_info e_def;
- let e = pred env p in
- rem_plet env.local l_var_info; e
+ let e_def = pred env def in
+ add_plet env.local l_var_info e_def;
+ let e = pred env p in
+ rem_plet env.local l_var_info; e
| Plet(_,_t) ->
- Wp_parameters.not_yet_implemented "unknown \\let construct"
+ Wp_parameters.not_yet_implemented "unknown \\let construct"
(* Call *)
| Papp({l_var_info=({lv_origin=None; lv_kind=LVLocal} as lvar)},[],[]) ->
- (* var bound by a \\let *)
- get_plet env.local lvar
+ (* var bound by a \\let *)
+ get_plet env.local lvar
| Papp(phi,_,ts) -> v_lphi env phi ts
(* No escape *)
@@ -534,11 +534,11 @@ and pred (env:ctx) p : value = match p.pred_content with
| Pallocable(_, t) | Pfreeable(_, t)
| Pvalid(_,t) | Pvalid_read (_,t)
| Pobject_pointer (_,t) | Pvalid_function t ->
- unescape ((term env) t)
+ unescape ((term env) t)
| Pseparated ts ->
- E.fcup (fun t -> unescape ((term env) t)) ts
+ E.fcup (fun t -> unescape ((term env) t)) ts
| Pfresh(_, _, t1, t2) ->
- E.fcup (fun t -> unescape ((term env) t)) [t1;t2]
+ E.fcup (fun t -> unescape ((term env) t)) [t1;t2]
(* --- Call to Logical functions/Predicates --- *)
and v_lphi (env:ctx) (lphi:logic_info) ts : value =
@@ -551,15 +551,15 @@ and v_lphi (env:ctx) (lphi:logic_info) ts : value =
| LVQuant -> not_yet_implemented "LVQuant"
| LVLocal -> not_yet_implemented "LVLocal"
| LVGlobal ->
- let v_body = (* get the accesses the globals *)
- if not (LFset.mem lphi env.global.lphi) then begin
- env.global.lphi <- LFset.add lphi env.global.lphi;
- v_body env lphi.l_body
- end
- else E.bot
- and v_param =
- E.fcup (vterm env) ts (* usage of the parameter of the application *)
- in E.cup v_param v_body
+ let v_body = (* get the accesses the globals *)
+ if not (LFset.mem lphi env.global.lphi) then begin
+ env.global.lphi <- LFset.add lphi env.global.lphi;
+ v_body env lphi.l_body
+ end
+ else E.bot
+ and v_param =
+ E.fcup (vterm env) ts (* usage of the parameter of the application *)
+ in E.cup v_param v_body
and v_body (env:ctx) = (* locals of the logical function are removed *)
let vglob v = snd (E.partition_formals_vs_others v) in
function
@@ -581,8 +581,8 @@ let cinit vi init =
let rec aux (m: model) a = function
| SingleInit (exp) -> einit m a exp
| CompoundInit(_,loi) ->
- List.fold_left (fun a (ofs,init) -> aux (offset m ofs) a init)
- a loi
+ List.fold_left (fun a (ofs,init) -> aux (offset m ofs) a init)
+ a loi
in aux (cval vi) E.bot init
let cfun_code env kf = (* Visits term/pred of code annotations and C exp *)
@@ -619,24 +619,24 @@ let cfun_code env kf = (* Visits term/pred of code annotations and C exp *)
-> ()
| Throw _ | TryCatch _ | TryExcept _ ->
- Wp_parameters.warning "RefUsage: throw/try-catch not implemented"
+ Wp_parameters.warning "RefUsage: throw/try-catch not implemented"
| Instr(Set(lval,exp,_)) -> do_lval lval ; do_exp exp
| Instr(Call(lval_opt,fun_exp,args_list,_)) ->
- begin
- do_lval_opt lval_opt ;
- match Kernel_function.get_called fun_exp with
- | None -> List.iter do_exp (fun_exp::args_list)
- | Some called_kf -> do_args called_kf args_list
- end
+ begin
+ do_lval_opt lval_opt ;
+ match Kernel_function.get_called fun_exp with
+ | None -> List.iter do_exp (fun_exp::args_list)
+ | Some called_kf -> do_args called_kf args_list
+ end
| Instr(Local_init (v,AssignInit i,_)) -> update_code_env (cinit v i)
| Instr(Local_init (v,ConsInit (f,args,kind),_)) ->
- let kf = Globals.Functions.get f in
- (match kind with
- | Constructor -> do_args kf (Cil.mkAddrOfVi v :: args)
- | Plain_func ->
- update_code_env (e_value (cval v));
- do_args kf args)
+ let kf = Globals.Functions.get f in
+ (match kind with
+ | Constructor -> do_args kf (Cil.mkAddrOfVi v :: args)
+ | Plain_func ->
+ update_code_env (e_value (cval v));
+ do_args kf args)
| Return(Some exp,_)
| If (exp,_,_,_)
| Switch (exp,_,_,_) -> do_exp exp
@@ -713,9 +713,9 @@ let call_kf (env:global_ctx) (formals:access list) (models:model list) (reached:
let unmodified = ref reached in
let rec call xs ms = match xs, ms with
| x::xs , m::ms ->
- let actual = param x m in
- if update_call_env env actual then unmodified := false;
- call xs ms
+ let actual = param x m in
+ if update_call_env env actual then unmodified := false;
+ call xs ms
| _ -> ()
in call formals models;
!unmodified
@@ -844,7 +844,7 @@ struct
match ctxt.Logic_typing.type_term ctxt ctxt.pre_state e with
| { term_node = TLval (TVar { lv_origin = Some vi }, TNoOffset) } as term
when Cil.isPointerType vi.vtype && vi.vformal ->
- make_nullable vi ; term
+ make_nullable vi ; term
| t -> ctxt.error loc "Not a formal pointer: %a" Cil_printer.pp_term t
let typer ctxt loc l =
@@ -880,8 +880,8 @@ let iter ?kf ?(init=false) f =
let kf_access = match kf with
| None -> E.bot
| Some kf ->
- (try KFmap.find kf usage
- with Not_found -> E.bot)
+ (try KFmap.find kf usage
+ with Not_found -> E.bot)
in
let access = if init then E.cup kf_access u_init else kf_access in
E.iter f access
@@ -891,8 +891,8 @@ let get ?kf ?(init=false) vi =
let kf_access = match kf with
| None -> NoAccess
| Some kf ->
- (try E.get vi (KFmap.find kf usage)
- with Not_found -> NoAccess)
+ (try E.get vi (KFmap.find kf usage)
+ with Not_found -> NoAccess)
in
if init then Access.cup kf_access (E.get vi u_init) else kf_access
diff --git a/src/plugins/wp/Region.ml b/src/plugins/wp/Region.ml
index 17964ff42b8c48fb69bfcc8c411fddd3cf179680..26983f71f4f57e3147e5f9e4dfd6fbf253844d16 100644
--- a/src/plugins/wp/Region.ml
+++ b/src/plugins/wp/Region.ml
@@ -237,8 +237,8 @@ let add_pointed map reg =
match reg.pointsTo with
| Some k -> region map k
| None ->
- let r = fresh map in
- reg.pointsTo <- Some r.id ; r
+ let r = fresh map in
+ reg.pointsTo <- Some r.id ; r
let get_addrof map reg =
let addr = fresh map in
@@ -531,9 +531,9 @@ struct
and add_range map marks ~source = function
| { ofs ; reg = target ; dim = Dim(_,[]) } ->
- forward map marks ~source ~from:(Ffield(source,ofs)) ~target
+ forward map marks ~source ~from:(Ffield(source,ofs)) ~target
| { reg = target } ->
- forward map marks ~source ~from:(Findex source) ~target
+ forward map marks ~source ~from:(Findex source) ~target
end
@@ -600,16 +600,16 @@ let rec chunk map region =
match cluster map region with
| Empty | Garbled -> Mraw (roots,get_pointed map region)
| Chunk v ->
- if is_read region || is_written region then
- Mmem(roots,v)
- else
- begin match v with
- | Pointer r -> Mref r
- | _ -> Mraw (roots,get_pointed map region)
- end
+ if is_read region || is_written region then
+ Mmem(roots,v)
+ else
+ begin match v with
+ | Pointer r -> Mref r
+ | _ -> Mraw (roots,get_pointed map region)
+ end
| Layout { layout } ->
- let chunks = Chunk.union_map (fun { reg } -> chunks map reg) layout
- in Mcomp(chunks,layout)
+ let chunks = Chunk.union_map (fun { reg } -> chunks map reg) layout
+ in Mcomp(chunks,layout)
in map.chunk <- Rmap.add region.id chunk map.chunk ; chunk
diff --git a/src/plugins/wp/RegionAccess.ml b/src/plugins/wp/RegionAccess.ml
index 2e47b7ade3a1489e1f8640d2bcbf45a4a8a0b910..21f2c9ab90675ce2e82f634fa1fd50a26d84aff9 100644
--- a/src/plugins/wp/RegionAccess.ml
+++ b/src/plugins/wp/RegionAccess.ml
@@ -44,10 +44,10 @@ let pp_value fmt = function
| Pure -> Format.pp_print_string fmt "scalar"
| Read_at(_,r) -> Format.fprintf fmt "read %a" R.pretty r
| Addr_of a ->
- if a.shift then
- Format.fprintf fmt "addr %a+" R.pretty a.addrof
- else
- Format.fprintf fmt "addr %a" R.pretty a.addrof
+ if a.shift then
+ Format.fprintf fmt "addr %a+" R.pretty a.addrof
+ else
+ Format.fprintf fmt "addr %a" R.pretty a.addrof
[@@@ warning "+32"]
(* -------------------------------------------------------------------------- *)
@@ -67,8 +67,8 @@ let read acs = function
| Pure -> ()
| Addr_of _ -> ()
| Read_at(tr,r) ->
- acs_deref r (Value,tr) ;
- acs_read r acs
+ acs_deref r (Value,tr) ;
+ acs_read r acs
let points_to = function { shift ; addrof = pointed ; typeOfPointed = typ } ->
acs_deref pointed ((if shift then Array else Deref),typ)
@@ -76,19 +76,19 @@ let points_to = function { shift ; addrof = pointed ; typeOfPointed = typ } ->
let addrof map = function
| Pure -> failwith "Wp.Region: physical address"
| Read_at(tr,r) ->
- acs_deref r (Value,tr) ;
- {
- addrof = add_pointed map r ;
- typeOfPointed = Cil.typeOf_pointed tr ;
- shift = false ;
- }
+ acs_deref r (Value,tr) ;
+ {
+ addrof = add_pointed map r ;
+ typeOfPointed = Cil.typeOf_pointed tr ;
+ shift = false ;
+ }
| Addr_of addr -> addr
let cast ty value =
if Cil.isPointerType ty then
match value with
| Addr_of addr ->
- Addr_of { addr with typeOfPointed = Cil.typeOf_pointed ty }
+ Addr_of { addr with typeOfPointed = Cil.typeOf_pointed ty }
| Read_at (_,r) -> Read_at(ty,r)
| Pure -> Pure
else
@@ -122,16 +122,16 @@ let merge_addrof (map:map) v1 v2 =
let rec cc_exp (map:map) exp =
match exp.enode with
| BinOp( (PlusPI | MinusPI) , a , b , _ ) ->
- cc_read map b ;
- let { addrof = pointed } as addr = cc_addr map a in
- acs_shift pointed (Eval exp) ;
- Addr_of { addr with shift = true }
+ cc_read map b ;
+ let { addrof = pointed } as addr = cc_addr map a in
+ acs_shift pointed (Eval exp) ;
+ Addr_of { addr with shift = true }
| AddrOf lv | StartOf lv ->
- Addr_of {
- addrof = cc_lval map lv ;
- typeOfPointed = Cil.typeOfLval lv ;
- shift = false ;
- }
+ Addr_of {
+ addrof = cc_lval map lv ;
+ typeOfPointed = Cil.typeOfLval lv ;
+ shift = false ;
+ }
| Lval lv -> Read_at (Cil.typeOfLval lv , cc_lval map lv)
| CastE(ty,e) -> cast ty (cc_exp map e)
| Const (CStr _ | CWStr _) -> Addr_of (cc_string map exp)
@@ -139,18 +139,18 @@ let rec cc_exp (map:map) exp =
| SizeOf _ | SizeOfE _ | SizeOfStr _
| AlignOf _ | AlignOfE _ -> Pure
| UnOp(_,e,ty) ->
- assert (not (Cil.isPointerType ty)) ;
- cc_read map e ; Pure
+ assert (not (Cil.isPointerType ty)) ;
+ cc_read map e ; Pure
| BinOp(_,a,b,ty) ->
- assert (not (Cil.isPointerType ty)) ;
- cc_read map a ; cc_read map b ; Pure
+ assert (not (Cil.isPointerType ty)) ;
+ cc_read map a ; cc_read map b ; Pure
and cc_host map = function
| Var x -> of_cvar map x , x.vtype
| Mem e ->
- let a = cc_addr map e in
- points_to a ; (* deref, not read !*)
- a.addrof , a.typeOfPointed
+ let a = cc_addr map e in
+ points_to a ; (* deref, not read !*)
+ a.addrof , a.typeOfPointed
and cc_lval map (host , offset) =
let r,ty = cc_host map host in cc_offset map r ty offset
@@ -158,13 +158,13 @@ and cc_lval map (host , offset) =
and cc_offset map r ty = function
| Cil_types.NoOffset -> r
| Cil_types.Field(fd,ofs) ->
- let df = Offset.field fd in
- cc_offset map (add_offset map r df) fd.ftype ofs
+ let df = Offset.field fd in
+ cc_offset map (add_offset map r df) fd.ftype ofs
| Cil_types.Index(e,ofs) ->
- cc_read map e ;
- let de = Offset.index ty in
- let te = Offset.typeof de in
- cc_offset map (add_offset map r de) te ofs
+ cc_read map e ;
+ let de = Offset.index ty in
+ let te = Offset.typeof de in
+ cc_offset map (add_offset map r de) te ofs
and cc_addr map a = addrof map (cc_exp map a)
@@ -180,14 +180,14 @@ let cc_writes map stmt tgt typ e =
acs_write tgt (Assigned stmt) ;
match Cil.unrollType typ with
| TPtr _ ->
- let a = cc_addr map e in
- points_to a ; (* deref, not read! *)
- do_alias map a.addrof (add_pointed map tgt)
+ let a = cc_addr map e in
+ points_to a ; (* deref, not read! *)
+ do_alias map a.addrof (add_pointed map tgt)
| TComp _ ->
- let src = cc_comp map e in
- acs_copy ~src ~tgt
+ let src = cc_comp map e in
+ acs_copy ~src ~tgt
| _ ->
- cc_read map e
+ cc_read map e
let cc_assign map stmt lv e =
cc_writes map stmt (cc_lval map lv) (Cil.typeOfLval lv) e
@@ -202,10 +202,10 @@ let cc_return map stmt e =
let rec cc_init map stmt lv = function
| SingleInit e -> cc_assign map stmt lv e
| CompoundInit(_,content) ->
- List.iter
- (fun (ofs,vi) ->
- cc_init map stmt (Cil.addOffsetLval ofs lv) vi
- ) content
+ List.iter
+ (fun (ofs,vi) ->
+ cc_init map stmt (Cil.addOffsetLval ofs lv) vi
+ ) content
let cc_local_init map stmt x = function
| AssignInit vi -> cc_init map stmt (Var x,NoOffset) vi
@@ -237,33 +237,33 @@ let rec cc_term map t = read (Tval t) (cc_term_value map t)
and cc_term_value (map:map) (term:term) =
match term.term_node with
| TLval lv ->
- begin match cc_term_lval map lv with
- | None -> Pure
- | Some(ty,reg) -> Read_at(ty,reg)
- end
+ begin match cc_term_lval map lv with
+ | None -> Pure
+ | Some(ty,reg) -> Read_at(ty,reg)
+ end
| TAddrOf lv | TStartOf lv ->
- begin match cc_term_lval map lv with
- | None -> failwith "Wp.Region: pure term-value"
- | Some(ty,reg) -> Addr_of {
- addrof = reg ;
- typeOfPointed = ty ;
- shift = false ;
- }
- end
+ begin match cc_term_lval map lv with
+ | None -> failwith "Wp.Region: pure term-value"
+ | Some(ty,reg) -> Addr_of {
+ addrof = reg ;
+ typeOfPointed = ty ;
+ shift = false ;
+ }
+ end
| TBinOp( (PlusPI | MinusPI) , a , b ) ->
- begin
- cc_term map b ;
- let { addrof = pointed } as addr = cc_term_addr map a in
- acs_shift pointed (Tval term) ;
- Addr_of { addr with shift = true }
- end
+ begin
+ cc_term map b ;
+ let { addrof = pointed } as addr = cc_term_addr map a in
+ acs_shift pointed (Tval term) ;
+ Addr_of { addr with shift = true }
+ end
| Tnull ->
- Addr_of {
- addrof = Region.of_null map ;
- typeOfPointed = Cil.charType ;
- shift = false ;
- }
+ Addr_of {
+ addrof = Region.of_null map ;
+ typeOfPointed = Cil.charType ;
+ shift = false ;
+ }
| TUnOp(_,a) -> cc_term map a ; Pure
| TBinOp(_,a,b) -> cc_term map a ; cc_term map b ; Pure
@@ -281,61 +281,61 @@ and cc_term_value (map:map) (term:term) =
| TDataCons(_,ts) -> List.iter (cc_term map) ts ; Pure
| TUpdate(w,ofs,v) ->
- cc_term map w ;
- cc_term map v ;
- cc_term_offset_read map ofs ;
- Pure
+ cc_term map w ;
+ cc_term map v ;
+ cc_term_offset_read map ofs ;
+ Pure
| Tbase_addr(_at,t) -> cast Cil.voidPtrType @@ cc_term_value map t
| Tblock_length(_at,t) | Toffset(_at,t) -> cc_term map t ; Pure
| Tif(c,a,b) ->
- cc_term map c ;
- merge_addrof map (cc_term_value map a) (cc_term_value map b)
+ cc_term map c ;
+ merge_addrof map (cc_term_value map a) (cc_term_value map b)
| Tempty_set -> Pure
| Tunion ts | Tinter ts ->
- List.fold_left
- (fun v t -> merge_addrof map v (cc_term_value map t)) Pure ts
+ List.fold_left
+ (fun v t -> merge_addrof map v (cc_term_value map t)) Pure ts
| Tcomprehension(t,_,None) -> cc_term_value map t
| Tcomprehension(t,_,Some p) -> cc_pred map p ; cc_term_value map t
| Trange(a,b) -> cc_term_option map a ; cc_term_option map b ; Pure
| Tlet _ | Tlambda _ | Tapp _ ->
- failwith "Wp.Region: unsupported logic functions and bindings"
+ failwith "Wp.Region: unsupported logic functions and bindings"
and cc_term_lval map (lhost,loffset) =
match lhost with
| TResult typ -> Some(typ,of_return map)
| TVar lvar ->
- begin
- match lvar.lv_origin with
- | Some x ->
- let ty,rv = cc_term_offset map (of_cvar map x) x.vtype loffset in
- Some(ty,rv)
- | None ->
- cc_term_offset_read map loffset ;
- None
- end
+ begin
+ match lvar.lv_origin with
+ | Some x ->
+ let ty,rv = cc_term_offset map (of_cvar map x) x.vtype loffset in
+ Some(ty,rv)
+ | None ->
+ cc_term_offset_read map loffset ;
+ None
+ end
| TMem p ->
- begin
- let a = cc_term_addr map p in
- points_to a ;
- let ty,ra = cc_term_offset map a.addrof a.typeOfPointed loffset in
- Some(ty,ra)
- end
+ begin
+ let a = cc_term_addr map p in
+ points_to a ;
+ let ty,ra = cc_term_offset map a.addrof a.typeOfPointed loffset in
+ Some(ty,ra)
+ end
and cc_term_offset map r ty = function
| TNoOffset -> ty,r
| TField(fd,ofs) ->
- let df = Offset.field fd in
- cc_term_offset map (add_offset map r df) fd.ftype ofs
+ let df = Offset.field fd in
+ cc_term_offset map (add_offset map r df) fd.ftype ofs
| TIndex(t,ofs) ->
- cc_term map t ;
- let de = Offset.index ty in
- let te = Offset.typeof de in
- cc_term_offset map (add_offset map r de) te ofs
+ cc_term map t ;
+ let de = Offset.index ty in
+ let te = Offset.typeof de in
+ cc_term_offset map (add_offset map r de) te ofs
| TModel _ -> failwith "Wp.Region: model field"
and cc_term_offset_read map = function
@@ -357,13 +357,13 @@ and cc_pred (map:map) (p:predicate) =
| Pfalse | Ptrue -> ()
| Prel(_,a,b) ->
- cc_term map a ; cc_term map b
+ cc_term map a ; cc_term map b
| Pnot a -> cc_pred map a
| Pif(t,a,b) ->
- cc_term map t ; cc_pred map a ; cc_pred map b
+ cc_term map t ; cc_pred map a ; cc_pred map b
| Pand(a,b) | Por(a,b) | Pxor(a,b) | Pimplies(a,b) | Piff(a,b) ->
- cc_pred map a ; cc_pred map b
+ cc_pred map a ; cc_pred map b
| Pforall(_,p) | Pexists(_,p) -> cc_pred map p
@@ -376,7 +376,7 @@ and cc_pred (map:map) (p:predicate) =
| Pat(p,_at) -> cc_pred map p
| Plet _ | Papp _ ->
- failwith "Wp.Region: unsupported logic predicates and bindings"
+ failwith "Wp.Region: unsupported logic predicates and bindings"
(* -------------------------------------------------------------------------- *)
(* --- ACSL Spec & Defs --- *)
diff --git a/src/plugins/wp/RegionAnalysis.ml b/src/plugins/wp/RegionAnalysis.ml
index 4a0e8616936bd6d2458a5beef4f6b1cab76efd9d..26086422bf23a28056a33e901d15134461c4b205 100644
--- a/src/plugins/wp/RegionAnalysis.ml
+++ b/src/plugins/wp/RegionAnalysis.ml
@@ -84,10 +84,10 @@ module REGISTRY = State_builder.Hashtbl
let get = function
| None -> GLOBAL.get ()
| Some kf ->
- try REGISTRY.find kf
- with Not_found ->
- let map = compute kf in
- REGISTRY.add kf map ; map
+ try REGISTRY.find kf
+ with Not_found ->
+ let map = compute kf in
+ REGISTRY.add kf map ; map
(* ---------------------------------------------------------------------- *)
(* --- Command Line Registry --- *)
diff --git a/src/plugins/wp/RegionAnnot.ml b/src/plugins/wp/RegionAnnot.ml
index b8b16aa0c91609a331d673f6033ddca622279ba3..aed0a6fb8afa347ae58bf944c13de7994253881a 100644
--- a/src/plugins/wp/RegionAnnot.ml
+++ b/src/plugins/wp/RegionAnnot.ml
@@ -92,8 +92,8 @@ struct
| R_index _ , _ -> (-1)
| _ , R_index _ -> 1
| R_range(a1,b1) , R_range(a2,b2) ->
- let cmp = compare_bound a1 a2 in
- if cmp <> 0 then cmp else compare_bound b1 b2
+ let cmp = compare_bound a1 a2 in
+ if cmp <> 0 then cmp else compare_bound b1 b2
let rec compare a b =
match a.lnode , b.lnode with
@@ -104,8 +104,8 @@ struct
| L_region _ , _ -> (-1)
| _ , L_region _ -> 1
| L_star(ta,a) , L_star(tb,b) ->
- let cmp = Typ.compare ta tb in
- if cmp <> 0 then cmp else compare a b
+ let cmp = Typ.compare ta tb in
+ if cmp <> 0 then cmp else compare a b
| L_star _ , _ -> (-1)
| _ , L_star _ -> 1
| L_addr a , L_addr b -> compare a b
@@ -118,14 +118,14 @@ struct
| L_index _ , _ -> (-1)
| _ , L_index _ -> 1
| L_field(a,fs) , L_field(b,gs) ->
- let cmp = compare a b in
- if cmp <> 0 then cmp
- else Qed.Hcons.compare_list Fieldinfo.compare fs gs
+ let cmp = compare a b in
+ if cmp <> 0 then cmp
+ else Qed.Hcons.compare_list Fieldinfo.compare fs gs
| L_field _ , _ -> (-1)
| _ , L_field _ -> 1
| L_cast(ta,a) , L_cast(tb,b) ->
- let cmp = Typ.compare ta tb in
- if cmp <> 0 then cmp else compare a b
+ let cmp = Typ.compare ta tb in
+ if cmp <> 0 then cmp else compare a b
and compare_index a ta i b tb j =
let cmp = compare a b in
@@ -140,11 +140,11 @@ struct
let pp_range pp fmt = function
| R_index a -> pp fmt a
| R_range(a,b) ->
- begin
- pp_bound pp fmt a ;
- Format.fprintf fmt "@,.." ;
- pp_bound pp fmt b ;
- end
+ begin
+ pp_bound pp fmt a ;
+ Format.fprintf fmt "@,.." ;
+ pp_bound pp fmt b ;
+ end
let first = function [] -> assert false | f::_ -> f
let rec last = function [] -> assert false | [f] -> f | _::fs -> last fs
@@ -158,14 +158,14 @@ struct
| L_region a -> Format.pp_print_string fmt a
| L_field( p , [f] ) -> pfield pp p f fmt
| L_field( p , fs ) ->
- Format.fprintf fmt "@[<hov 2>(%t@,..%t)@]"
- (pfield pp p (first fs)) (pfield pp p (last fs))
+ Format.fprintf fmt "@[<hov 2>(%t@,..%t)@]"
+ (pfield pp p (first fs)) (pfield pp p (last fs))
| L_index(a,_,i) ->
- Format.fprintf fmt "@[<hov 2>%a@,[%a]@]"
- (pp_lval pp) a (pp_range pp) i
+ Format.fprintf fmt "@[<hov 2>%a@,[%a]@]"
+ (pp_lval pp) a (pp_range pp) i
| L_shift(a,_,i) ->
- Format.fprintf fmt "@[<hov 2>%a@,+(%a)@]"
- (pp_lpath pp) a (pp_range pp) i
+ Format.fprintf fmt "@[<hov 2>%a@,+(%a)@]"
+ (pp_lpath pp) a (pp_range pp) i
| L_star(_,a) -> Format.fprintf fmt "*%a" (pp_lval pp) a
| L_addr a -> Format.fprintf fmt "&%a" (pp_lval pp) a
| L_cast(t,a) -> Format.fprintf fmt "(%a)@,%a" Typ.pretty t (pp_lval pp) a
@@ -303,109 +303,109 @@ let sugar ~loc node = { lexpr_loc = loc ; lexpr_node = node }
let rec field_range ~inside fa fb = function
| [] -> []
| f::fs ->
- let bound = Fieldinfo.equal f fa || Fieldinfo.equal f fb in
- if inside then f :: (if bound then [] else field_range ~inside fa fb fs)
- else if bound then f :: (field_range ~inside:true fa fb fs)
- else field_range ~inside fa fb fs
+ let bound = Fieldinfo.equal f fa || Fieldinfo.equal f fb in
+ if inside then f :: (if bound then [] else field_range ~inside fa fb fs)
+ else if bound then f :: (field_range ~inside:true fa fb fs)
+ else field_range ~inside fa fb fs
let rec typeof_fields = function
| [] -> TVoid []
| [f] -> f.ftype
| f::fs ->
- let t = typeof_fields fs in
- if Typ.equal f.ftype t then t else TVoid []
+ let t = typeof_fields fs in
+ if Typ.equal f.ftype t then t else TVoid []
let rec parse_lpath env e =
let loc = e.lexpr_loc in
match e.lexpr_node with
| PLvar x ->
- if List.mem x env.declared
- then { loc ; lnode = L_region x ; ltype = TVoid [] }
- else
- let v = parse_varinfo env ~loc x in
- { loc ; lnode = L_var v ; ltype = v.vtype }
+ if List.mem x env.declared
+ then { loc ; lnode = L_region x ; ltype = TVoid [] }
+ else
+ let v = parse_varinfo env ~loc x in
+ { loc ; lnode = L_var v ; ltype = v.vtype }
| PLunop( Ustar , p ) ->
- let lv = parse_lpath env p in
- if Cil.isPointerType lv.ltype then
- let te = Cil.typeOf_pointed lv.ltype in
- { loc ; lnode = L_star(te,lv) ; ltype = te }
- else
- error env ~loc "Pointer-type expected for operator '&'"
+ let lv = parse_lpath env p in
+ if Cil.isPointerType lv.ltype then
+ let te = Cil.typeOf_pointed lv.ltype in
+ { loc ; lnode = L_star(te,lv) ; ltype = te }
+ else
+ error env ~loc "Pointer-type expected for operator '&'"
| PLunop( Uamp , p ) ->
- let lv = parse_lpath env p in
- let ltype = TPtr( lv.ltype , [] ) in
- { loc ; lnode = L_addr lv ; ltype }
+ let lv = parse_lpath env p in
+ let ltype = TPtr( lv.ltype , [] ) in
+ { loc ; lnode = L_addr lv ; ltype }
| PLbinop( p , Badd , r ) ->
- let { ltype } as lv = parse_lpath env p in
- let rg = parse_lrange env r in
- if Cil.isPointerType ltype then
- let te = Cil.typeOf_pointed ltype in
- { loc ; lnode = L_shift(lv,te,rg) ; ltype = ltype }
- else
- if Cil.isArrayType ltype then
- let te = Cil.typeOf_array_elem ltype in
- { loc ; lnode = L_shift(lv,te,rg) ; ltype = TPtr(te,[]) }
- else
- error env ~loc "Pointer-type expected for operator '+'"
+ let { ltype } as lv = parse_lpath env p in
+ let rg = parse_lrange env r in
+ if Cil.isPointerType ltype then
+ let te = Cil.typeOf_pointed ltype in
+ { loc ; lnode = L_shift(lv,te,rg) ; ltype = ltype }
+ else
+ if Cil.isArrayType ltype then
+ let te = Cil.typeOf_array_elem ltype in
+ { loc ; lnode = L_shift(lv,te,rg) ; ltype = TPtr(te,[]) }
+ else
+ error env ~loc "Pointer-type expected for operator '+'"
| PLdot( p , f ) ->
- let lv = parse_lpath env p in
- let comp = getCompoundType env ~loc:lv.loc lv.ltype in
- let fd = parse_fieldinfo env ~loc comp f in
- { loc ; lnode = L_field(lv,[fd]) ; ltype = fd.ftype }
+ let lv = parse_lpath env p in
+ let comp = getCompoundType env ~loc:lv.loc lv.ltype in
+ let fd = parse_fieldinfo env ~loc comp f in
+ { loc ; lnode = L_field(lv,[fd]) ; ltype = fd.ftype }
| PLarrow( p , f ) ->
- let sp = sugar ~loc (PLunop(Ustar,p)) in
- let pf = sugar ~loc (PLdot(sp,f)) in
- parse_lpath env pf
+ let sp = sugar ~loc (PLunop(Ustar,p)) in
+ let pf = sugar ~loc (PLdot(sp,f)) in
+ parse_lpath env pf
| PLarrget( p , k ) ->
- let { ltype } as lv = parse_lpath env p in
- let rg = parse_lrange env k in
- if Cil.isPointerType ltype then
- let pointed = Cil.typeOf_pointed ltype in
- let ls = { loc ; lnode = L_shift(lv,pointed,rg) ; ltype } in
- { loc ; lnode = L_star(pointed,ls) ; ltype = pointed }
- else
- if Cil.isArrayType ltype then
- let elt = Cil.typeOf_array_elem ltype in
- { loc ; lnode = L_index(lv,elt,rg) ; ltype = elt }
- else
- error env ~loc:lv.loc "Pointer or array type expected"
+ let { ltype } as lv = parse_lpath env p in
+ let rg = parse_lrange env k in
+ if Cil.isPointerType ltype then
+ let pointed = Cil.typeOf_pointed ltype in
+ let ls = { loc ; lnode = L_shift(lv,pointed,rg) ; ltype } in
+ { loc ; lnode = L_star(pointed,ls) ; ltype = pointed }
+ else
+ if Cil.isArrayType ltype then
+ let elt = Cil.typeOf_array_elem ltype in
+ { loc ; lnode = L_index(lv,elt,rg) ; ltype = elt }
+ else
+ error env ~loc:lv.loc "Pointer or array type expected"
| PLcast( t , a ) ->
- let lv = parse_lpath env a in
- let ty = parse_ltype env ~loc t in
- { loc ; lnode = L_cast(ty,lv) ; ltype = ty }
+ let lv = parse_lpath env a in
+ let ty = parse_ltype env ~loc t in
+ { loc ; lnode = L_cast(ty,lv) ; ltype = ty }
| PLrange( Some a , Some b ) ->
- let pa,fa = parse_fpath env a in
- let pb,fb = parse_fpath env b in
- let p =
- if Lpath.equal pa pb then pa
- else error env ~loc "Range of fields from different l-values" in
- let comp =
- if Compinfo.equal fa.fcomp fb.fcomp then fa.fcomp
- else error env ~loc "Range of fields from incompatible types" in
- let fields =
- field_range ~inside:false fa fb
- (Option.value ~default:[] comp.cfields)
- in
- let ltype = typeof_fields fields in
- { loc ; lnode = L_field(p,fields) ; ltype }
+ let pa,fa = parse_fpath env a in
+ let pb,fb = parse_fpath env b in
+ let p =
+ if Lpath.equal pa pb then pa
+ else error env ~loc "Range of fields from different l-values" in
+ let comp =
+ if Compinfo.equal fa.fcomp fb.fcomp then fa.fcomp
+ else error env ~loc "Range of fields from incompatible types" in
+ let fields =
+ field_range ~inside:false fa fb
+ (Option.value ~default:[] comp.cfields)
+ in
+ let ltype = typeof_fields fields in
+ { loc ; lnode = L_field(p,fields) ; ltype }
| PLrange( Some a , None ) ->
- let p,fd = parse_fpath env a in
- let fields =
- field_range ~inside:false fd fd
- (Option.value ~default:[] fd.fcomp.cfields)
- in
- let ltype = typeof_fields fields in
- { loc ; lnode = L_field(p,fields) ; ltype }
+ let p,fd = parse_fpath env a in
+ let fields =
+ field_range ~inside:false fd fd
+ (Option.value ~default:[] fd.fcomp.cfields)
+ in
+ let ltype = typeof_fields fields in
+ { loc ; lnode = L_field(p,fields) ; ltype }
| PLrange( None , Some a ) ->
- let p,fd = parse_fpath env a in
- let fields =
- field_range ~inside:true fd fd
- (Option.value ~default:[] fd.fcomp.cfields)
- in
- let ltype = typeof_fields fields in
- { loc ; lnode = L_field(p,fields) ; ltype }
+ let p,fd = parse_fpath env a in
+ let fields =
+ field_range ~inside:true fd fd
+ (Option.value ~default:[] fd.fcomp.cfields)
+ in
+ let ltype = typeof_fields fields in
+ { loc ; lnode = L_field(p,fields) ; ltype }
| _ ->
- error env ~loc "Unexpected expression for region spec"
+ error env ~loc "Unexpected expression for region spec"
and parse_fpath env p =
let lv = parse_lpath env p in
@@ -423,12 +423,12 @@ let registry = Hashtbl.create 0
let parse_pattern env ~loc names params =
match names with
| [name] ->
- let pattern =
- try List.assoc name patterns
- with Not_found -> error env ~loc "Unknown pattern '%s'" name in
- if params <> [] then
- error env ~loc "Unexpected parameters for pattern '%s'" name ;
- pattern
+ let pattern =
+ try List.assoc name patterns
+ with Not_found -> error env ~loc "Unknown pattern '%s'" name in
+ if params <> [] then
+ error env ~loc "Unexpected parameters for pattern '%s'" name ;
+ pattern
| [] -> error env ~loc "Missing pattern name"
| _ -> error env ~loc "Duplicate pattern names"
@@ -436,18 +436,18 @@ let rec parse_region env p =
let loc = p.lexpr_loc in
match p.lexpr_node with
| PLnamed( name , p ) ->
- flush env ;
- env.name <- Some name ;
- parse_region env p
+ flush env ;
+ env.name <- Some name ;
+ parse_region env p
| PLapp("\\pattern",names,params) ->
- let pattern = parse_pattern env ~loc names params in
- if env.pattern <> FREE && env.pattern <> pattern then
- error env ~loc "Duplicate pattern definition in region"
- else
- env.pattern <- pattern
+ let pattern = parse_pattern env ~loc names params in
+ if env.pattern <> FREE && env.pattern <> pattern then
+ error env ~loc "Duplicate pattern definition in region"
+ else
+ env.pattern <- pattern
| _ ->
- let path = parse_lpath env p in
- env.paths <- path :: env.paths
+ let path = parse_lpath env p in
+ env.paths <- path :: env.paths
let typecheck typing_context _loc ps =
let env = {
@@ -478,8 +478,8 @@ let of_behavior bhv =
let pp_extension printer fmt = function
| Ext_id k ->
- let spec = try Hashtbl.find registry k with Not_found -> [] in
- ignore (List.fold_left (pp_region_spec printer#term fmt) false spec)
+ let spec = try Hashtbl.find registry k with Not_found -> [] in
+ ignore (List.fold_left (pp_region_spec printer#term fmt) false spec)
| _ -> ()
let specified =
diff --git a/src/plugins/wp/RegionDump.ml b/src/plugins/wp/RegionDump.ml
index 37b36fb17f948f2248a7efe726b4972c94693b48..418d8cacb9a5f2e4b1db45bade0782170739ee7c 100644
--- a/src/plugins/wp/RegionDump.ml
+++ b/src/plugins/wp/RegionDump.ml
@@ -103,8 +103,8 @@ let dotcluster cluster : Dotgraph.record =
| Garbled -> `Label "Garbled"
| Chunk v -> dotvalue v
| Layout { sizeof ; layout } ->
- let label = Printf.sprintf "sizeof:%d" sizeof in
- `Hbox (`Label label :: List.map dotrange layout)
+ let label = Printf.sprintf "sizeof:%d" sizeof in
+ `Hbox (`Label label :: List.map dotrange layout)
let dotchunk mem : Dotgraph.record =
let open Layout in
@@ -113,12 +113,12 @@ let dotchunk mem : Dotgraph.record =
| Mraw(_,Some r) -> dotpointed ~label:"Raw" r
| Mref r -> dotpointed ~label:"Ref" r
| Mmem(rt,v) ->
- let prefix = if Layout.Root.indexed rt then "Mem " else "Var " in
- dotvalue ~prefix v
+ let prefix = if Layout.Root.indexed rt then "Mem " else "Var " in
+ dotvalue ~prefix v
| Mcomp(_,ovl) ->
- let range rg = dotrange
- ~prefix:(if Overlay.once rg.reg ovl then "D" else "C") rg in
- `Hbox (List.map range ovl)
+ let range rg = dotrange
+ ~prefix:(if Overlay.once rg.reg ovl then "D" else "C") rg in
+ `Hbox (List.map range ovl)
let dotregion dot map region node =
begin
@@ -215,14 +215,14 @@ let dotregion dot map region node =
(function
| Fvar _ -> ()
| Farray r ->
- G.edge dot (R.get r) node (`Label "[]"::attr_froms)
+ G.edge dot (R.get r) node (`Label "[]"::attr_froms)
| Fderef r ->
- G.edge dot (R.get r) node (`Label "*"::attr_froms)
+ G.edge dot (R.get r) node (`Label "*"::attr_froms)
| Findex r ->
- G.edge dot (R.get r) node (`Label "+(..)"::attr_froms)
+ G.edge dot (R.get r) node (`Label "+(..)"::attr_froms)
| Ffield(r,ofs) ->
- let label = Printf.sprintf "+%d" ofs in
- G.edge dot (R.get r) node (`Label label::attr_froms)
+ let label = Printf.sprintf "+%d" ofs in
+ G.edge dot (R.get r) node (`Label label::attr_froms)
) (Region.get_froms map region)
end ;
Region.iter_copies map
diff --git a/src/plugins/wp/Sigma.ml b/src/plugins/wp/Sigma.ml
index 603540c0223670216662927db246f2c694d39e5e..51a27a90efb22f96f635bbc999d5bc363f7e761b 100644
--- a/src/plugins/wp/Sigma.ml
+++ b/src/plugins/wp/Sigma.ml
@@ -89,15 +89,15 @@ struct
| [] -> assert false
(** If all the sigmas use the same variable *)
| (Used a)::l when List.for_all (function | Unused -> true | Used x -> Var.equal x a) l ->
- a
+ a
| _ ->
- let z = newchunk c in
- let map2 p = function
- | Unused -> p
- | Used a -> Passive.bind ~fresh:z ~bound:a p
- in
- p := List.map2 map2 !p l;
- z
+ let z = newchunk c in
+ let map2 p = function
+ | Unused -> p
+ | Used a -> Passive.bind ~fresh:z ~bound:a p
+ in
+ p := List.map2 map2 !p l;
+ z
in
let union = H.Map.mapi map union in
build union , !p
@@ -133,7 +133,7 @@ struct
if not (H.Set.mem chunk written) then
match x,y with
| Some x , Some y when x != y ->
- p := Bag.add (p_equal (e_var x) (e_var y)) !p
+ p := Bag.add (p_equal (e_var x) (e_var y)) !p
| Some x , None -> post.map <- H.Map.add chunk x post.map
| None , Some y -> pre.map <- H.Map.add chunk y pre.map
| _ -> ())
diff --git a/src/plugins/wp/Splitter.ml b/src/plugins/wp/Splitter.ml
index 5d1d851891994219e11b8820314efd750256f8db..b42081dcfaf7e1b1732d2c55704d9fa9e56a0f63 100644
--- a/src/plugins/wp/Splitter.ml
+++ b/src/plugins/wp/Splitter.ml
@@ -41,9 +41,9 @@ let pretty fmt = function
| CASE(_,[]) -> Format.fprintf fmt "Case(s)"
| CASE(_,[k]) -> Format.fprintf fmt "Case %s" (Int64.to_string k)
| CASE(_,k::ks) ->
- Format.fprintf fmt "@[Cases %s" (Int64.to_string k) ;
- List.iter (fun k -> Format.fprintf fmt ",@,%s" (Int64.to_string k)) ks ;
- Format.fprintf fmt "@]"
+ Format.fprintf fmt "@[Cases %s" (Int64.to_string k) ;
+ List.iter (fun k -> Format.fprintf fmt ",@,%s" (Int64.to_string k)) ks ;
+ Format.fprintf fmt "@]"
| CALL(_,kf) -> Format.fprintf fmt "Call %a" Kernel_function.pretty kf
| DEFAULT _ -> Format.fprintf fmt "Default"
| ASSERT(_,k,n) -> Format.fprintf fmt "Disjunction (%d/%d)" k n
@@ -62,21 +62,21 @@ let compare p q =
| ELSE _ , _ -> (-1)
| _ , ELSE _ -> 1
| CASE(s1,k1) , CASE(s2,k2) ->
- let c = Stmt.compare s1 s2 in
- if c = 0 then Stdlib.compare k1 k2 else c
+ let c = Stmt.compare s1 s2 in
+ if c = 0 then Stdlib.compare k1 k2 else c
| CASE _ , _ -> (-1)
| _ , CASE _ -> 1
| DEFAULT s , DEFAULT t -> Stmt.compare s t
| DEFAULT _ , _ -> (-1)
| _ , DEFAULT _ -> 1
| CALL(s1,f1) , CALL(s2,f2) ->
- let c = Stmt.compare s1 s2 in
- if c = 0 then Kernel_function.compare f1 f2 else c
+ let c = Stmt.compare s1 s2 in
+ if c = 0 then Kernel_function.compare f1 f2 else c
| CALL _ , _ -> (-1)
| _ , CALL _ -> 1
| ASSERT(ip1,k1,_) , ASSERT(ip2,k2,_) ->
- let c = Stdlib.compare ip1.ip_id ip2.ip_id in
- if c = 0 then k1 - k2 else c
+ let c = Stdlib.compare ip1.ip_id ip2.ip_id in
+ if c = 0 then k1 - k2 else c
(* -------------------------------------------------------------------------- *)
(* --- Assertion Disjunction --- *)
@@ -90,17 +90,17 @@ and unwrap p =
match p.pred_content with
| Por(a,b) -> disjunction a @ disjunction b
| Plet(f,a) ->
- List.map
- (fun q -> { p with pred_content = Plet(f,q) })
- (unwrap a)
+ List.map
+ (fun q -> { p with pred_content = Plet(f,q) })
+ (unwrap a)
| Pexists(qs,p) ->
- List.map
- (fun q -> { p with pred_content = Pexists(qs,q) })
- (unwrap p)
+ List.map
+ (fun q -> { p with pred_content = Pexists(qs,q) })
+ (unwrap p)
| Pat(p,l) ->
- List.map
- (fun q -> { p with pred_content = Pat(q,l) })
- (unwrap p)
+ List.map
+ (fun q -> { p with pred_content = Pat(q,l) })
+ (unwrap p)
| _ -> raise Exit
let predicate ip = ip.ip_content.tp_statement
@@ -143,17 +143,17 @@ type 'a t = 'a M.t
let rec compact merge = function
| ([] | [_]) as m -> m
| ( (k1,v1) as e )::(( (k2,v2)::r ) as m) ->
- if Tags.compare k1 k2 = 0 then
- collect merge k1 [v2;v1] r
- else
- e :: compact merge m
+ if Tags.compare k1 k2 = 0 then
+ collect merge k1 [v2;v1] r
+ else
+ e :: compact merge m
and collect merge k vs = function
| [] -> [k,merge vs]
| ((k',v')::r) as m ->
- if Tags.compare k k' = 0 then
- collect merge k (v'::vs) r
- else
- (k,merge vs) :: compact merge m
+ if Tags.compare k k' = 0 then
+ collect merge k (v'::vs) r
+ else
+ (k,merge vs) :: compact merge m
let bytags (k,_) (k',_) = Tags.compare k k'
@@ -180,34 +180,34 @@ let rec merge ~left ~both ~right m1 m2 =
| _,[] -> List.map (fun (k,v) -> k , left v) m1
| [],_ -> List.map (fun (k,v) -> k , right v) m2
| (k1,v1)::w1 , (k2,v2)::w2 ->
- let cmp = Tags.compare k1 k2 in
- if cmp < 0 then
- (k1 , left v1) :: merge ~left ~both ~right w1 m2
- else if cmp > 0 then
- (k2 , right v2) :: merge ~left ~both ~right m1 w2
- else
- (k1 , both v1 v2) :: merge ~left ~both ~right w1 w2
+ let cmp = Tags.compare k1 k2 in
+ if cmp < 0 then
+ (k1 , left v1) :: merge ~left ~both ~right w1 m2
+ else if cmp > 0 then
+ (k2 , right v2) :: merge ~left ~both ~right m1 w2
+ else
+ (k1 , both v1 v2) :: merge ~left ~both ~right w1 w2
let merge_all merge = function
| [] -> []
| [m] -> m
| [m1;m2] -> M.union (fun _ u v -> merge [u;v]) m1 m2
| ms ->
- let t = ref I.empty in
- List.iter
- (List.iter
- (fun (k,v) ->
- try
- let r = (I.find k !t) in r := v :: !r
- with Not_found ->
- t := I.add k (ref [v]) !t))
- ms ;
- I.fold
- (fun k r m -> match !r with
- | [] -> m
- | [v] -> (k,v)::m
- | vs -> (k,merge vs)::m)
- !t []
+ let t = ref I.empty in
+ List.iter
+ (List.iter
+ (fun (k,v) ->
+ try
+ let r = (I.find k !t) in r := v :: !r
+ with Not_found ->
+ t := I.add k (ref [v]) !t))
+ ms ;
+ I.fold
+ (fun k r m -> match !r with
+ | [] -> m
+ | [v] -> (k,v)::m
+ | vs -> (k,merge vs)::m)
+ !t []
let map = M.map
let iter = M.iter
diff --git a/src/plugins/wp/StmtSemantics.ml b/src/plugins/wp/StmtSemantics.ml
index 83b9e66d8605a49169b2b8672953a2df13ea7234..9a869be254529e65a19478ff2bf8cdcb1f79776e 100644
--- a/src/plugins/wp/StmtSemantics.ml
+++ b/src/plugins/wp/StmtSemantics.ml
@@ -141,9 +141,9 @@ struct
| [] -> goto (env @: Clabels.here) (env @: Clabels.next)
| [ elt ] -> f env elt
| stmt :: stmts ->
- let n = Cfg.node () in
- let paths = f (bind Clabels.next n env) stmt in
- paths @^ (sequence f (bind Clabels.here n env) stmts)
+ let n = Cfg.node () in
+ let paths = f (bind Clabels.next n env) stmt in
+ paths @^ (sequence f (bind Clabels.here n env) stmts)
let choice ?(pre=Clabels.here) ?(post=Clabels.next) f env =
let pre_node = env @: pre in
@@ -153,11 +153,11 @@ struct
let rec aux env ns = function
| [] -> goto (env @: pre) (env @: post)
| [ elt ] ->
- let n, paths = apply f env elt in
- paths @^ either pre_node (n :: ns)
+ let n, paths = apply f env elt in
+ paths @^ either pre_node (n :: ns)
| elt :: elts ->
- let n, paths = apply f env elt in
- paths @^ (aux env (n :: ns) elts)
+ let n, paths = apply f env elt in
+ paths @^ (aux env (n :: ns) elts)
in
aux env []
@@ -170,11 +170,11 @@ struct
let rec aux env ns = function
| [] -> goto (env @: pre) (env @: post)
| [ elt ] ->
- let n, (c,paths) = apply f env elt in
- paths @^ implies pre_node ((c,n) :: ns)
+ let n, (c,paths) = apply f env elt in
+ paths @^ implies pre_node ((c,n) :: ns)
| elt :: elts ->
- let n, (c,paths) = apply f env elt in
- paths @^ (aux env ((c,n) :: ns) elts)
+ let n, (c,paths) = apply f env elt in
+ paths @^ (aux env ((c,n) :: ns) elts)
in
aux env []
@@ -229,11 +229,11 @@ struct
match e_opt with
| None -> nop
| Some exp ->
- let rtyp = env.return in
- let here = Sigma.create () in
- let value = C.return here rtyp exp in
- let p = Lang.F.p_equal (Lang.F.e_var env.result) value in
- assume (Cfg.P.create (current env here) p)
+ let rtyp = env.return in
+ let here = Sigma.create () in
+ let value = C.return here rtyp exp in
+ let p = Lang.F.p_equal (Lang.F.e_var env.result) value in
+ assume (Cfg.P.create (current env here) p)
(* -------------------------------------------------------------------------- *)
(* --- Compiler: Assertion --- *)
@@ -347,18 +347,18 @@ struct
let result env = match lvr with
| None -> goto (env @: Clabels.here) (env @: Clabels.next)
| Some lv ->
- let pre = Sigma.create () in
- let tr = Cil.typeOfLval lv in
- let obj = Ctypes.object_of tr in
- let loc = C.lval pre lv in
- let post = Sigma.havoc pre (M.domain obj loc) in
- let vr = M.load post obj loc in
- let p =
- C.equal_typ tr vr
- (C.cast tr env.return (Val (Lang.F.e_var env.result)))
- in
- let e = Cfg.E.create { pre; post } p in
- effect (env @: Clabels.here) e (env @: Clabels.next)
+ let pre = Sigma.create () in
+ let tr = Cil.typeOfLval lv in
+ let obj = Ctypes.object_of tr in
+ let loc = C.lval pre lv in
+ let post = Sigma.havoc pre (M.domain obj loc) in
+ let vr = M.load post obj loc in
+ let p =
+ C.equal_typ tr vr
+ (C.cast tr env.return (Val (Lang.F.e_var env.result)))
+ in
+ let e = Cfg.E.create { pre; post } p in
+ effect (env @: Clabels.here) e (env @: Clabels.next)
in
let old_status = env.status in
@@ -409,18 +409,18 @@ struct
| Call (lv, e, es, _) -> call env lv e es
| Asm _ -> not_yet "[StmtSemantics] Inline Asm."
| Local_init (v, ConsInit(f, args, kind), loc) ->
- Cil.treat_constructor_as_func
- (fun lv e es _ -> call env lv e es)
- v f args kind loc
+ Cil.treat_constructor_as_func
+ (fun lv e es _ -> call env lv e es)
+ v f args kind loc
| Local_init (vi, AssignInit init, _) ->
- let here = Sigma.create () in
- let next = Sigma.create () in
- (*TODO: make something of warnings *)
- let init = C.init ~sigma:next vi (Some init) in
- let hyp_value = Lang.F.p_all (fun (_, h) -> fst h) init in
- let hyp_init = Lang.F.p_all (fun (_, h) -> snd h) init in
- let hyp = Lang.F.p_and hyp_init hyp_value in
- effect (env @: Clabels.here) (Cfg.E.create {pre=here; post=next} hyp) (env @: Clabels.next)
+ let here = Sigma.create () in
+ let next = Sigma.create () in
+ (*TODO: make something of warnings *)
+ let init = C.init ~sigma:next vi (Some init) in
+ let hyp_value = Lang.F.p_all (fun (_, h) -> fst h) init in
+ let hyp_init = Lang.F.p_all (fun (_, h) -> snd h) init in
+ let hyp = Lang.F.p_and hyp_init hyp_value in
+ effect (env @: Clabels.here) (Cfg.E.create {pre=here; post=next} hyp) (env @: Clabels.next)
| Skip _ | Code_annot _ -> goto (env @: Clabels.here) (env @: Clabels.next)
(* -------------------------------------------------------------------------- *)
@@ -483,11 +483,11 @@ struct
match authorized_region with
| None -> goto (env @: Clabels.here) (env @: Clabels.next)
| Some region ->
- let domain = A.domain region in
- let next = M.Sigma.havoc here domain in
- let seq = { pre = here; post = next } in
- let preds = A.apply_assigns seq region in
- effect (env @: Clabels.here) (Cfg.E.create seq (Lang.F.p_conj preds)) (env @: Clabels.next)
+ let domain = A.domain region in
+ let next = M.Sigma.havoc here domain in
+ let seq = { pre = here; post = next } in
+ let preds = A.apply_assigns seq region in
+ effect (env @: Clabels.here) (Cfg.E.create seq (Lang.F.p_conj preds)) (env @: Clabels.next)
and froms : env -> from list -> paths = fun env froms ->
assigns env (Writes froms)
@@ -524,35 +524,35 @@ struct
let open Interpreted_automata in
match tr with
| Skip | Enter { blocals = [] } | Leave { blocals = [] } ->
- goto (env @: Clabels.here) (env @: Clabels.next)
+ goto (env @: Clabels.here) (env @: Clabels.next)
| Enter {blocals} -> scope env Sigs.Enter blocals
| Leave {blocals} -> scope env Sigs.Leave blocals
| Return (r,_) -> return env r
| Prop ({kind = Assert|Invariant} as a, _) ->
- let env = Logic_label.Map.fold
- (fun logic_label vertex acc ->
- let c_label = Clabels.of_logic logic_label in
- let node = get_node nodes vertex in
- bind c_label node acc
- ) a.labels env in
- assert_ env a.predicate (WpPropId.mk_property a.property)
+ let env = Logic_label.Map.fold
+ (fun logic_label vertex acc ->
+ let c_label = Clabels.of_logic logic_label in
+ let node = get_node nodes vertex in
+ bind c_label node acc
+ ) a.labels env in
+ assert_ env a.predicate (WpPropId.mk_property a.property)
| Prop ({kind = Assume} as a, _)->
- let env = Logic_label.Map.fold
- (fun logic_label vertex acc ->
- let c_label = Clabels.of_logic logic_label in
- let node = get_node nodes vertex in
- bind c_label node acc
- ) a.labels env in
- assume (pred env `Negative a.predicate.ip_content.tp_statement) @^
- goto (env @: Clabels.here) (env @: Clabels.next)
+ let env = Logic_label.Map.fold
+ (fun logic_label vertex acc ->
+ let c_label = Clabels.of_logic logic_label in
+ let node = get_node nodes vertex in
+ bind c_label node acc
+ ) a.labels env in
+ assume (pred env `Negative a.predicate.ip_content.tp_statement) @^
+ goto (env @: Clabels.here) (env @: Clabels.next)
| Prop _ ->
- not_yet "[StmtSemantics] Annots other than 'assert'"
+ not_yet "[StmtSemantics] Annots other than 'assert'"
| Guard (exp,b,_) ->
- let here = Sigma.create () in
- let cond = C.cond here exp in
- let condition = Cfg.C.create here cond in
- (if b = Then then guard else guard')
- (env @: Clabels.here) condition (env @: Clabels.next)
+ let here = Sigma.create () in
+ let cond = C.cond here exp in
+ let condition = Cfg.C.create here cond in
+ (if b = Then then guard else guard')
+ (env @: Clabels.here) condition (env @: Clabels.next)
| Instr (i,_) -> instr env i
let rec get_invariants g n (l:Automata.t Wto.partition) =
@@ -563,8 +563,8 @@ struct
[(_,{edge_transition =
(Prop({kind=Assert|Invariant|Assume|Check},_) | Skip) as t},b)]
when Automata.equal a b ->
- let invs,l = get_invariants g b l in
- (t,a)::invs,l
+ let invs,l = get_invariants g b l in
+ (t,a)::invs,l
| _ -> [],(Wto.Node n)::l
let as_assumes l =
@@ -615,40 +615,40 @@ struct
let rec do_list ~fresh_nodes paths nodes n1 = function
| [] -> (n1,paths)
| (t,b)::l ->
- let n2, nodes =
- if fresh_nodes then
- let n2 = Cfg.node () in
- let nodes = add_local nodes b n2 in
- n2, nodes
- else (get_node nodes b), nodes
- in
- let paths = paths @^ transition (env @* [Clabels.here,n1;Clabels.next,n2]) nodes t in
- do_list ~fresh_nodes paths nodes n2 l
+ let n2, nodes =
+ if fresh_nodes then
+ let n2 = Cfg.node () in
+ let nodes = add_local nodes b n2 in
+ n2, nodes
+ else (get_node nodes b), nodes
+ in
+ let paths = paths @^ transition (env @* [Clabels.here,n1;Clabels.next,n2]) nodes t in
+ do_list ~fresh_nodes paths nodes n2 l
in
let rec component nodes paths = function
| Wto.Node ((n, _) as v) -> bind n (do_node nodes v) paths
| Wto.Component ((n, _) as v, l) ->
- let do_component (v, l) =
- assert (not (Automata.Map.mem v nodes.local));
- let invariants,l = get_invariants g v l in
- let n = get_node {nodes with local = Automata.Map.empty} v in
- (* initialization *)
- let n,paths = do_list ~fresh_nodes:true paths nodes n invariants in
- (* preservation *)
- let n_loop = Cfg.node () in
- let _,paths = do_list ~fresh_nodes:true paths nodes n_loop invariants in
- (* arbitrary number of loop *)
- let n_havoc = Cfg.node () in
- let havoc = Cfg.havoc n ~effects:{pre=n_havoc;post=n_loop} n_havoc in
- let paths = (havoc |> paths_of_cfg) @^ paths in
- (* body *)
- let invariants_as_assumes = as_assumes invariants in
- let _,paths =
- do_list ~fresh_nodes:false paths (add_local nodes v n_havoc)
- n_havoc invariants_as_assumes in
- partition (add_local nodes v n_loop) paths l
- in
- bind n do_component (v, l)
+ let do_component (v, l) =
+ assert (not (Automata.Map.mem v nodes.local));
+ let invariants,l = get_invariants g v l in
+ let n = get_node {nodes with local = Automata.Map.empty} v in
+ (* initialization *)
+ let n,paths = do_list ~fresh_nodes:true paths nodes n invariants in
+ (* preservation *)
+ let n_loop = Cfg.node () in
+ let _,paths = do_list ~fresh_nodes:true paths nodes n_loop invariants in
+ (* arbitrary number of loop *)
+ let n_havoc = Cfg.node () in
+ let havoc = Cfg.havoc n ~effects:{pre=n_havoc;post=n_loop} n_havoc in
+ let paths = (havoc |> paths_of_cfg) @^ paths in
+ (* body *)
+ let invariants_as_assumes = as_assumes invariants in
+ let _,paths =
+ do_list ~fresh_nodes:false paths (add_local nodes v n_havoc)
+ n_havoc invariants_as_assumes in
+ partition (add_local nodes v n_loop) paths l
+ in
+ bind n do_component (v, l)
and partition nodes paths l =
List.fold_left (component nodes) paths l
diff --git a/src/plugins/wp/Strategy.ml b/src/plugins/wp/Strategy.ml
index 88ed2a4367072c8c0bea9fbbec8955cc34da6021..2436374c3739ea78bc54bc3d28aee84aca86f027 100644
--- a/src/plugins/wp/Strategy.ml
+++ b/src/plugins/wp/Strategy.ml
@@ -56,15 +56,15 @@ let lookup_step env queue s =
match s.condition with
| State _ -> Empty
| When p | Have p | Init p | Core p | Type p ->
- let p = Lang.F.e_prop p in
- if p == env.target then Clause(Step s) else
- if lookup_term env p then Inside(Step s,env.target) else Empty
+ let p = Lang.F.e_prop p in
+ if p == env.target then Clause(Step s) else
+ if lookup_term env p then Inside(Step s,env.target) else Empty
| Branch(c,sa,sb) ->
- let p = Lang.F.e_prop c in
- if lookup_term env p then Inside(Step s,env.target) else
- ( Queue.add sa queue ; Queue.add sb queue ; Empty )
+ let p = Lang.F.e_prop c in
+ if lookup_term env p then Inside(Step s,env.target) else
+ ( Queue.add sa queue ; Queue.add sb queue ; Empty )
| Either cs ->
- List.iter (fun s -> Queue.add s queue) cs ; Empty
+ List.iter (fun s -> Queue.add s queue) cs ; Empty
exception Found of selection
diff --git a/src/plugins/wp/TacArray.ml b/src/plugins/wp/TacArray.ml
index a019c52959408fbdbbd385e2942b757e6eb9d98f..34860d996da377bd8980d8152de57104a164a0e9 100644
--- a/src/plugins/wp/TacArray.ml
+++ b/src/plugins/wp/TacArray.ml
@@ -32,10 +32,10 @@ let access_update_pattern e =
let open Qed.Logic in
match F.repr e with
| Aget(u,j) ->
- begin match F.repr u with
- | Aset(a,i,e) -> Some(a,i,e,j)
- | _ -> None
- end
+ begin match F.repr u with
+ | Aset(a,i,e) -> Some(a,i,e,j)
+ | _ -> None
+ end
| _ -> None
class array =
@@ -50,13 +50,13 @@ class array =
match access_update_pattern e with
| None -> Not_applicable
| Some(a,i,v,j) ->
- ignore feedback ;
- let at = Tactical.at s in
- let cases = [
- "Same Indices" , F.p_equal i j , e , v ;
- "Diff Indices" , F.p_neq i j , e , F.e_get a j ;
- ] in
- Applicable (Tactical.rewrite ?at cases)
+ ignore feedback ;
+ let at = Tactical.at s in
+ let cases = [
+ "Same Indices" , F.p_equal i j , e , v ;
+ "Diff Indices" , F.p_neq i j , e , F.e_get a j ;
+ ] in
+ Applicable (Tactical.rewrite ?at cases)
end
diff --git a/src/plugins/wp/TacBitrange.ml b/src/plugins/wp/TacBitrange.ml
index 3bf028ce7665b2d4adf78313de877b8d3e438e0e..2a9dcd09914afd3c3eb32f15c0413a7968baa664 100644
--- a/src/plugins/wp/TacBitrange.ml
+++ b/src/plugins/wp/TacBitrange.ml
@@ -190,11 +190,11 @@ let select_goal ~pland ~plor g =
let rec split_goals ~pland ~plor others ranges = function
| [] -> List.rev others , List.rev ranges
| g::gs ->
- begin
- match select_goal ~pland ~plor g with
- | None -> split_goals ~pland ~plor (F.p_bool g::others) ranges gs
- | Some g' -> split_goals ~pland ~plor others (g'::ranges) gs
- end
+ begin
+ match select_goal ~pland ~plor g with
+ | None -> split_goals ~pland ~plor (F.p_bool g::others) ranges gs
+ | Some g' -> split_goals ~pland ~plor others (g'::ranges) gs
+ end
let range_goal g' (hs,_) = ["bit-range" , (hs,g')]
let range_goals gs' (hs,_) = List.map (fun g' -> "bit-range" , (hs,g')) gs'
@@ -226,42 +226,42 @@ class bitrange =
method select feedback = function
| Clause(Goal p) ->
- begin
- let goals =
- let e = F.e_prop p in
- match F.repr e with
- | Qed.Logic.And es -> es
- | Qed.Logic.Leq _ | Qed.Logic.Lt _ -> [e]
- | _ -> raise Not_found
- in
- let pland = self#get_field (fst positive_land) in
- let plor = self#get_field (fst positive_lor) in
- let others,ranges = split_goals ~pland ~plor [] [] goals in
- if ranges = [] then Tactical.Not_applicable else
- begin
- if others = [] then
- feedback#set_title "Split & Bit Range(s)"
- else
- feedback#set_title "Bit Range(s)" ;
- Tactical.Applicable
- (fun seq -> other_goals others seq @
- range_goals ranges seq)
- end
- end
+ begin
+ let goals =
+ let e = F.e_prop p in
+ match F.repr e with
+ | Qed.Logic.And es -> es
+ | Qed.Logic.Leq _ | Qed.Logic.Lt _ -> [e]
+ | _ -> raise Not_found
+ in
+ let pland = self#get_field (fst positive_land) in
+ let plor = self#get_field (fst positive_lor) in
+ let others,ranges = split_goals ~pland ~plor [] [] goals in
+ if ranges = [] then Tactical.Not_applicable else
+ begin
+ if others = [] then
+ feedback#set_title "Split & Bit Range(s)"
+ else
+ feedback#set_title "Bit Range(s)" ;
+ Tactical.Applicable
+ (fun seq -> other_goals others seq @
+ range_goals ranges seq)
+ end
+ end
| Inside(Goal p,e) ->
- begin
- let g = F.e_prop p in
- match F.repr g with
- | Qed.Logic.And es when List.memq e es ->
- begin
- let pland = self#get_field (fst positive_land) in
- let plor = self#get_field (fst positive_lor) in
- match select_goal ~pland ~plor g with
- | Some g' -> Tactical.Applicable(range_goal g')
- | None -> Tactical.Not_applicable
- end
- | _ -> Tactical.Not_applicable
- end
+ begin
+ let g = F.e_prop p in
+ match F.repr g with
+ | Qed.Logic.And es when List.memq e es ->
+ begin
+ let pland = self#get_field (fst positive_land) in
+ let plor = self#get_field (fst positive_lor) in
+ match select_goal ~pland ~plor g with
+ | Some g' -> Tactical.Applicable(range_goal g')
+ | None -> Tactical.Not_applicable
+ end
+ | _ -> Tactical.Not_applicable
+ end
| _ -> Tactical.Not_applicable
end
@@ -290,7 +290,7 @@ class autobitrange =
let open Qed.Logic in
match F.e_expr goal with
| Lt(x,y) | Leq(x,y) when is_bitwised x || is_bitwised y ->
- push (strategy Tactical.(Clause (Goal goal)))
+ push (strategy Tactical.(Clause (Goal goal)))
| _ -> ()
end
diff --git a/src/plugins/wp/TacBittest.ml b/src/plugins/wp/TacBittest.ml
index 683746d8c39d5ccbea105b5a49a8639874f4f573..d971f45ba62e7400e663cb7da896d695c9ba943f 100644
--- a/src/plugins/wp/TacBittest.ml
+++ b/src/plugins/wp/TacBittest.ml
@@ -39,11 +39,11 @@ let rec lookup_bittest e =
match F.repr e with
| Not e -> lookup_bittest e
| Fun(f,[n;ek]) when List.memq f Cint.f_bits ->
- begin
- match lookup_int ek with
- | Some k when 0 <= k && k < 128 -> Some (n,k)
- | _ -> None
- end
+ begin
+ match lookup_int ek with
+ | Some k when 0 <= k && k < 128 -> Some (n,k)
+ | _ -> None
+ end
| _ -> None
(* -------------------------------------------------------------------------- *)
@@ -62,21 +62,21 @@ class bittestrange =
let e = Tactical.selected selection in
match lookup_bittest e with
| Some (n,k) ->
- let bit = Cint.bit_test n k in
- let bit_set = F.p_bool bit in
- let bit_clear = F.p_not bit_set in
- let pos = positive n in
- let pk = power k in
- let pk1 = power (succ k) in
- let g_inf = F.p_hyps [pos] (F.p_leq pk n) in
- let g_sup = F.p_hyps [pos;F.p_lt n pk1] (F.p_lt n pk) in
- let name_inf = Printf.sprintf "Bit #%d (inf)" k in
- let name_sup = Printf.sprintf "Bit #%d (sup)" k in
- let at = Tactical.at selection in
- Tactical.Applicable (Tactical.insert ?at [
- name_inf , F.p_and bit_set g_inf ;
- name_sup , F.p_and bit_clear g_sup ;
- ])
+ let bit = Cint.bit_test n k in
+ let bit_set = F.p_bool bit in
+ let bit_clear = F.p_not bit_set in
+ let pos = positive n in
+ let pk = power k in
+ let pk1 = power (succ k) in
+ let g_inf = F.p_hyps [pos] (F.p_leq pk n) in
+ let g_sup = F.p_hyps [pos;F.p_lt n pk1] (F.p_lt n pk) in
+ let name_inf = Printf.sprintf "Bit #%d (inf)" k in
+ let name_sup = Printf.sprintf "Bit #%d (sup)" k in
+ let at = Tactical.at selection in
+ Tactical.Applicable (Tactical.insert ?at [
+ name_inf , F.p_and bit_set g_inf ;
+ name_sup , F.p_and bit_clear g_sup ;
+ ])
| None -> Tactical.Not_applicable
end
@@ -94,12 +94,12 @@ let rec lookup push step e =
| Or es -> List.iter (lookup push step) es
| Imply (hs,p) -> List.iter (lookup push step) (p::hs)
| _ ->
- begin
- match lookup_bittest e with
- | None -> ()
- | Some _ ->
- push @@ strategy ~priority:0.3 (Tactical.Inside(step,e))
- end
+ begin
+ match lookup_bittest e with
+ | None -> ()
+ | Some _ ->
+ push @@ strategy ~priority:0.3 (Tactical.Inside(step,e))
+ end
class autobittestrange : Strategy.heuristic =
object
diff --git a/src/plugins/wp/TacBitwised.ml b/src/plugins/wp/TacBitwised.ml
index aba8d792d84b36129b8c071d8014ff3806c72998..7d7e105a818c58397e691e25f5ec8c15f3075684 100644
--- a/src/plugins/wp/TacBitwised.ml
+++ b/src/plugins/wp/TacBitwised.ml
@@ -103,15 +103,15 @@ let rec lookup push clause ~nbits ~priority p =
let open Qed.Logic in
match F.repr p with
| And ps | Or ps ->
- List.iter (lookup push clause ~priority ~nbits) ps
+ List.iter (lookup push clause ~priority ~nbits) ps
| Imply(hs,p) ->
- List.iter (lookup push clause ~priority ~nbits) (p::hs)
+ List.iter (lookup push clause ~priority ~nbits) (p::hs)
| Eq(x,y) | Neq(x,y) when F.is_int x && F.is_int y ->
- let bx = is_bitwised x in
- let by = is_bitwised y in
- if bx || by then
- let priority = if bx && by then priority else priority *. 0.8 in
- push (strategy ~priority ~nbits Tactical.(Inside(clause,p)))
+ let bx = is_bitwised x in
+ let by = is_bitwised y in
+ if bx || by then
+ let priority = if bx && by then priority else priority *. 0.8 in
+ push (strategy ~priority ~nbits Tactical.(Inside(clause,p)))
| _ -> ()
class autobitwise =
diff --git a/src/plugins/wp/TacChoice.ml b/src/plugins/wp/TacChoice.ml
index 28ba26f16aed2a59c62767c2ce30958d782fd219..4a5a7930f07cb6b689a9cce86ea7b14d5a312c71 100644
--- a/src/plugins/wp/TacChoice.ml
+++ b/src/plugins/wp/TacChoice.ml
@@ -39,14 +39,14 @@ class choice =
method select _feedback (s : Tactical.selection) =
match s with
| Inside(Goal p,q) ->
- begin
- match F.e_expr p with
- | Qed.Logic.Or qs when List.memq q qs ->
- Applicable (fun (hs,_) -> ["Choice",(hs,F.p_bool q)])
- | _ -> Not_applicable
- end
+ begin
+ match F.e_expr p with
+ | Qed.Logic.Or qs when List.memq q qs ->
+ Applicable (fun (hs,_) -> ["Choice",(hs,F.p_bool q)])
+ | _ -> Not_applicable
+ end
| Empty | Compose _ | Clause _ | Inside(Step _,_) | Multi _ ->
- Not_applicable
+ Not_applicable
end
class absurd =
@@ -62,17 +62,17 @@ class absurd =
| Empty | Compose _ | Inside _ | Clause(Goal _) | Multi _
-> Not_applicable
| Clause(Step s) ->
- begin
- match s.condition with
- | Have p | When p | Core p | Init p | Type p ->
- let absurd seq =
- let emp = Conditions.(step (Have F.p_true)) in
- let seq = Conditions.replace ~at:s.id emp seq in
- [ "Absurd" , (fst seq , F.p_not p) ]
- in Applicable absurd
- | Branch _ | Either _ | State _ ->
- Not_applicable
- end
+ begin
+ match s.condition with
+ | Have p | When p | Core p | Init p | Type p ->
+ let absurd seq =
+ let emp = Conditions.(step (Have F.p_true)) in
+ let seq = Conditions.replace ~at:s.id emp seq in
+ [ "Absurd" , (fst seq , F.p_not p) ]
+ in Applicable absurd
+ | Branch _ | Either _ | State _ ->
+ Not_applicable
+ end
end
class contrapose =
@@ -88,19 +88,19 @@ class contrapose =
| Empty | Compose _ | Inside _ | Clause(Goal _) | Multi _
-> Not_applicable
| Clause(Step s) ->
- begin
- match s.condition with
- | Have p | When p | Core p | Init p | Type p ->
- let contrapose (hs,goal) =
- let descr = "Contrapose" in
- let goal = F.p_not goal in
- let goal = Conditions.(step ~descr (Have goal)) in
- let hs = Conditions.replace ~at:s.id goal (hs , F.p_false) in
- [ "Contrapose" , (fst hs , F.p_not p) ]
- in Applicable contrapose
- | Branch _ | Either _ | State _ ->
- Not_applicable
- end
+ begin
+ match s.condition with
+ | Have p | When p | Core p | Init p | Type p ->
+ let contrapose (hs,goal) =
+ let descr = "Contrapose" in
+ let goal = F.p_not goal in
+ let goal = Conditions.(step ~descr (Have goal)) in
+ let hs = Conditions.replace ~at:s.id goal (hs , F.p_false) in
+ [ "Contrapose" , (fst hs , F.p_not p) ]
+ in Applicable contrapose
+ | Branch _ | Either _ | State _ ->
+ Not_applicable
+ end
end
diff --git a/src/plugins/wp/TacClear.ml b/src/plugins/wp/TacClear.ml
index 73f33b2e8cfbbac93770098b6c48f349f1013dc7..19f9f1371e104adc4472b27b57c9d9dbeec2654e 100644
--- a/src/plugins/wp/TacClear.ml
+++ b/src/plugins/wp/TacClear.ml
@@ -46,10 +46,10 @@ let tactical_inside step remove =
in
begin match step.condition with
| Type p | Have p | When p | Core p | Init p ->
- let ps = Lang.F.e_props @@ collect p in
- let ps = TermLset.diff ps remove in
- let cond = condition step @@ Lang.F.p_bool @@ Lang.F.e_and ps in
- Tactical.replace_single ~at:step.id ("Filtered", cond)
+ let ps = Lang.F.e_props @@ collect p in
+ let ps = TermLset.diff ps remove in
+ let cond = condition step @@ Lang.F.p_bool @@ Lang.F.e_and ps in
+ Tactical.replace_single ~at:step.id ("Filtered", cond)
| _ -> raise Not_found
end
@@ -62,11 +62,11 @@ module Smap = Qed.Idxmap.Make
let collect_remove m = function
| Inside(Step step, remove) ->
- let l =
- try Smap.find step m
- with Not_found -> []
- in
- Smap.add step (remove :: l) m
+ let l =
+ try Smap.find step m
+ with Not_found -> []
+ in
+ Smap.add step (remove :: l) m
| _ -> raise Not_found
let fold_selection s seq =
@@ -85,14 +85,14 @@ class clear =
method select _feedback sel =
match sel with
| Clause(Step step) ->
- Applicable(process @@ tactical_step step)
+ Applicable(process @@ tactical_step step)
| Inside(Step step, remove) ->
- begin
- try Applicable(process @@ tactical_inside step [remove])
- with Not_found -> Not_applicable
- end
+ begin
+ try Applicable(process @@ tactical_inside step [remove])
+ with Not_found -> Not_applicable
+ end
| Multi es ->
- Applicable (process @@ fold_selection es)
+ Applicable (process @@ fold_selection es)
| _ -> Not_applicable
end
diff --git a/src/plugins/wp/TacCompound.ml b/src/plugins/wp/TacCompound.ml
index 53c984d681cfecf23fc3cf4d69f7318e37b59544..c19276d95bb836f528d6369b52e60c113c709c87 100644
--- a/src/plugins/wp/TacCompound.ml
+++ b/src/plugins/wp/TacCompound.ml
@@ -96,11 +96,11 @@ let get_compound_cmp a b =
| None -> match get_record_term b with
| Some fs -> Record(a,b,fs)
| None ->
- match get_array_update a , get_array_update b with
- | None , None -> raise Not_found
- | Some upd , None -> array1 upd b
- | None , Some upd -> array1 upd a
- | Some p , Some q -> array2 p q
+ match get_array_update a , get_array_update b with
+ | None , None -> raise Not_found
+ | Some upd , None -> array1 upd b
+ | None , Some upd -> array1 upd a
+ | Some p , Some q -> array2 p q
let get_compound_equality e =
match F.repr e with
@@ -128,15 +128,15 @@ let get2 a b k = F.p_equal (F.e_get a k) (F.e_get b k)
let clause ~pool = function
| Record(a,b,fs) -> List.map (field a b) fs
| Array1((a,i,u),b,t) ->
- let ks,k = index ~pool t in
- [ "Updated" , get1 b i u ;
- "Others" , F.p_forall ks (neq i k (get2 a b k)) ]
+ let ks,k = index ~pool t in
+ [ "Updated" , get1 b i u ;
+ "Others" , F.p_forall ks (neq i k (get2 a b k)) ]
| Array2((a,i,u),(b,j,v),t) ->
- let ks,k = index ~pool t in
- [ "Updated (both)" , eq i j (F.p_equal u v) ;
- "Updated (left)" , neq i j (get1 a j v) ;
- "Updated (right)" , neq i j (get1 b i u) ;
- "Others" , F.p_forall ks (neq i k (neq j k (get2 a b k))) ]
+ let ks,k = index ~pool t in
+ [ "Updated (both)" , eq i j (F.p_equal u v) ;
+ "Updated (left)" , neq i j (get1 a j v) ;
+ "Updated (right)" , neq i j (get1 b i u) ;
+ "Others" , F.p_forall ks (neq i k (neq j k (get2 a b k))) ]
(* -------------------------------------------------------------------------- *)
(* --- Compound Tactic --- *)
diff --git a/src/plugins/wp/TacCongruence.ml b/src/plugins/wp/TacCongruence.ml
index 3641f4387e5d7e6ecef8e181d57ec21a9339ede9..c602887bccf67a85f36dd168a7e279c3f233627d 100644
--- a/src/plugins/wp/TacCongruence.ml
+++ b/src/plugins/wp/TacCongruence.ml
@@ -37,16 +37,16 @@ let pattern e =
| Times(k,e) when F.is_int e -> IMUL_K(k,e)
| Div(a,b) when not (F.is_int e) -> QDIV(a,b)
| Div(a,b) when F.is_int e ->
- begin match F.repr b with
- | Kint k ->
- if Integer.(equal k zero) then raise Not_found ;
- IDIV_K(a,k)
- | _ -> Ival(e,None)
- end
+ begin match F.repr b with
+ | Kint k ->
+ if Integer.(equal k zero) then raise Not_found ;
+ IDIV_K(a,k)
+ | _ -> Ival(e,None)
+ end
| _ ->
- if F.is_int e then Ival(e,None) else
- if F.is_real e then Rval e else
- raise Not_found
+ if F.is_int e then Ival(e,None) else
+ if F.is_real e then Rval e else
+ raise Not_found
(*
let pp_pattern fmt = function
| Ival(_,Some z) -> Format.fprintf fmt "(%s : constant)" (Integer.to_string z)
@@ -102,46 +102,46 @@ let compare_div cmp a b g =
let rec compare cmp a b =
match a, b with
| IMUL_K( k,a ) , Ival(_,Some n) ->
- if Integer.(lt zero k) then compare cmp (pattern a) (pdiv n k) else
- if Integer.(lt k zero) then compare cmp (pdiv n k) (pattern a) else
- if icmp cmp Integer.zero n then F.p_true else F.p_false
+ if Integer.(lt zero k) then compare cmp (pattern a) (pdiv n k) else
+ if Integer.(lt k zero) then compare cmp (pdiv n k) (pattern a) else
+ if icmp cmp Integer.zero n then F.p_true else F.p_false
| Ival(_,Some n) , IMUL_K( k,a ) ->
- if Integer.(lt zero k) then compare cmp (pdiv n k) (pattern a) else
- if Integer.(lt k zero) then compare cmp (pattern a) (pdiv n k) else
- if icmp cmp Integer.zero n then F.p_true else F.p_false
+ if Integer.(lt zero k) then compare cmp (pdiv n k) (pattern a) else
+ if Integer.(lt k zero) then compare cmp (pattern a) (pdiv n k) else
+ if icmp cmp Integer.zero n then F.p_true else F.p_false
| IDIV_K( a,k ) , Ival(b,_) ->
- if Integer.(lt zero k) then
- let c = F.e_times k (F.e_add b F.e_one) in
- fcmp cmp a c
- else
- if Integer.(lt k zero) then
- let c = F.e_times k (F.e_sub b F.e_one) in
- fcmp cmp c a
- else
- raise Not_found
+ if Integer.(lt zero k) then
+ let c = F.e_times k (F.e_add b F.e_one) in
+ fcmp cmp a c
+ else
+ if Integer.(lt k zero) then
+ let c = F.e_times k (F.e_sub b F.e_one) in
+ fcmp cmp c a
+ else
+ raise Not_found
| Ival(a,_) , IDIV_K( b,k ) ->
- if Integer.(lt zero k) then
- let c = F.e_times k (F.e_sub a F.e_one) in
- fcmp cmp c b
- else
- if Integer.(lt k zero) then
- let c = F.e_times k (F.e_add a F.e_one) in
- fcmp cmp b c
- else
- raise Not_found
+ if Integer.(lt zero k) then
+ let c = F.e_times k (F.e_sub a F.e_one) in
+ fcmp cmp c b
+ else
+ if Integer.(lt k zero) then
+ let c = F.e_times k (F.e_add a F.e_one) in
+ fcmp cmp b c
+ else
+ raise Not_found
| IDIV_K( a,p ) , IDIV_K( b,q ) when
not Integer.(equal p zero) &&
not Integer.(equal q zero) ->
- let g = Integer.pgcd (Integer.abs p) (Integer.abs q) in
- let ka = Integer.e_div p g in
- let kb = Integer.e_div q g in
- compare_div cmp (F.e_times ka a) (F.e_times kb b) (F.e_zint g)
+ let g = Integer.pgcd (Integer.abs p) (Integer.abs q) in
+ let ka = Integer.e_div p g in
+ let kb = Integer.e_div q g in
+ compare_div cmp (F.e_times ka a) (F.e_times kb b) (F.e_zint g)
| QDIV(a,u) , QDIV(b,v) -> compare_ratio cmp a u b v
| QDIV(a,u) , (Ival(b,_) | Rval b) -> compare_ratio cmp a u b F.e_one
| (Ival(a,_) | Rval a) , QDIV(b,v) -> compare_ratio cmp a F.e_one b v
| _ ->
- raise Not_found
+ raise Not_found
let eq_ratio eq a u b v =
F.p_conj [ nzero u ; nzero v ; eq (F.e_mul a v) (F.e_mul b u) ]
@@ -150,23 +150,23 @@ let rec equal eq a b =
match a , b with
| IMUL_K( k,a ) , Ival(_,Some n)
| Ival(_,Some n) , IMUL_K( k,a ) ->
- let r = Integer.c_rem k n in
- if Integer.equal r Integer.zero then
- equal eq (pattern a) (pdiv n k)
- else
- eq F.e_one F.e_zero
+ let r = Integer.c_rem k n in
+ if Integer.equal r Integer.zero then
+ equal eq (pattern a) (pdiv n k)
+ else
+ eq F.e_one F.e_zero
| IMUL_K( k,a ) , IMUL_K( k',b ) ->
- let r = Integer.pgcd k k' in
- eq (F.e_times (Integer.c_div k r) a)
- (F.e_times (Integer.c_div k' r) b)
+ let r = Integer.pgcd k k' in
+ eq (F.e_times (Integer.c_div k r) a)
+ (F.e_times (Integer.c_div k' r) b)
| IDIV_K( a,p ) , IDIV_K( b,q ) when
not Integer.(equal p zero) &&
not Integer.(equal q zero) ->
- let g = Integer.pgcd (Integer.abs p) (Integer.abs q) in
- let ka = Integer.e_div p g in
- let kb = Integer.e_div q g in
- compare_div EQ (F.e_times ka a) (F.e_times kb b) (F.e_zint g)
+ let g = Integer.pgcd (Integer.abs p) (Integer.abs q) in
+ let ka = Integer.e_div p g in
+ let kb = Integer.e_div q g in
+ compare_div EQ (F.e_times ka a) (F.e_times kb b) (F.e_zint g)
| QDIV(a,u) , QDIV(b,v) -> eq_ratio eq a u b v
| QDIV(a,u) , (Ival(b,_) | Rval b) -> eq_ratio eq a u b F.e_one
@@ -191,10 +191,10 @@ class congruence =
method select _feedback = function
| Tactical.Clause(Tactical.Goal p) ->
- let q = select p in
- if q != p
- then Tactical.Applicable(fun seq -> ["congruence" , (fst seq , q)])
- else Tactical.Not_applicable
+ let q = select p in
+ if q != p
+ then Tactical.Applicable(fun seq -> ["congruence" , (fst seq , q)])
+ else Tactical.Not_applicable
| _ -> Tactical.Not_applicable
end
diff --git a/src/plugins/wp/TacCut.ml b/src/plugins/wp/TacCut.ml
index 16f3233837d88b305183fc9177696b48b1155c78..ce748978280b114c5bfa1e30542aac145d60a8fa 100644
--- a/src/plugins/wp/TacCut.ml
+++ b/src/plugins/wp/TacCut.ml
@@ -60,35 +60,35 @@ class cut =
let mode =
match sel with
| Clause(Goal p) when p != F.p_false ->
- feedback#update_field ~enabled:false fmode ; CASES
+ feedback#update_field ~enabled:false fmode ; CASES
| _ ->
- feedback#update_field ~enabled:true fmode ;
- self#get_field fmode in
+ feedback#update_field ~enabled:true fmode ;
+ self#get_field fmode in
let cut = self#get_field fclause in
if Tactical.is_empty cut then
Not_configured
else
match mode with
| MODUS ->
- feedback#set_descr "Prove then Insert the Clause" ;
- let clause = F.p_bool (Tactical.selected cut) in
- let step = Conditions.step ~descr:"Cut" (Have clause) in
- let at = Tactical.at sel in
- Applicable
- begin fun sequent ->
- let assume = Conditions.insert ?at step sequent in
- [ "Clause" , (fst sequent,clause) ;
- "Assume" , (fst assume,snd sequent) ]
- end
+ feedback#set_descr "Prove then Insert the Clause" ;
+ let clause = F.p_bool (Tactical.selected cut) in
+ let step = Conditions.step ~descr:"Cut" (Have clause) in
+ let at = Tactical.at sel in
+ Applicable
+ begin fun sequent ->
+ let assume = Conditions.insert ?at step sequent in
+ [ "Clause" , (fst sequent,clause) ;
+ "Assume" , (fst assume,snd sequent) ]
+ end
| CASES ->
- feedback#set_descr "Proof by Case in the Clause" ;
- let positive = F.p_bool (Tactical.selected cut) in
- let negative = F.p_not positive in
- Applicable
- begin fun (hs,goal) ->
- [ "Positive" , (hs,F.p_imply positive goal) ;
- "Negative" , (hs,F.p_imply negative goal) ]
- end
+ feedback#set_descr "Proof by Case in the Clause" ;
+ let positive = F.p_bool (Tactical.selected cut) in
+ let negative = F.p_not positive in
+ Applicable
+ begin fun (hs,goal) ->
+ [ "Positive" , (hs,F.p_imply positive goal) ;
+ "Negative" , (hs,F.p_imply negative goal) ]
+ end
end
let tactical = Tactical.export (new cut)
diff --git a/src/plugins/wp/TacHavoc.ml b/src/plugins/wp/TacHavoc.ml
index 785aebf8552f6759e6a8619778973e78181589f8..67b441c0db981c2c9ccd258bf91099a7e0241796 100644
--- a/src/plugins/wp/TacHavoc.ml
+++ b/src/plugins/wp/TacHavoc.ml
@@ -33,12 +33,12 @@ module L = Qed.Logic
let lookup_havoc e =
match F.repr e with
| L.Aget( m , p ) ->
- begin
- match F.repr m with
- | L.Fun( f , [m_undef;m_sep;a;n] ) when f == MemMemory.f_havoc ->
- Some( m_undef , m_sep , a , n , p )
- | _ -> None
- end
+ begin
+ match F.repr m with
+ | L.Fun( f , [m_undef;m_sep;a;n] ) when f == MemMemory.f_havoc ->
+ Some( m_undef , m_sep , a , n , p )
+ | _ -> None
+ end
| _ -> None
class havoc =
@@ -54,14 +54,14 @@ class havoc =
match lookup_havoc e with
| None -> Not_applicable
| Some(mr,m0,a,n,p) ->
- let separated =
- F.p_call MemMemory.p_separated
- [ p ; F.e_int 1 ; a ; n ] in
- let process = Tactical.rewrite ?at [
- "Unassigned" , separated , e , F.e_get m0 p ;
- "Assigned" , F.p_not separated , e , F.e_get mr p ;
- ] in
- Applicable process
+ let separated =
+ F.p_call MemMemory.p_separated
+ [ p ; F.e_int 1 ; a ; n ] in
+ let process = Tactical.rewrite ?at [
+ "Unassigned" , separated , e , F.e_get m0 p ;
+ "Assigned" , F.p_not separated , e , F.e_get mr p ;
+ ] in
+ Applicable process
end
(* -------------------------------------------------------------------------- *)
@@ -71,22 +71,22 @@ class havoc =
let separated ?at property =
match F.e_expr property with
| L.Fun( f , [p;n;q;m] ) when f == MemMemory.p_separated ->
- let base_p = MemMemory.a_base p in
- let ofs_p = MemMemory.a_offset p in
- let base_q = MemMemory.a_base q in
- let ofs_q = MemMemory.a_offset q in
- let eq_base = F.p_equal base_p base_q in
- let on_left = F.p_leq (F.e_add ofs_p n) ofs_q in
- let on_right = F.p_leq (F.e_add ofs_q m) ofs_p in
- let overlap = F.p_not (F.p_and on_left on_right) in
- let pattern = F.e_prop property in
- let cases =
- [ "WrongBase" , F.p_neq base_p base_q , pattern , F.e_true ;
- "OnLeft" , F.p_and eq_base on_left , pattern , F.e_true ;
- "OnRight" , F.p_and eq_base on_right , pattern , F.e_true ;
- "OverLap" , F.p_and eq_base overlap , pattern , F.e_false ]
- in
- Applicable (Tactical.rewrite ?at cases)
+ let base_p = MemMemory.a_base p in
+ let ofs_p = MemMemory.a_offset p in
+ let base_q = MemMemory.a_base q in
+ let ofs_q = MemMemory.a_offset q in
+ let eq_base = F.p_equal base_p base_q in
+ let on_left = F.p_leq (F.e_add ofs_p n) ofs_q in
+ let on_right = F.p_leq (F.e_add ofs_q m) ofs_p in
+ let overlap = F.p_not (F.p_and on_left on_right) in
+ let pattern = F.e_prop property in
+ let cases =
+ [ "WrongBase" , F.p_neq base_p base_q , pattern , F.e_true ;
+ "OnLeft" , F.p_and eq_base on_left , pattern , F.e_true ;
+ "OnRight" , F.p_and eq_base on_right , pattern , F.e_true ;
+ "OverLap" , F.p_and eq_base overlap , pattern , F.e_false ]
+ in
+ Applicable (Tactical.rewrite ?at cases)
| _ -> Not_applicable
class separated =
@@ -101,7 +101,7 @@ class separated =
| Clause (Goal p) -> separated p
| Clause (Step s) -> separated ~at:s.id (Conditions.head s)
| Inside (_,p) when F.is_prop p ->
- separated ?at:(Tactical.at sel) (F.p_bool p)
+ separated ?at:(Tactical.at sel) (F.p_bool p)
| _ -> Not_applicable
end
diff --git a/src/plugins/wp/TacInduction.ml b/src/plugins/wp/TacInduction.ml
index 7bbe267f4a216bdb8780b32faa3f6ac7d7de2d9d..564862a0b9cc95d4a8a0e138939686cd1aaa6393 100644
--- a/src/plugins/wp/TacInduction.ml
+++ b/src/plugins/wp/TacInduction.ml
@@ -32,11 +32,11 @@ let filter_pred n hs p =
let filter_step n hs s =
match s.Conditions.condition with
| (Have _ | Type _ | Core _ | Init _ | When _) ->
- Conditions.map_step (filter_pred n hs) s
+ Conditions.map_step (filter_pred n hs) s
| (State _ | Branch _ | Either _) as c ->
- if F.Vars.mem n s.vars then
- (hs := Conditions.pred_cond c :: !hs ; Conditions.step (Have F.p_true))
- else s
+ if F.Vars.mem n s.vars then
+ (hs := Conditions.pred_cond c :: !hs ; Conditions.step (Have F.p_true))
+ else s
let filter_seq n hs seq =
Conditions.sequence @@ List.map (filter_step n hs) @@ Conditions.list seq
@@ -97,17 +97,17 @@ class induction =
match self#get_field vbase with
| Tactical.Compose(Code(t, _, _))
| Inside(_, t) when Lang.F.typeof t = Lang.t_int ->
- Some t
+ Some t
| Compose(Cint i) ->
- Some (Lang.F.e_bigint i)
+ Some (Lang.F.e_bigint i)
| _ ->
- None
+ None
method select feedback (s : Tactical.selection) =
begin match self#get_field vbase with
| Empty ->
- self#set_field vbase (Tactical.int 0) ;
- feedback#update_field vbase
+ self#set_field vbase (Tactical.int 0) ;
+ feedback#update_field vbase
| _ -> ()
end ;
let value = Tactical.selected s in
diff --git a/src/plugins/wp/TacInstance.ml b/src/plugins/wp/TacInstance.ml
index 3592e7b15cac3e83d3782af78091c6de886d70c0..e723ddf1fb636c2a8590aeb3e10ea646b8af02c6 100644
--- a/src/plugins/wp/TacInstance.ml
+++ b/src/plugins/wp/TacInstance.ml
@@ -59,11 +59,11 @@ type env = {
let rec complexity = function
| [] -> Integer.one
| (_,v) :: bindings ->
- match v with
- | Tactical.Compose(Tactical.Range(a,b)) when a < b ->
- let n = Integer.of_int (b+1-a) in
- Integer.mul n (complexity bindings)
- | _ -> complexity bindings
+ match v with
+ | Tactical.Compose(Tactical.Range(a,b)) when a < b ->
+ let n = Integer.of_int (b+1-a) in
+ Integer.mul n (complexity bindings)
+ | _ -> complexity bindings
let cardinal limit bindings =
let n = complexity bindings in
@@ -74,13 +74,13 @@ let rec bind_exists bindings property =
match bindings with
| [] -> property
| (x,v) :: bindings ->
- let closed =
- if Tactical.is_empty v then
- Lang.F.p_bind L.Exists x property
- else
- let value = Tactical.selected v in
- Lang.F.p_subst_var x value property
- in bind_exists bindings closed
+ let closed =
+ if Tactical.is_empty v then
+ Lang.F.p_bind L.Exists x property
+ else
+ let value = Tactical.selected v in
+ Lang.F.p_subst_var x value property
+ in bind_exists bindings closed
let rec range x a b w =
if a <= b then
@@ -92,23 +92,23 @@ let rec range x a b w =
let rec bind_ranges pool = function
| [] -> pool
| (x,a,b) :: ranges ->
- bind_ranges (List.concat (List.map (range x a b) pool)) ranges
+ bind_ranges (List.concat (List.map (range x a b) pool)) ranges
let rec bind_forall ranges bindings property =
match bindings with
| (x,v) :: bindings ->
- begin
- match v with
- | Tactical.Compose(Tactical.Range(a,b)) when a < b ->
- bind_forall ((x,a,b)::ranges) bindings property
- | Tactical.Empty ->
- bind_forall ranges bindings (Lang.F.p_bind L.Forall x property)
- | _ ->
- let value = Tactical.selected v in
- bind_forall ranges bindings (Lang.F.p_subst_var x value property)
- end
+ begin
+ match v with
+ | Tactical.Compose(Tactical.Range(a,b)) when a < b ->
+ bind_forall ((x,a,b)::ranges) bindings property
+ | Tactical.Empty ->
+ bind_forall ranges bindings (Lang.F.p_bind L.Forall x property)
+ | _ ->
+ let value = Tactical.selected v in
+ bind_forall ranges bindings (Lang.F.p_subst_var x value property)
+ end
| [] ->
- bind_ranges [ "Instance" , property ] ranges
+ bind_ranges [ "Instance" , property ] ranges
let instance_goal ?(title="Witness") bindings property sequent =
[ title, (fst sequent , bind_exists bindings property) ]
@@ -125,10 +125,10 @@ let instance_have ?(title="Instance") ?at bindings property sequent =
let bind ~side bindings property : Tactical.process =
match side with
| None ->
- instance_goal ~title:"Witness" bindings property
+ instance_goal ~title:"Witness" bindings property
| Some s ->
- let open Conditions in
- instance_have ?title:s.descr ~at:s.id bindings property
+ let open Conditions in
+ instance_have ?title:s.descr ~at:s.id bindings property
let filter tau e =
try F.Tau.equal tau (F.typeof e)
@@ -150,22 +150,22 @@ class instance =
match F.repr lemma , fields with
| L.Imply(hs,p) , _ when env.binder = L.Forall &&
has_binder env.binder p ->
- let bindings,property = self#wrap env p fields in
- bindings, F.e_imply hs property
+ let bindings,property = self#wrap env p fields in
+ bindings, F.e_imply hs property
| L.Bind(q,tau,phi) , fd :: fields when q = env.binder ->
- env.index <- succ env.index ;
- let x = F.fresh env.feedback#pool tau in
- let v = self#get_field fd in
- let range = match tau with L.Int -> true | _ -> false in
- let tooltip = fieldname ~range env.index x in
- env.feedback#update_field
- ~tooltip ~range ~enabled:true ~filter:(filter tau) fd ;
- let lemma = F.QED.e_unbind x phi in
- let bindings,property = self#wrap env lemma fields in
- (x,v) :: bindings , property
+ env.index <- succ env.index ;
+ let x = F.fresh env.feedback#pool tau in
+ let v = self#get_field fd in
+ let range = match tau with L.Int -> true | _ -> false in
+ let tooltip = fieldname ~range env.index x in
+ env.feedback#update_field
+ ~tooltip ~range ~enabled:true ~filter:(filter tau) fd ;
+ let lemma = F.QED.e_unbind x phi in
+ let bindings,property = self#wrap env lemma fields in
+ (x,v) :: bindings , property
| _ ->
- List.iter (env.feedback#update_field ~enabled:false) fields ;
- [] , lemma
+ List.iter (env.feedback#update_field ~enabled:false) fields ;
+ [] , lemma
method private configure ~side feedback p =
let binder = match side with None -> L.Exists | Some _ -> L.Forall in
@@ -177,12 +177,12 @@ class instance =
then
match cardinal 1000 bindings with
| Some n ->
- if n > 1 then
- feedback#set_descr "Generates %d instances" n ;
- Applicable (bind ~side bindings (F.p_bool phi))
+ if n > 1 then
+ feedback#set_descr "Generates %d instances" n ;
+ Applicable (bind ~side bindings (F.p_bool phi))
| None ->
- feedback#set_error "More than 1,000 instances" ;
- Not_configured
+ feedback#set_error "More than 1,000 instances" ;
+ Not_configured
else Not_configured
else
Not_applicable
@@ -190,22 +190,22 @@ class instance =
method select feedback sel =
match sel with
| Inside(Step s,t) when F.is_prop t ->
- let hs = Conditions.have s in
- let p = F.p_bool t in
- begin match F.p_expr hs with
- | L.And ps when List.memq p ps ->
- self#configure ~side:(Some s) feedback p
- | _ -> Not_applicable
- end
+ let hs = Conditions.have s in
+ let p = F.p_bool t in
+ begin match F.p_expr hs with
+ | L.And ps when List.memq p ps ->
+ self#configure ~side:(Some s) feedback p
+ | _ -> Not_applicable
+ end
| Clause(Step s) ->
- let open Conditions in
- begin match s.condition with
- | Have p | When p | Init p | Core p ->
- self#configure ~side:(Some s) feedback p
- | _ -> Not_applicable
- end
+ let open Conditions in
+ begin match s.condition with
+ | Have p | When p | Init p | Core p ->
+ self#configure ~side:(Some s) feedback p
+ | _ -> Not_applicable
+ end
| Clause(Goal p) ->
- self#configure ~side:None feedback p
+ self#configure ~side:None feedback p
| _ -> Not_applicable
end
@@ -215,9 +215,9 @@ let tactical = Tactical.export (new instance)
let rec wrap fs vs =
match fs , vs with
| f :: fs , v :: vs ->
- Strategy.arg f v :: (wrap fs vs)
+ Strategy.arg f v :: (wrap fs vs)
| fs , _ ->
- List.map (fun f -> Strategy.arg f Empty) fs
+ List.map (fun f -> Strategy.arg f Empty) fs
let strategy ?(priority=1.0) selection values =
Strategy.{
diff --git a/src/plugins/wp/TacLemma.ml b/src/plugins/wp/TacLemma.ml
index 5e9ebe63af4c7a377352667f690d466f764c4ca8..2d9680ba5753889d01d59599a6d64661a3df5164 100644
--- a/src/plugins/wp/TacLemma.ml
+++ b/src/plugins/wp/TacLemma.ml
@@ -112,43 +112,43 @@ class instance =
method private wrap env vars fields =
match vars , fields with
| x::xs , fd::fields ->
- let title = Pretty_utils.to_string F.pp_var x in
- let value = self#get_field fd in
- let tau = F.tau_of_var x in
- env.feedback#update_field ~enabled:true
- ~title ~tooltip:env.descr
- ~range:(match tau with L.Int -> true | _ -> false)
- ~filter:(TacInstance.filter tau) fd ;
- let bindings,lemma = self#wrap env xs fields in
- (x,value)::bindings , lemma
+ let title = Pretty_utils.to_string F.pp_var x in
+ let value = self#get_field fd in
+ let tau = F.tau_of_var x in
+ env.feedback#update_field ~enabled:true
+ ~title ~tooltip:env.descr
+ ~range:(match tau with L.Int -> true | _ -> false)
+ ~filter:(TacInstance.filter tau) fd ;
+ let bindings,lemma = self#wrap env xs fields in
+ (x,value)::bindings , lemma
| _ ->
- self#hide env.feedback fields ;
- [] , F.p_forall vars env.lemma
+ self#hide env.feedback fields ;
+ [] , F.p_forall vars env.lemma
method select feedback = function
| Empty -> Not_applicable
| selection ->
- begin match self#get_field search with
+ begin match self#get_field search with
+ | None ->
+ self#hide feedback TacInstance.fields ;
+ Not_configured
+ | Some Tactical.{ title ; value = dlem } ->
+ let fields = TacInstance.fields in
+ let vars,lemma = fresh feedback#pool dlem in
+ let descr = Pretty_utils.to_string F.pp_pred lemma in
+ let bindings,lemma =
+ self#wrap { feedback ; descr ; lemma } vars fields in
+ match TacInstance.cardinal 1000 bindings with
+ | Some n ->
+ if n > 1 then
+ feedback#set_descr "Generates %d instances" n ;
+ let at = Tactical.at selection in
+ Applicable
+ (TacInstance.instance_have ~title ?at bindings lemma)
| None ->
- self#hide feedback TacInstance.fields ;
- Not_configured
- | Some Tactical.{ title ; value = dlem } ->
- let fields = TacInstance.fields in
- let vars,lemma = fresh feedback#pool dlem in
- let descr = Pretty_utils.to_string F.pp_pred lemma in
- let bindings,lemma =
- self#wrap { feedback ; descr ; lemma } vars fields in
- match TacInstance.cardinal 1000 bindings with
- | Some n ->
- if n > 1 then
- feedback#set_descr "Generates %d instances" n ;
- let at = Tactical.at selection in
- Applicable
- (TacInstance.instance_have ~title ?at bindings lemma)
- | None ->
- feedback#set_error "More than 1,000 instances" ;
- Not_configured
- end
+ feedback#set_error "More than 1,000 instances" ;
+ Not_configured
+ end
end
let tactical = Tactical.export (new instance)
diff --git a/src/plugins/wp/TacModMask.ml b/src/plugins/wp/TacModMask.ml
index ac36c191eb812f8cee19bef219f23bfd4eaaa55c..72925e7e9540c69fae02dda7d337548509912f99 100644
--- a/src/plugins/wp/TacModMask.ml
+++ b/src/plugins/wp/TacModMask.ml
@@ -65,59 +65,59 @@ class modmask =
in
match Lang.F.repr e with
| Mod(a, m) ->
- begin
- try
- let m = Cint.l_lsl e_one @@ Cint.match_power2 m in
- let n = Cint.l_and a (m - e_one) in
- let cond = a >= e_zero in
-
- update_display ~hard:false ~active_field:false ;
- Applicable (on_cond "Mask Guard" cond @@ replace_with "Mask" n)
-
- with Not_found ->
- let power_of_2 =
- let v = Lang.freshvar ~basename:"n" Lang.t_int in
- let tv = e_var v in
- p_exists [v] (e_zero <= tv && m = Cint.l_lsl e_one tv)
- in
- let cond = (a >= e_zero && e_zero < m && power_of_2) in
- let n = Cint.l_and a (m - e_one) in
-
- update_display ~hard:true ~active_field:false ;
- Applicable (on_cond "Mask Guard" cond @@ replace_with "Mask" n)
- end
+ begin
+ try
+ let m = Cint.l_lsl e_one @@ Cint.match_power2 m in
+ let n = Cint.l_and a (m - e_one) in
+ let cond = a >= e_zero in
+
+ update_display ~hard:false ~active_field:false ;
+ Applicable (on_cond "Mask Guard" cond @@ replace_with "Mask" n)
+
+ with Not_found ->
+ let power_of_2 =
+ let v = Lang.freshvar ~basename:"n" Lang.t_int in
+ let tv = e_var v in
+ p_exists [v] (e_zero <= tv && m = Cint.l_lsl e_one tv)
+ in
+ let cond = (a >= e_zero && e_zero < m && power_of_2) in
+ let n = Cint.l_and a (m - e_one) in
+
+ update_display ~hard:true ~active_field:false ;
+ Applicable (on_cond "Mask Guard" cond @@ replace_with "Mask" n)
+ end
| Fun( f , [ a ; b ] ) when Lang.Fun.equal f Cint.f_land ->
- begin
- try
- let a, m =
- try b, Cint.match_power2_minus1 a
- with Not_found -> a, Cint.match_power2_minus1 b
- in
-
- let cond = a >= e_zero in
- let n = a mod (Cint.l_lsl e_one m) in
-
- update_display ~hard:false ~active_field:false ;
- Applicable (on_cond "Mod Guard" cond @@ replace_with "Mod" n)
-
- with Not_found ->
- let a, m = if self#get_field v_revert then b, a else a, b in
- let plus_1_power_of_2 =
- let v = Lang.freshvar ~basename:"n" Lang.t_int in
- let tv = e_var v in
- p_exists [v] (e_zero <= tv && m + e_one = Cint.l_lsl e_one tv)
- in
- let cond = (a >= e_zero && e_zero <= m && plus_1_power_of_2) in
- let n = a mod (m + e_one) in
-
- update_display ~hard:true ~active_field:true ;
- Applicable (on_cond "Mod Guard" cond @@ replace_with "Mod" n)
- end
+ begin
+ try
+ let a, m =
+ try b, Cint.match_power2_minus1 a
+ with Not_found -> a, Cint.match_power2_minus1 b
+ in
+
+ let cond = a >= e_zero in
+ let n = a mod (Cint.l_lsl e_one m) in
+
+ update_display ~hard:false ~active_field:false ;
+ Applicable (on_cond "Mod Guard" cond @@ replace_with "Mod" n)
+
+ with Not_found ->
+ let a, m = if self#get_field v_revert then b, a else a, b in
+ let plus_1_power_of_2 =
+ let v = Lang.freshvar ~basename:"n" Lang.t_int in
+ let tv = e_var v in
+ p_exists [v] (e_zero <= tv && m + e_one = Cint.l_lsl e_one tv)
+ in
+ let cond = (a >= e_zero && e_zero <= m && plus_1_power_of_2) in
+ let n = a mod (m + e_one) in
+
+ update_display ~hard:true ~active_field:true ;
+ Applicable (on_cond "Mod Guard" cond @@ replace_with "Mod" n)
+ end
| _ ->
- update_display ~hard:false ~active_field:false ;
- Not_applicable
+ update_display ~hard:false ~active_field:false ;
+ Not_applicable
end
let modmask = Tactical.export (new modmask)
diff --git a/src/plugins/wp/TacNormalForm.ml b/src/plugins/wp/TacNormalForm.ml
index a3ca166d4d31e5b3cb6d4270a67f56d0a6ae19a9..8c45c327521577cd344537ce0882508f95f5be81 100644
--- a/src/plugins/wp/TacNormalForm.ml
+++ b/src/plugins/wp/TacNormalForm.ml
@@ -61,18 +61,18 @@ let f_nf_hyp s e ~depth = f_replace_hyp s ["DNF"] (nf_disj_args (WpTac.e_dnf ~d
let match_selection = function
| Clause(Goal p) ->
- let e = Lang.F.e_prop p in
- if WpTac.is_cnf e then None
- else Some (true, e, f_nf_goal e)
+ let e = Lang.F.e_prop p in
+ if WpTac.is_cnf e then None
+ else Some (true, e, f_nf_goal e)
| Clause(Step s) ->
- begin
- match s.condition with
- | (Type p | Have p | When p | Core p | Init p) ->
- let e = Lang.F.e_prop p in
- if WpTac.is_dnf e then None
- else Some (false, e, f_nf_hyp s e)
- | _ -> None
- end
+ begin
+ match s.condition with
+ | (Type p | Have p | When p | Core p | Init p) ->
+ let e = Lang.F.e_prop p in
+ if WpTac.is_dnf e then None
+ else Some (false, e, f_nf_hyp s e)
+ | _ -> None
+ end
| Inside(_,_) | Compose _ | Empty | Multi _ -> None
class normal_form =
@@ -85,10 +85,10 @@ class normal_form =
method select feedback (s : Tactical.selection) =
match match_selection s with
| Some (pol,_,continuation) ->
- feedback#set_title
- (if pol then "Intuition (CNF)" else "Intuition (DNF)") ;
- let depth = (-1) in
- Applicable (continuation ~depth)
+ feedback#set_title
+ (if pol then "Intuition (CNF)" else "Intuition (DNF)") ;
+ let depth = (-1) in
+ Applicable (continuation ~depth)
| _ -> Not_applicable
end
diff --git a/src/plugins/wp/TacOverflow.ml b/src/plugins/wp/TacOverflow.ml
index 406c1101709d2e92c2e4df2b43d40f18341581c8..0a032be201096dcfee1f4bfcac2584d89df32e7d 100644
--- a/src/plugins/wp/TacOverflow.ml
+++ b/src/plugins/wp/TacOverflow.ml
@@ -36,27 +36,27 @@ class overflow =
let open Qed.Logic in
match F.repr e with
| Fun(f,[v]) ->
- let open Lang.F in
- let open Lang.N in
- let min, max = Ctypes.bounds @@ Cint.to_cint f in
- let min, max = e_zint min, e_zint max in
+ let open Lang.F in
+ let open Lang.N in
+ let min, max = Ctypes.bounds @@ Cint.to_cint f in
+ let min, max = e_zint min, e_zint max in
- let lower = v < min and upper = max < v in
- let in_range = not (lower || upper) in
+ let lower = v < min and upper = max < v in
+ let in_range = not (lower || upper) in
- let length = (max - min) + e_one in
- let overflow = min + ((v - min) mod length) in
+ let length = (max - min) + e_one in
+ let overflow = min + ((v - min) mod length) in
- let replace_with v = fun u -> if u == e then v else raise Not_found in
+ let replace_with v = fun u -> if u == e then v else raise Not_found in
- Applicable(fun (hs,g) -> [
- "In-Range",
- Conditions.subst (replace_with v) (hs , in_range ==> g) ;
- "Lower",
- Conditions.subst (replace_with overflow) (hs , lower ==> g) ;
- "Upper",
- Conditions.subst (replace_with overflow) (hs , upper ==> g)
- ])
+ Applicable(fun (hs,g) -> [
+ "In-Range",
+ Conditions.subst (replace_with v) (hs , in_range ==> g) ;
+ "Lower",
+ Conditions.subst (replace_with overflow) (hs , lower ==> g) ;
+ "Upper",
+ Conditions.subst (replace_with overflow) (hs , upper ==> g)
+ ])
| _ -> Not_applicable
end
diff --git a/src/plugins/wp/TacRewrite.ml b/src/plugins/wp/TacRewrite.ml
index d784e380c4849256d03c51ec3e4b49a1efc0611c..6764f2358f22aec679234540eb42421ecf852032 100644
--- a/src/plugins/wp/TacRewrite.ml
+++ b/src/plugins/wp/TacRewrite.ml
@@ -41,11 +41,11 @@ let hypothesis s =
let clause = function
| Clause(Step s) -> hypothesis s
| Inside(Step s,e) ->
- begin
- match Repr.pred (hypothesis s) with
- | And es when List.memq e es -> Lang.F.p_bool e
- | _ -> raise Not_found
- end
+ begin
+ match Repr.pred (hypothesis s) with
+ | And es when List.memq e es -> Lang.F.p_bool e
+ | _ -> raise Not_found
+ end
| _ -> raise Not_found
class rewrite dir =
@@ -60,8 +60,8 @@ class rewrite dir =
let p = clause select in
match Repr.pred p with
| Eq(a,b) ->
- let replaced,value = if dir then a,b else b,a in
- rewrite ~select ~replaced ~value
+ let replaced,value = if dir then a,b else b,a in
+ rewrite ~select ~replaced ~value
| _ -> Not_applicable
with Not_found -> Not_applicable
end
@@ -95,11 +95,11 @@ let rec lookup step push goal e =
match Repr.term e with
| And ps -> List.iter (lookup step push goal) ps
| Eq(a,b) ->
- begin
- let select = Inside(Step step,e) in
- submit push select a goal tacl ;
- submit push select b goal tacr ;
- end
+ begin
+ let select = Inside(Step step,e) in
+ submit push select a goal tacl ;
+ submit push select b goal tacr ;
+ end
| _ -> ()
class auto_rewrite =
@@ -113,7 +113,7 @@ class auto_rewrite =
let open Conditions in
match s.condition with
| Have p | When p | Core p | Init p ->
- lookup s push (Lang.F.e_prop goal) (Lang.F.e_prop p)
+ lookup s push (Lang.F.e_prop goal) (Lang.F.e_prop p)
| _ -> ())
hyps
end
diff --git a/src/plugins/wp/TacSequence.ml b/src/plugins/wp/TacSequence.ml
index ab689630267f2bfc69790deb410b7399075391ad..4ebca8983d0fdee9e75e399a779146f163fd3c80 100644
--- a/src/plugins/wp/TacSequence.ml
+++ b/src/plugins/wp/TacSequence.ml
@@ -57,55 +57,55 @@ class sequence =
let value = Tactical.selected s in
match F.repr value with
| Fun(f,[a;n]) when f == Vlist.f_repeat ->
- let result = F.typeof value in
- let at = Tactical.at s in
- begin
- match self#get_field vmode with
- | `Sum ->
- (* n1>=0 && n2>=0 && ... |- (a *^ (n1 + n2 + ...)) -+-> ((a *^ n1) ^ (a *^ n2) ^ ...) *)
- begin
- match sum n with
- | [ s ] ->
- feedback#set_descr
- "Cannot unroll with selected option, '%a' is not a sum"
- F.pp_term s ;
- Tactical.Not_configured
- | ns ->
- (* NB. the term is rewriten in itself when the initial term is not a sum *)
- let pos = F.p_all positive ns in
- let cat =
- concat ~result (List.map (repeat ~result a) ns) in
- feedback#set_descr
- "Unroll repeat-sequence: unroll sum" ;
- Tactical.Applicable (
- Tactical.condition "Positive" pos @@
- Tactical.rewrite ?at [ "Unroll" , pos , value , cat ])
- end
- | `Left ->
- (* n<=0 |- (a *^ n) -+-> [] *)
- (* n-1>=0 |- (a *^ n) -+-> (a ^ (a *^ (n-1))) *)
- let p = F.e_add n F.e_minus_one in
- let unroll = concat ~result [a ; repeat ~result a p] in
+ let result = F.typeof value in
+ let at = Tactical.at s in
+ begin
+ match self#get_field vmode with
+ | `Sum ->
+ (* n1>=0 && n2>=0 && ... |- (a *^ (n1 + n2 + ...)) -+-> ((a *^ n1) ^ (a *^ n2) ^ ...) *)
+ begin
+ match sum n with
+ | [ s ] ->
feedback#set_descr
- "Unroll repeat-sequence: unroll first element" ;
- Tactical.Applicable(
- Tactical.rewrite ?at [
- "Nil", negative n , value , concat ~result [] ;
- "Unroll", positive p , value , unroll ;
- ])
- | `Right ->
- (* n<=0 |- (a *^ n) -+-> [] *)
- (* n-1>=0 |- (a *^ n) -+-> ((a *^ (n-1)) ^ a) *)
- let p = F.e_add n F.e_minus_one in
- let unroll = concat ~result [repeat ~result a p ; a] in
+ "Cannot unroll with selected option, '%a' is not a sum"
+ F.pp_term s ;
+ Tactical.Not_configured
+ | ns ->
+ (* NB. the term is rewriten in itself when the initial term is not a sum *)
+ let pos = F.p_all positive ns in
+ let cat =
+ concat ~result (List.map (repeat ~result a) ns) in
feedback#set_descr
- "Unroll repeat-sequence: unroll last element" ;
- Tactical.Applicable(
- Tactical.rewrite ?at [
- "Nil", negative n , value , concat ~result [] ;
- "Unroll", positive p , value , unroll ;
- ])
- end
+ "Unroll repeat-sequence: unroll sum" ;
+ Tactical.Applicable (
+ Tactical.condition "Positive" pos @@
+ Tactical.rewrite ?at [ "Unroll" , pos , value , cat ])
+ end
+ | `Left ->
+ (* n<=0 |- (a *^ n) -+-> [] *)
+ (* n-1>=0 |- (a *^ n) -+-> (a ^ (a *^ (n-1))) *)
+ let p = F.e_add n F.e_minus_one in
+ let unroll = concat ~result [a ; repeat ~result a p] in
+ feedback#set_descr
+ "Unroll repeat-sequence: unroll first element" ;
+ Tactical.Applicable(
+ Tactical.rewrite ?at [
+ "Nil", negative n , value , concat ~result [] ;
+ "Unroll", positive p , value , unroll ;
+ ])
+ | `Right ->
+ (* n<=0 |- (a *^ n) -+-> [] *)
+ (* n-1>=0 |- (a *^ n) -+-> ((a *^ (n-1)) ^ a) *)
+ let p = F.e_add n F.e_minus_one in
+ let unroll = concat ~result [repeat ~result a p ; a] in
+ feedback#set_descr
+ "Unroll repeat-sequence: unroll last element" ;
+ Tactical.Applicable(
+ Tactical.rewrite ?at [
+ "Nil", negative n , value , concat ~result [] ;
+ "Unroll", positive p , value , unroll ;
+ ])
+ end
| _ -> Not_applicable
end
diff --git a/src/plugins/wp/TacShift.ml b/src/plugins/wp/TacShift.ml
index 43f4f9171cc9d2d358a75a1ce299b53e4c62d897..2f6bb010b810b86a631aafb59db4e0e5b3f44149 100644
--- a/src/plugins/wp/TacShift.ml
+++ b/src/plugins/wp/TacShift.ml
@@ -45,7 +45,7 @@ let select_op f =
let select_int n =
match F.repr n with
| Qed.Logic.Kint n ->
- (try Integer.to_int_exn n with Z.Overflow -> raise Not_found)
+ (try Integer.to_int_exn n with Z.Overflow -> raise Not_found)
| _ -> raise Not_found
class shift =
@@ -61,13 +61,13 @@ class shift =
let open Qed.Logic in
match F.repr e with
| Fun( f , [a;n] ) ->
- begin
- let rewrite_shift = select_op f in
- let n = select_int n in
- if n > 64 then feedback#set_error "Too large shift (64 max.)" ;
- if n < 0 then feedback#set_error "Negative shift (0 min.)" ;
- Tactical.Applicable (rewrite_shift e a n)
- end
+ begin
+ let rewrite_shift = select_op f in
+ let n = select_int n in
+ if n > 64 then feedback#set_error "Too large shift (64 max.)" ;
+ if n < 0 then feedback#set_error "Negative shift (0 min.)" ;
+ Tactical.Applicable (rewrite_shift e a n)
+ end
| _ -> Tactical.Not_applicable
end
@@ -84,9 +84,9 @@ let is_shift e =
let open Qed.Logic in
match F.repr e with
| Fun( f , [_;n] ) ->
- let _ignore = select_op f in
- let _ = select_int n in
- true
+ let _ignore = select_op f in
+ let _ = select_int n in
+ true
| _ -> false
with Not_found -> false
diff --git a/src/plugins/wp/TacSplit.ml b/src/plugins/wp/TacSplit.ml
index 20857de0be03c63f38eaaf97c345129968666858..188c68400499b6e1a76b9e24e555d0d1ad1067c0 100644
--- a/src/plugins/wp/TacSplit.ml
+++ b/src/plugins/wp/TacSplit.ml
@@ -54,26 +54,26 @@ end
let find (map:var2node_t) var =
let find_root var root = function
| None -> (* adds an empty root partition for that [var] *)
- root := Some { var; rank=0; kind=(Root F.Tset.empty) };
- debug ". . find(%a)= %a (inserted)@." Lang.F.pp_var var Lang.F.pp_var var ;
- !root
+ root := Some { var; rank=0; kind=(Root F.Tset.empty) };
+ debug ". . find(%a)= %a (inserted)@." Lang.F.pp_var var Lang.F.pp_var var ;
+ !root
| (Some { kind=(Root _); var=debug_var }) as old ->
- debug ". . find(%a)= %a@." Lang.F.pp_var var Lang.F.pp_var debug_var ;
- root := old ;
- old
+ debug ". . find(%a)= %a@." Lang.F.pp_var var Lang.F.pp_var debug_var ;
+ root := old ;
+ old
| Some ({ kind=(Node _) } as node) ->
- debug ". . find(%a)=" Lang.F.pp_var var ;
- let rec find_aux node =
- debug " %a" Lang.F.pp_var node.var ;
- match node.kind with
- | Node y ->
- let r = find_aux y in
- node.kind <- Node r ; r
- | Root _ -> node
- in
- root := Some (find_aux node);
- debug "@." ;
- !root
+ debug ". . find(%a)=" Lang.F.pp_var var ;
+ let rec find_aux node =
+ debug " %a" Lang.F.pp_var node.var ;
+ match node.kind with
+ | Node y ->
+ let r = find_aux y in
+ node.kind <- Node r ; r
+ | Root _ -> node
+ in
+ root := Some (find_aux node);
+ debug "@." ;
+ !root
in
let root = ref None in
let map = F.Vmap.change find_root var root map in
@@ -116,17 +116,17 @@ end
let vars = F.Vars.inter vars (Lang.F.vars term) in
match F.Vars.elements vars with
| [] ->
- debug "- term #%d: no vars -> %a@." !debug_term_nth Lang.F.pp_term term;
- (F.Tset.add term set), map (* closed term partition *)
+ debug "- term #%d: no vars -> %a@." !debug_term_nth Lang.F.pp_term term;
+ (F.Tset.add term set), map (* closed term partition *)
| var::others -> (* term partition bound to variables *)
- debug "- term #%d: nb vars=%d -> %a@." !debug_term_nth (1+List.length others) Lang.F.pp_term term;
- let map,root = List.fold_left union (find map var) others in
- (* adds the current term to the partition *)
- (match root.kind with
- | Node _ -> assert false
- | Root terms ->
- root.kind <- Root (F.Tset.add term terms));
- set,map
+ debug "- term #%d: nb vars=%d -> %a@." !debug_term_nth (1+List.length others) Lang.F.pp_term term;
+ let map,root = List.fold_left union (find map var) others in
+ (* adds the current term to the partition *)
+ (match root.kind with
+ | Node _ -> assert false
+ | Root terms ->
+ root.kind <- Root (F.Tset.add term terms));
+ set,map
in
debug "------------@.Partitions(vars #%d,terms #%d)@." (F.Vars.cardinal vars) (List.length es);
List.fold_left partitions (F.Tset.empty,F.Vmap.empty) es
@@ -138,8 +138,8 @@ end
if 0 != F.Var.compare node.var var then acc
else match node.kind with
| Root part -> assert (not (F.Tset.is_empty part));
- debug "var %a, nb terms = %d@." Lang.F.pp_var var (F.Tset.cardinal part);
- (nb_parts+1),part::parts
+ debug "var %a, nb terms = %d@." Lang.F.pp_var var (F.Tset.cardinal part);
+ (nb_parts+1),part::parts
| Node _ -> acc
in
let ((nb_part,_) as r) = F.Vmap.fold extract map acc in
@@ -189,236 +189,236 @@ class split =
match s with
| Empty | Compose _ | Multi _ -> Not_applicable
| Inside(_,e) ->
- begin
+ begin
+ let at = Tactical.at s in
+ let open Qed.Logic in
+ match Lang.F.repr e with
+ | Leq(x,y) -> split_leq at x y
+ | Lt(x,y) -> split_lt at x y
+ | Eq(x,y) when not (is_prop x || is_prop y) -> split_eq at x y
+ | Neq(x,y) when not (is_prop x || is_prop y) -> split_neq at x y
+ | _ when F.is_prop e ->
+ feedback#set_title "Split (true,false)" ;
+ feedback#set_descr "Decompose between True and False values" ;
+ let cases = ["True",F.p_bool e;"False",F.p_not (F.p_bool e)] in
let at = Tactical.at s in
- let open Qed.Logic in
- match Lang.F.repr e with
- | Leq(x,y) -> split_leq at x y
- | Lt(x,y) -> split_lt at x y
- | Eq(x,y) when not (is_prop x || is_prop y) -> split_eq at x y
- | Neq(x,y) when not (is_prop x || is_prop y) -> split_neq at x y
- | _ when F.is_prop e ->
- feedback#set_title "Split (true,false)" ;
- feedback#set_descr "Decompose between True and False values" ;
- let cases = ["True",F.p_bool e;"False",F.p_not (F.p_bool e)] in
- let at = Tactical.at s in
- Applicable (Tactical.insert ?at cases)
- | _ -> Not_applicable
- end
+ Applicable (Tactical.insert ?at cases)
+ | _ -> Not_applicable
+ end
| Clause(Goal p) ->
- begin
- let open Qed.Logic in
- match Lang.F.e_expr p with
- | Bind (Exists,_,_) -> begin
- let vars,q = PartitionsQQ.destructs_qq feedback#pool ~is_forall:false (e_prop p) in
- match Lang.F.repr q with
- | If (c,p,q) ->
+ begin
+ let open Qed.Logic in
+ match Lang.F.e_expr p with
+ | Bind (Exists,_,_) -> begin
+ let vars,q = PartitionsQQ.destructs_qq feedback#pool ~is_forall:false (e_prop p) in
+ match Lang.F.repr q with
+ | If (c,p,q) ->
+ if F.Vars.is_empty (F.Vars.inter (F.vars c) vars) then
+ begin
+ (* unbound condition: proceed by case *)
+ feedback#set_title "Split (exists if)" ;
+ feedback#set_descr
+ "Split unbound Condition into Branches" ;
+ let p = F.e_imply [c] (bind Exists ~vars p) in
+ let q = F.e_imply [e_not c] (bind Exists ~vars q) in
+ Applicable (Tactical.split [
+ "Then" , F.p_bool p ;
+ "Else" , F.p_bool q ;
+ ])
+ end
+ else
+ begin
+ feedback#set_title "Split (rewrite exists if)" ;
+ feedback#set_descr
+ "Rewrite the Conditional in a Disjunction \
+ and Distribute the Quantifier under" ;
+ let p = bind Exists ~vars (F.e_and [c;p]) in
+ let q = bind Exists ~vars (F.e_and [(e_not c); q]) in
+ let cases = [ "Split" , F.p_bool (F.e_or [p;q]) ] in
+ Applicable (Tactical.split cases)
+ end
+ | Or es ->
+ feedback#set_title "Split (exists or)" ;
+ feedback#set_descr
+ "Distributes the Quantifier under the Disjunction" ;
+ let p = F.e_or (List.map (bind Exists ~vars) es) in
+ let cases = [ "Split" , F.p_bool p ] in
+ Applicable (Tactical.split cases)
+ | Imply (es, p) ->
+ feedback#set_title "Split (exists imply)" ;
+ feedback#set_descr
+ "Distributes the Quantifier under the Imply" ;
+ let p = F.e_imply (List.map (bind Forall ~vars) es)
+ (bind Exists ~vars p) in
+ let cases = [ "Split" , F.p_bool p ] in
+ Applicable (Tactical.split cases)
+ | And es ->
+ let nb_parts,parts = PartitionsQQ.get vars es in
+ if nb_parts=1 then Not_applicable
+ else begin
+ feedback#set_title "Split (exists and)" ;
+ feedback#set_descr
+ "Decompose the Quantifier into %d Blocks" nb_parts ;
+ let bind es =
+ bind Exists ~vars (F.e_and (F.Tset.elements es)) in
+ let goal i n es =
+ Printf.sprintf "Goal %d/%d" i n , F.p_bool (bind es) in
+ Applicable (Tactical.split (Tactical.mapi goal parts))
+ end
+ | _ -> Not_applicable
+ end
+ | And es ->
+ let n = List.length es in
+ feedback#set_title "Split (and)" ;
+ feedback#set_descr
+ "Decompose between the %d parts of the Conjunction" n ;
+ let goal i n e = Printf.sprintf "Goal %d/%d" i n , F.p_bool e in
+ Applicable (Tactical.split (Tactical.mapi goal es))
+ | Eq(x,y) when (F.is_prop x) && (F.is_prop y) ->
+ feedback#set_title "Split (iff)" ;
+ feedback#set_descr "Turn Equivalence into Implications" ;
+ let p = F.p_bool (F.e_imply [x] y) in
+ let q = F.p_bool (F.e_imply [y] x) in
+ let cases = [ "Necessity" , p ; "Sufficiency" , q ] in
+ Applicable (Tactical.split cases)
+ | Neq(x,y) when (F.is_prop x) && (F.is_prop y) ->
+ feedback#set_title "Split (xor)" ;
+ feedback#set_descr "Turn Dis-Equivalence into Implications" ;
+ let p = F.p_bool (F.e_imply [x] (e_not y)) in
+ let q = F.p_bool (F.e_imply [y] (e_not x)) in
+ let cases = [ "Necessity" , p ; "Sufficiency" , q ] in
+ Applicable (Tactical.split cases)
+ | If(c,p,q) -> (* Split + intro *)
+ feedback#set_title "Split (if)" ;
+ feedback#set_descr "Decompose Conditional into Branches" ;
+ let p = F.p_bool (F.e_imply [c] p) in
+ let q = F.p_bool (F.e_imply [e_not c] q) in
+ let cases = [ "Then" , p ; "Else" , q ] in
+ Applicable (Tactical.split cases)
+ | _ ->
+ Not_applicable
+ end
+ | Clause(Step step) ->
+ begin
+ match step.condition with
+ | State _ -> Not_applicable
+ | Branch(p,_,_) ->
+ feedback#set_title "Split (branch)" ;
+ feedback#set_descr "Decompose Conditional into Branches" ;
+ let cases = [ "Then" , p ; "Else" , p_not p ] in
+ Applicable (Tactical.insert ~at:step.id cases)
+ | Either seqs ->
+ let n = List.length seqs in
+ feedback#set_title "Split (switch)" ;
+ feedback#set_descr "Decompose each %d Cases" n ;
+ let either i n s = Printf.sprintf "Case %d/%d" i n , Either [s] in
+ let cases = Tactical.mapi either seqs in
+ Applicable (Tactical.replace ~at:step.id cases)
+ | (Type p | Have p | When p | Core p | Init p) ->
+ begin
+ let open Qed.Logic in
+ match F.e_expr p with
+ | Bind (Forall,_,_) -> begin
+ let vars,q = PartitionsQQ.destructs_qq feedback#pool ~is_forall:true (e_prop p) in
+ match Lang.F.repr q with
+ | If (c,p,q) ->
if F.Vars.is_empty (F.Vars.inter (F.vars c) vars) then
- begin
- (* unbound condition: proceed by case *)
- feedback#set_title "Split (exists if)" ;
- feedback#set_descr
- "Split unbound Condition into Branches" ;
- let p = F.e_imply [c] (bind Exists ~vars p) in
- let q = F.e_imply [e_not c] (bind Exists ~vars q) in
- Applicable (Tactical.split [
- "Then" , F.p_bool p ;
- "Else" , F.p_bool q ;
- ])
+ begin (* unbound condition: so, the If is considered as a disjunction *)
+ feedback#set_title "Split (forall if)" ;
+ feedback#set_descr "Decompose unbound conditional into Branches" ;
+ let p = F.p_bool (F.e_and [c; (bind Exists ~vars p)]) in
+ let q = F.p_bool (F.e_and [(e_not c); (bind Exists ~vars q)]) in
+ let cases = [ "Then" , When p ; "Else" , When q ] in
+ Applicable (Tactical.replace ~at:step.id cases)
end
else
begin
- feedback#set_title "Split (rewrite exists if)" ;
- feedback#set_descr
- "Rewrite the Conditional in a Disjunction \
- and Distribute the Quantifier under" ;
- let p = bind Exists ~vars (F.e_and [c;p]) in
- let q = bind Exists ~vars (F.e_and [(e_not c); q]) in
- let cases = [ "Split" , F.p_bool (F.e_or [p;q]) ] in
- Applicable (Tactical.split cases)
+ feedback#set_title "Split (rewrite forall if)" ;
+ feedback#set_descr "Rewrite the Conditional in a Conjunction and Distributes the Quantifier under the Conjunction" ;
+ let p = bind Exists ~vars (F.e_imply [c] p) in
+ let q = bind Exists ~vars (F.e_imply [e_not c] q) in
+ let cases = [ "Split (rewrite exists if)" , When (F.p_bool (F.e_and [p;q])) ] in
+ Applicable (Tactical.replace ~at:step.id cases)
end
- | Or es ->
- feedback#set_title "Split (exists or)" ;
- feedback#set_descr
- "Distributes the Quantifier under the Disjunction" ;
- let p = F.e_or (List.map (bind Exists ~vars) es) in
- let cases = [ "Split" , F.p_bool p ] in
- Applicable (Tactical.split cases)
- | Imply (es, p) ->
- feedback#set_title "Split (exists imply)" ;
- feedback#set_descr
- "Distributes the Quantifier under the Imply" ;
- let p = F.e_imply (List.map (bind Forall ~vars) es)
- (bind Exists ~vars p) in
- let cases = [ "Split" , F.p_bool p ] in
- Applicable (Tactical.split cases)
- | And es ->
+ | And es ->
+ feedback#set_title "Split (forall and)" ;
+ feedback#set_descr "Distributes the Quantifier under the Conjunction" ;
+ let p = F.p_bool (F.e_and (List.map (bind Forall ~vars) es)) in
+ let cases = [ "Split (distrib forall and)" , When p ] in
+ Applicable (Tactical.replace ~at:step.id cases)
+ | Or es ->
let nb_parts,parts = PartitionsQQ.get vars es in
if nb_parts=1 then Not_applicable
else begin
- feedback#set_title "Split (exists and)" ;
- feedback#set_descr
- "Decompose the Quantifier into %d Blocks" nb_parts ;
- let bind es =
- bind Exists ~vars (F.e_and (F.Tset.elements es)) in
- let goal i n es =
- Printf.sprintf "Goal %d/%d" i n , F.p_bool (bind es) in
- Applicable (Tactical.split (Tactical.mapi goal parts))
+ feedback#set_title "Split (forall or)" ;
+ feedback#set_descr "Decompose the Quantifier between %d parts of the Disjunction" nb_parts ;
+ let bind es = bind Forall ~vars (F.e_or (F.Tset.elements es)) in
+ let goal i n es = Printf.sprintf "Goal %d/%d" i n , When (F.p_bool (bind es)) in
+ let cases = Tactical.mapi goal parts in
+ Applicable (Tactical.replace ~at:step.id cases)
end
- | _ -> Not_applicable
- end
- | And es ->
- let n = List.length es in
- feedback#set_title "Split (and)" ;
- feedback#set_descr
- "Decompose between the %d parts of the Conjunction" n ;
- let goal i n e = Printf.sprintf "Goal %d/%d" i n , F.p_bool e in
- Applicable (Tactical.split (Tactical.mapi goal es))
- | Eq(x,y) when (F.is_prop x) && (F.is_prop y) ->
- feedback#set_title "Split (iff)" ;
- feedback#set_descr "Turn Equivalence into Implications" ;
- let p = F.p_bool (F.e_imply [x] y) in
- let q = F.p_bool (F.e_imply [y] x) in
- let cases = [ "Necessity" , p ; "Sufficiency" , q ] in
- Applicable (Tactical.split cases)
- | Neq(x,y) when (F.is_prop x) && (F.is_prop y) ->
- feedback#set_title "Split (xor)" ;
- feedback#set_descr "Turn Dis-Equivalence into Implications" ;
- let p = F.p_bool (F.e_imply [x] (e_not y)) in
- let q = F.p_bool (F.e_imply [y] (e_not x)) in
- let cases = [ "Necessity" , p ; "Sufficiency" , q ] in
- Applicable (Tactical.split cases)
- | If(c,p,q) -> (* Split + intro *)
+ | _ -> Not_applicable
+ end
+ | Or xs ->
+ let n = List.length xs in
+ feedback#set_title "Split (or)" ;
+ feedback#set_descr "Distinguish the %d parts of the Disjunction" n ;
+ let hyp i n e = Printf.sprintf "Case %d/%d" i n , When (F.p_bool e) in
+ let cases = Tactical.mapi hyp xs in
+ Applicable (Tactical.replace ~at:step.id cases)
+ | Eq(x,y) when (F.is_prop x)&&(F.is_prop y) ->
+ feedback#set_title "Split (iff)";
+ feedback#set_descr "Decompose Equivalence into both True/False" ;
+ let p = F.p_bool x in
+ let q = F.p_bool y in
+ let cases = [
+ "Both True" , When F.(p_and p q) ;
+ "Both False" , When F.(p_and (p_not p) (p_not q)) ;
+ ] in
+ Applicable (Tactical.replace ~at:step.id cases)
+ | Neq(x,y) when (F.is_prop x)&&(F.is_prop y) ->
+ feedback#set_title "Split (xor)";
+ feedback#set_descr "Decompose Dis-Equivalence into alternated True/False" ;
+ let p = F.p_bool x in
+ let q = F.p_bool y in
+ let cases = [
+ "True/False" , When F.(p_and p (p_not q)) ;
+ "False/True" , When F.(p_and (p_not p) q) ;
+ ] in
+ Applicable (Tactical.replace ~at:step.id cases)
+ | Neq(x,y) when not (is_prop x || is_prop y) ->
+ split_neq (Some step.id) x y
+ | Eq(x,y) when not (is_prop x || is_prop y) ->
+ split_eq (Some step.id) x y
+ | Lt(x,y) ->
+ split_lt (Some step.id) x y
+ | Leq(x,y) ->
+ split_leq (Some step.id) x y
+ | If(c,p,q) ->
feedback#set_title "Split (if)" ;
- feedback#set_descr "Decompose Conditional into Branches" ;
- let p = F.p_bool (F.e_imply [c] p) in
- let q = F.p_bool (F.e_imply [e_not c] q) in
- let cases = [ "Then" , p ; "Else" , q ] in
- Applicable (Tactical.split cases)
- | _ ->
- Not_applicable
- end
- | Clause(Step step) ->
- begin
- match step.condition with
- | State _ -> Not_applicable
- | Branch(p,_,_) ->
- feedback#set_title "Split (branch)" ;
- feedback#set_descr "Decompose Conditional into Branches" ;
- let cases = [ "Then" , p ; "Else" , p_not p ] in
- Applicable (Tactical.insert ~at:step.id cases)
- | Either seqs ->
- let n = List.length seqs in
- feedback#set_title "Split (switch)" ;
- feedback#set_descr "Decompose each %d Cases" n ;
- let either i n s = Printf.sprintf "Case %d/%d" i n , Either [s] in
- let cases = Tactical.mapi either seqs in
+ feedback#set_descr "Split Conditional into Branches" ;
+ let p = F.p_bool (F.e_and [c;p]) in
+ let q = F.p_bool (F.e_and [e_not c;q]) in
+ let cases = [ "Then" , When p ; "Else" , When q ] in
Applicable (Tactical.replace ~at:step.id cases)
- | (Type p | Have p | When p | Core p | Init p) ->
- begin
- let open Qed.Logic in
- match F.e_expr p with
- | Bind (Forall,_,_) -> begin
- let vars,q = PartitionsQQ.destructs_qq feedback#pool ~is_forall:true (e_prop p) in
- match Lang.F.repr q with
- | If (c,p,q) ->
- if F.Vars.is_empty (F.Vars.inter (F.vars c) vars) then
- begin (* unbound condition: so, the If is considered as a disjunction *)
- feedback#set_title "Split (forall if)" ;
- feedback#set_descr "Decompose unbound conditional into Branches" ;
- let p = F.p_bool (F.e_and [c; (bind Exists ~vars p)]) in
- let q = F.p_bool (F.e_and [(e_not c); (bind Exists ~vars q)]) in
- let cases = [ "Then" , When p ; "Else" , When q ] in
- Applicable (Tactical.replace ~at:step.id cases)
- end
- else
- begin
- feedback#set_title "Split (rewrite forall if)" ;
- feedback#set_descr "Rewrite the Conditional in a Conjunction and Distributes the Quantifier under the Conjunction" ;
- let p = bind Exists ~vars (F.e_imply [c] p) in
- let q = bind Exists ~vars (F.e_imply [e_not c] q) in
- let cases = [ "Split (rewrite exists if)" , When (F.p_bool (F.e_and [p;q])) ] in
- Applicable (Tactical.replace ~at:step.id cases)
- end
- | And es ->
- feedback#set_title "Split (forall and)" ;
- feedback#set_descr "Distributes the Quantifier under the Conjunction" ;
- let p = F.p_bool (F.e_and (List.map (bind Forall ~vars) es)) in
- let cases = [ "Split (distrib forall and)" , When p ] in
- Applicable (Tactical.replace ~at:step.id cases)
- | Or es ->
- let nb_parts,parts = PartitionsQQ.get vars es in
- if nb_parts=1 then Not_applicable
- else begin
- feedback#set_title "Split (forall or)" ;
- feedback#set_descr "Decompose the Quantifier between %d parts of the Disjunction" nb_parts ;
- let bind es = bind Forall ~vars (F.e_or (F.Tset.elements es)) in
- let goal i n es = Printf.sprintf "Goal %d/%d" i n , When (F.p_bool (bind es)) in
- let cases = Tactical.mapi goal parts in
- Applicable (Tactical.replace ~at:step.id cases)
- end
- | _ -> Not_applicable
- end
- | Or xs ->
- let n = List.length xs in
- feedback#set_title "Split (or)" ;
- feedback#set_descr "Distinguish the %d parts of the Disjunction" n ;
- let hyp i n e = Printf.sprintf "Case %d/%d" i n , When (F.p_bool e) in
- let cases = Tactical.mapi hyp xs in
- Applicable (Tactical.replace ~at:step.id cases)
- | Eq(x,y) when (F.is_prop x)&&(F.is_prop y) ->
- feedback#set_title "Split (iff)";
- feedback#set_descr "Decompose Equivalence into both True/False" ;
- let p = F.p_bool x in
- let q = F.p_bool y in
- let cases = [
- "Both True" , When F.(p_and p q) ;
- "Both False" , When F.(p_and (p_not p) (p_not q)) ;
- ] in
- Applicable (Tactical.replace ~at:step.id cases)
- | Neq(x,y) when (F.is_prop x)&&(F.is_prop y) ->
- feedback#set_title "Split (xor)";
- feedback#set_descr "Decompose Dis-Equivalence into alternated True/False" ;
- let p = F.p_bool x in
- let q = F.p_bool y in
- let cases = [
- "True/False" , When F.(p_and p (p_not q)) ;
- "False/True" , When F.(p_and (p_not p) q) ;
- ] in
- Applicable (Tactical.replace ~at:step.id cases)
- | Neq(x,y) when not (is_prop x || is_prop y) ->
- split_neq (Some step.id) x y
- | Eq(x,y) when not (is_prop x || is_prop y) ->
- split_eq (Some step.id) x y
- | Lt(x,y) ->
- split_lt (Some step.id) x y
- | Leq(x,y) ->
- split_leq (Some step.id) x y
- | If(c,p,q) ->
- feedback#set_title "Split (if)" ;
- feedback#set_descr "Split Conditional into Branches" ;
- let p = F.p_bool (F.e_and [c;p]) in
- let q = F.p_bool (F.e_and [e_not c;q]) in
- let cases = [ "Then" , When p ; "Else" , When q ] in
- Applicable (Tactical.replace ~at:step.id cases)
- | And ps ->
- let cond p = (* keep original kind of step *)
- match step.condition with
- | Type _ -> Type p
- | Have _ -> Have p
- | When _ -> When p
- | Core _ -> Core p
- | Init _ -> Init p
- | _ -> assert false (* see above pattern matching *)
- in
- feedback#set_title "Split (conjunction)" ;
- feedback#set_descr "Split conjunction into steps" ;
- let ps = List.map (fun p -> cond @@ p_bool p) ps in
- Applicable (Tactical.replace_step ~at:step.id ps)
- | _ ->
- Not_applicable
- end
- end
+ | And ps ->
+ let cond p = (* keep original kind of step *)
+ match step.condition with
+ | Type _ -> Type p
+ | Have _ -> Have p
+ | When _ -> When p
+ | Core _ -> Core p
+ | Init _ -> Init p
+ | _ -> assert false (* see above pattern matching *)
+ in
+ feedback#set_title "Split (conjunction)" ;
+ feedback#set_descr "Split conjunction into steps" ;
+ let ps = List.map (fun p -> cond @@ p_bool p) ps in
+ Applicable (Tactical.replace_step ~at:step.id ps)
+ | _ ->
+ Not_applicable
+ end
+ end
end
diff --git a/src/plugins/wp/TacUnfold.ml b/src/plugins/wp/TacUnfold.ml
index e64bfec45f97b0c11f2004a0050c429fc77fc090..f95a7645cf8e1af64b2aaad8e798fd7098d25cef 100644
--- a/src/plugins/wp/TacUnfold.ml
+++ b/src/plugins/wp/TacUnfold.ml
@@ -34,13 +34,13 @@ let definition f es =
let d = find_symbol f in
match d.d_definition with
| Function(_,_,u) ->
- let sigma = Lang.subst d.d_params es in
- F.e_subst sigma u
+ let sigma = Lang.subst d.d_params es in
+ F.e_subst sigma u
| Predicate(_,p) ->
- let sigma = Lang.subst d.d_params es in
- F.e_prop (F.p_subst sigma p)
+ let sigma = Lang.subst d.d_params es in
+ F.e_prop (F.p_subst sigma p)
| _ ->
- raise Not_found
+ raise Not_found
let range f es =
let a,b = Ctypes.bounds (Cint.is_cint f) in
@@ -53,16 +53,16 @@ let range f es =
let rec applicable ?at e f es = function
| phi::others ->
- begin
- try
- let v = phi f es in
- let d = Pretty_utils.sfprintf "Unfold '%a'" Lang.Fun.pretty f in
- Applicable (Tactical.rewrite ?at [d,F.p_true,e,v])
- with Not_found | Invalid_argument _ ->
- applicable ?at e f es others
- end
+ begin
+ try
+ let v = phi f es in
+ let d = Pretty_utils.sfprintf "Unfold '%a'" Lang.Fun.pretty f in
+ Applicable (Tactical.rewrite ?at [d,F.p_true,e,v])
+ with Not_found | Invalid_argument _ ->
+ applicable ?at e f es others
+ end
| [] ->
- Not_applicable
+ Not_applicable
(* Used only for Multi selection *)
@@ -83,28 +83,28 @@ let condition original p = (* keep original kind of simple condition *)
let collect_term_to_unfold (g, m) = function
| Inside(Step step, unfold) ->
- let l =
- try Smap.find step m
- with Not_found -> []
- in
- g, Smap.add step (unfold :: l) m
+ let l =
+ try Smap.find step m
+ with Not_found -> []
+ in
+ g, Smap.add step (unfold :: l) m
| Inside (Goal _, unfold) ->
- begin match g with
- | None -> Some [ unfold ], m
- | Some g -> Some (unfold :: g), m
- end
+ begin match g with
+ | None -> Some [ unfold ], m
+ | Some g -> Some (unfold :: g), m
+ end
| _ -> raise Not_found
let rec collect_unfold phis m e =
match phis with
| phi :: others ->
- begin
- try
- match F.repr e with
- | Qed.Logic.Fun(f,es) -> Lang.F.Tmap.add e (phi f es) m
- | _ -> raise Not_found
- with Not_found | Invalid_argument _ -> collect_unfold others m e
- end
+ begin
+ try
+ match F.repr e with
+ | Qed.Logic.Fun(f,es) -> Lang.F.Tmap.add e (phi f es) m
+ | _ -> raise Not_found
+ with Not_found | Invalid_argument _ -> collect_unfold others m e
+ end
| [] -> m
let unfolds_from_list phis es =
@@ -118,9 +118,9 @@ let tactical_inside step unfolds sequent =
then raise Not_found
else match step.condition with
| Type p | Have p | When p | Core p | Init p ->
- let subst t = Lang.F.Tmap.find t unfolds in
- let p = condition step @@ Lang.p_subst subst p in
- snd @@ Tactical.replace_single ~at:step.id ("Unfolded", p) sequent
+ let subst t = Lang.F.Tmap.find t unfolds in
+ let p = condition step @@ Lang.p_subst subst p in
+ snd @@ Tactical.replace_single ~at:step.id ("Unfolded", p) sequent
| _ -> raise Not_found
let tactical_goal unfolds (seq, g) =
@@ -151,18 +151,18 @@ class unfold =
let unfoldings = [ definition ; range ] in
match s with
| Multi es ->
- let goal, steps =
- List.fold_left collect_term_to_unfold (None, Smap.empty) es in
- let goal = Option.map (unfolds_from_list unfoldings) goal in
- let steps = unfolds_from_smap unfoldings steps in
- Applicable (process @@ fold_selection goal steps)
+ let goal, steps =
+ List.fold_left collect_term_to_unfold (None, Smap.empty) es in
+ let goal = Option.map (unfolds_from_list unfoldings) goal in
+ let steps = unfolds_from_smap unfoldings steps in
+ Applicable (process @@ fold_selection goal steps)
| s ->
- let at = Tactical.at s in
- let e = Tactical.selected s in
- match F.repr e with
- | Qed.Logic.Fun(f,es) ->
- applicable ?at e f es unfoldings
- | _ -> Not_applicable
+ let at = Tactical.at s in
+ let e = Tactical.selected s in
+ match F.repr e with
+ | Qed.Logic.Fun(f,es) ->
+ applicable ?at e f es unfoldings
+ | _ -> Not_applicable
end
let tactical = Tactical.export (new unfold)
diff --git a/src/plugins/wp/Tactical.ml b/src/plugins/wp/Tactical.ml
index 1da597fa8d3801f73d9ccea94c08f929a52f5d03..e31cbbb38ec37d79189d134e958bf8f722ef0cd2 100644
--- a/src/plugins/wp/Tactical.ml
+++ b/src/plugins/wp/Tactical.ml
@@ -45,10 +45,10 @@ class type composer =
let rec insert_group cc = function
| [] -> [cc#group , [cc]]
| (( gid , ccs ) as group ):: others ->
- if cc#group = gid then
- ( gid , ccs @ [cc] ) :: others
- else
- group :: insert_group cc others
+ if cc#group = gid then
+ ( gid , ccs @ [cc] ) :: others
+ else
+ group :: insert_group cc others
let add_composer (c : #composer) =
let id = c#id in
@@ -115,23 +115,23 @@ let get_int = function
| Empty -> None
| Compose(Cint a) -> get_int_z a
| s ->
- match Lang.F.repr (selected s) with
- | Qed.Logic.Kint z -> get_int_z z
- | _ -> None
+ match Lang.F.repr (selected s) with
+ | Qed.Logic.Kint z -> get_int_z z
+ | _ -> None
let subclause clause p =
match clause with
| Step s ->
- let hs = Conditions.have s in
- hs == p ||
- ( match Lang.F.p_expr hs with
- | Qed.Logic.And ps -> List.memq p ps
- | _ -> false )
+ let hs = Conditions.have s in
+ hs == p ||
+ ( match Lang.F.p_expr hs with
+ | Qed.Logic.And ps -> List.memq p ps
+ | _ -> false )
| Goal hs ->
- hs == p ||
- ( match Lang.F.p_expr hs with
- | Qed.Logic.Or ps -> List.memq p ps
- | _ -> false )
+ hs == p ||
+ ( match Lang.F.p_expr hs with
+ | Qed.Logic.Or ps -> List.memq p ps
+ | _ -> false )
let pp_clause fmt = function
| Goal _ -> Format.pp_print_string fmt "Goal"
@@ -140,20 +140,20 @@ let pp_clause fmt = function
let rec pp_selection fmt = function
| Empty -> Format.pp_print_string fmt "Empty"
| Inside(c,t) ->
- Format.fprintf fmt "Term %d in %a" (Lang.F.QED.id t) pp_clause c
+ Format.fprintf fmt "Term %d in %a" (Lang.F.QED.id t) pp_clause c
| Clause c -> pp_clause fmt c
| Compose(Cint k) ->
- Format.fprintf fmt "Constant '%a'" Integer.pretty k
+ Format.fprintf fmt "Constant '%a'" Integer.pretty k
| Compose(Range(a,b)) ->
- Format.fprintf fmt "Range '%d..%d'" a b
+ Format.fprintf fmt "Range '%d..%d'" a b
| Compose(Code(_,id,es)) ->
- Format.fprintf fmt "@[<hov 2>Compose '%s'" id ;
- List.iter (fun e -> Format.fprintf fmt "(%a)" pp_selection e) es ;
- Format.fprintf fmt "@]"
+ Format.fprintf fmt "@[<hov 2>Compose '%s'" id ;
+ List.iter (fun e -> Format.fprintf fmt "(%a)" pp_selection e) es ;
+ Format.fprintf fmt "@]"
| Multi es ->
- Format.fprintf fmt "@[<hov 2>Multi-selection" ;
- List.iter (fun e -> Format.fprintf fmt "(%a)" pp_selection e) es ;
- Format.fprintf fmt "@]"
+ Format.fprintf fmt "@[<hov 2>Multi-selection" ;
+ List.iter (fun e -> Format.fprintf fmt "(%a)" pp_selection e) es ;
+ Format.fprintf fmt "@]"
let int a = Compose(Cint (Integer.of_int a))
let cint a = Compose(Cint a)
@@ -174,12 +174,12 @@ let findhead (s:selection) e =
| Empty -> None
| Compose(Range _ | Cint _) -> None
| Inside(clause,_) | Clause clause ->
- let p = Lang.F.e_prop (head clause) in
- if Lang.F.is_subterm e p
- then Some(Inside(clause,e))
- else None
+ let p = Lang.F.e_prop (head clause) in
+ if Lang.F.is_subterm e p
+ then Some(Inside(clause,e))
+ else None
| Compose(Code(v,_,_)) as s ->
- if v == e then Some s else None
+ if v == e then Some s else None
| Multi _ -> None
let rec lookup (s:selection) e q =
@@ -190,7 +190,7 @@ let rec lookup (s:selection) e q =
and lookup_inner (s:selection) e q =
begin match s with
| Compose(Code(_,_,ps)) ->
- List.iter (fun p -> Queue.add p q) ps
+ List.iter (fun p -> Queue.add p q) ps
| _ -> ()
end ;
if Queue.is_empty q then None else lookup (Queue.pop q) e q
@@ -199,17 +199,17 @@ and subterm (s:selection) e =
match Lang.F.repr e with
| Qed.Logic.Kint z -> Some (cint z)
| _ ->
- match findhead s e with
- | Some _ as result -> result
- | None -> lookup_inner s e (Queue.create ())
+ match findhead s e with
+ | Some _ as result -> result
+ | None -> lookup_inner s e (Queue.create ())
let rec subterms s = function
| [] -> []
| e::es ->
- let ps = subterms s es in
- match subterm s e with
- | None -> ps
- | Some p -> p::ps
+ let ps = subterms s es in
+ match subterm s e with
+ | None -> ps
+ | Some p -> p::ps
let destruct_value s =
let v = selected s in
@@ -223,17 +223,17 @@ let destruct_value s =
| Rdef fvs -> subterms s (List.map snd fvs)
| Times(k,v) -> cint k :: subterms s [v]
| Div(a,b) | Mod(a,b) | Eq(a,b) | Neq(a,b) | Lt(a,b) | Leq(a,b) | Aget(a,b) ->
- subterms s [a;b]
+ subterms s [a;b]
let destruct = function
| Empty | Compose(Cint _) -> []
| Compose(Range(a,b)) -> [int a;int b]
| s ->
- let ps = destruct_value s in
- if ps <> [] then ps else
- match s with
- | Compose(Code(_,_,ps)) -> ps
- | _ -> []
+ let ps = destruct_value s in
+ if ps <> [] then ps else
+ match s with
+ | Compose(Code(_,_,ps)) -> ps
+ | _ -> []
(* -------------------------------------------------------------------------- *)
(* --- Fields --- *)
@@ -287,7 +287,7 @@ let checkbox ~id ~title ~descr ?(default=false) () =
let spinner ~id ~title ~descr ?default ?vmin ?vmax ?(vstep=1) () =
let () = match vmin , vmax with
| Some a , Some b ->
- if a >= b then raise (Invalid_argument "Tactical.spinner")
+ if a >= b then raise (Invalid_argument "Tactical.spinner")
| _ -> () in
let default = match default, vmin, vmax with
| Some v , _ , _ -> v
@@ -301,9 +301,9 @@ let selector ~id ~title ~descr ?default ~options ?(equal=(=)) () =
let default = match default,options with
| _ , [] -> raise (Invalid_argument "Tactical.selector(empty)")
| Some value , vs ->
- if List.for_all (fun v -> equal v.value value) vs
- then raise (Invalid_argument "Tactical.selector(default)") ;
- value
+ if List.for_all (fun v -> equal v.value value) vs
+ then raise (Invalid_argument "Tactical.selector(default)") ;
+ value
| None , {value}::_ -> value in
let fd = field ~id ~title ~descr ~default in
fd , Selector(fd,options,equal)
@@ -478,11 +478,11 @@ let () = add_composer
method arity = 2
method filter = function
| [a;b] ->
- (try
- let ta = F.typeof a in
- let tb = F.typeof b in
- F.Tau.equal ta tb
- with Not_found -> false)
+ (try
+ let ta = F.typeof a in
+ let tb = F.typeof b in
+ F.Tau.equal ta tb
+ with Not_found -> false)
| _ -> false
method compute = function [a;b] -> F.e_eq a b | _ -> F.e_true
end)
@@ -653,15 +653,15 @@ let () = add_composer
method arity = 2
method filter = function
| [a;b] ->
- begin
- try
- let ta = F.typeof a in
- let tb = F.typeof b in
- match ta with
- | Qed.Logic.Array(tm,_) -> F.Tau.equal tm tb
- | _ -> false
- with Not_found -> false
- end
+ begin
+ try
+ let ta = F.typeof a in
+ let tb = F.typeof b in
+ match ta with
+ | Qed.Logic.Array(tm,_) -> F.Tau.equal tm tb
+ | _ -> false
+ with Not_found -> false
+ end
| _ -> false
method compute = function [a;b] -> F.e_get a b | _ -> F.e_int 0
end)
@@ -675,18 +675,18 @@ let () = add_composer
method arity = 3
method filter = function
| [a;b;c] ->
- begin
- try
- let ta = F.typeof a in
- let tb = F.typeof b in
- let tc = F.typeof c in
- match ta with
- | Qed.Logic.Array(tm,tv) ->
- F.Tau.equal tm tb &&
- F.Tau.equal tv tc
- | _ -> false
- with Not_found -> false
- end
+ begin
+ try
+ let ta = F.typeof a in
+ let tb = F.typeof b in
+ let tc = F.typeof c in
+ match ta with
+ | Qed.Logic.Array(tm,tv) ->
+ F.Tau.equal tm tb &&
+ F.Tau.equal tv tc
+ | _ -> false
+ with Not_found -> false
+ end
| _ -> false
method compute = function [a;b] -> F.e_get a b | _ -> F.e_int 0
end)
diff --git a/src/plugins/wp/VC.ml b/src/plugins/wp/VC.ml
index 4c9c013695cf456b287d57b70fd109bf6a1a380c..d2641050677c979a1fc309159ddf1db5d5e5566b 100644
--- a/src/plugins/wp/VC.ml
+++ b/src/plugins/wp/VC.ml
@@ -46,8 +46,8 @@ let get_formula po =
match po.po_formula with
| GoalLemma l -> l.VC_Lemma.lemma.Definitions.l_lemma
| GoalAnnot { VC_Annot.goal = g } ->
- WpContext.on_context
- (get_context po) (Wpo.GOAL.compute_proof ~pid:po.po_pid) g
+ WpContext.on_context
+ (get_context po) (Wpo.GOAL.compute_proof ~pid:po.po_pid) g
let clear = Wpo.clear
let proof = Wpo.goals_of_property
@@ -55,13 +55,13 @@ let iter_ip on_goal ip = Wpo.iter ~ip ~on_goal ()
let iter_kf on_goal ?bhv kf =
match bhv with
| None ->
- (* iter on all behaviors, see Wpo.iter *)
- Wpo.iter ~index:(Wpo.Function(kf,None)) ~on_goal ()
+ (* iter on all behaviors, see Wpo.iter *)
+ Wpo.iter ~index:(Wpo.Function(kf,None)) ~on_goal ()
| Some bs ->
- List.iter
- (fun b ->
- Wpo.iter ~index:(Wpo.Function(kf,Some b)) ~on_goal ()
- ) bs
+ List.iter
+ (fun b ->
+ Wpo.iter ~index:(Wpo.Function(kf,Some b)) ~on_goal ()
+ ) bs
let remove = iter_ip Wpo.remove
let () = Property_status.register_property_remove_hook remove
diff --git a/src/plugins/wp/VCS.ml b/src/plugins/wp/VCS.ml
index 2faa6011629180a42c57748deef6e8074fd42600..f5106289bcf2daaebb5010cc98068408a92dbd41 100644
--- a/src/plugins/wp/VCS.ml
+++ b/src/plugins/wp/VCS.ml
@@ -47,20 +47,20 @@ let parse_prover = function
Why3.Whyconf.prover_version = "";
Why3.Whyconf.prover_altern = "generate only" })
| s ->
- let prv = String.split_on_char ':' s in
- let prv = match prv with "why3"::prv -> prv | _ -> prv in
- let name = String.concat "," prv in
- match Why3Provers.find_fallback name with
- | Exact p -> Some (Why3 p)
- | Fallback p ->
- Wp_parameters.warning ~current:false ~once:true
- "Prover '%s' not found, fallback to '%s'"
- (String.concat ":" prv) (Why3Provers.print_wp p) ;
- Some (Why3 p)
- | NotFound ->
- Wp_parameters.error ~once:true
- "Prover '%s' not found in why3.conf" name ;
- None
+ let prv = String.split_on_char ':' s in
+ let prv = match prv with "why3"::prv -> prv | _ -> prv in
+ let name = String.concat "," prv in
+ match Why3Provers.find_fallback name with
+ | Exact p -> Some (Why3 p)
+ | Fallback p ->
+ Wp_parameters.warning ~current:false ~once:true
+ "Prover '%s' not found, fallback to '%s'"
+ (String.concat ":" prv) (Why3Provers.print_wp p) ;
+ Some (Why3 p)
+ | NotFound ->
+ Wp_parameters.error ~once:true
+ "Prover '%s' not found in why3.conf" name ;
+ None
let parse_mode m =
match String.lowercase_ascii m with
@@ -70,9 +70,9 @@ let parse_mode m =
| "update" -> Update
| "fixup" -> FixUpdate
| _ ->
- Wp_parameters.error ~once:true
- "Unrecognized mode %S (use 'batch' instead)" m ;
- Batch
+ Wp_parameters.error ~once:true
+ "Unrecognized mode %S (use 'batch' instead)" m ;
+ Batch
let name_of_prover = function
| Why3 s -> Why3Provers.print_wp s
@@ -81,9 +81,9 @@ let name_of_prover = function
let title_of_prover = function
| Why3 s ->
- if Wp_parameters.has_dkey dkey_shell
- then Why3Provers.name s
- else Why3Provers.title s
+ if Wp_parameters.has_dkey dkey_shell
+ then Why3Provers.name s
+ else Why3Provers.title s
| Qed -> "Qed"
| Tactical -> "Script"
@@ -117,15 +117,15 @@ let is_auto = function
| Qed -> true
| Tactical -> false
| Why3 p ->
- match p.prover_name with
- | "Alt-Ergo" | "CVC4" | "Z3" -> true
- | "Coq" -> false
- | _ ->
- let config = Why3Provers.config () in
- try
- let prover_config = Why3.Whyconf.get_prover_config config p in
- not prover_config.interactive
- with Not_found -> true
+ match p.prover_name with
+ | "Alt-Ergo" | "CVC4" | "Z3" -> true
+ | "Coq" -> false
+ | _ ->
+ let config = Why3Provers.config () in
+ try
+ let prover_config = Why3.Whyconf.get_prover_config config p in
+ not prover_config.interactive
+ with Not_found -> true
let cmp_prover p q =
match p,q with
@@ -166,9 +166,9 @@ let default = { valid = false ; timeout = None ; stepout = None }
let get_timeout ~smoke = function
| { timeout = None } ->
- if smoke
- then Wp_parameters.SmokeTimeout.get ()
- else Wp_parameters.Timeout.get ()
+ if smoke
+ then Wp_parameters.SmokeTimeout.get ()
+ else Wp_parameters.Timeout.get ()
| { timeout = Some t } -> t
let get_stepout = function
diff --git a/src/plugins/wp/Vlist.ml b/src/plugins/wp/Vlist.ml
index 76423f7fee8de99ce2a543a5d264bc5c18128ed5..55feed3b6a8d57e9c0cde4963f099e19bdeb7340 100644
--- a/src/plugins/wp/Vlist.ml
+++ b/src/plugins/wp/Vlist.ml
@@ -161,19 +161,19 @@ let rewrite_length e =
| L.Fun( nil , [] ) when nil == f_nil -> F.e_zero (* \length([]) == 0 *)
| L.Fun( elt , [_] ) when elt == f_elt -> F.e_one (* \length([x]) == 1 *)
| L.Fun( concat , es ) when concat == f_concat -> (* \length(\concat(...,x_i,...)) == \sum(...,\length(x_i),...) *)
- F.e_sum (List.map v_length es)
+ F.e_sum (List.map v_length es)
| L.Fun( repeat , [ u ; n ] ) when repeat == f_repeat ->
- (* \length(u ^* n) == if 0<=n then n * \length(u) else 0 *)
- F.e_if (F.e_leq e_zero n) (F.e_mul n (v_length u)) e_zero
+ (* \length(u ^* n) == if 0<=n then n * \length(u) else 0 *)
+ F.e_if (F.e_leq e_zero n) (F.e_mul n (v_length u)) e_zero
| _ ->
- (* NB. do not considers \Cons because they are removed *)
- raise Not_found
+ (* NB. do not considers \Cons because they are removed *)
+ raise Not_found
let match_natural k =
match F.repr k with
| L.Kint z ->
- let k = try Integer.to_int_exn z with Z.Overflow -> raise Not_found in
- if 0 <= k then k else raise Not_found
+ let k = try Integer.to_int_exn z with Z.Overflow -> raise Not_found in
+ if 0 <= k then k else raise Not_found
| _ -> raise Not_found
(* Why3 definition: [\nth(e,k)] is undefined for [k<0 || k>=\length(e)].
@@ -182,21 +182,21 @@ let rec get_nth k e =
match F.repr e with
| L.Fun( concat , list ) when concat == f_concat -> get_nth_list k list
| L.Fun( elt , [x] ) when elt == f_elt ->
- get_nth_elt k x (fun _ -> raise Not_found)
+ get_nth_elt k x (fun _ -> raise Not_found)
| L.Fun( repeat , [x;n] ) when repeat == f_repeat ->
- get_nth_repeat k x n (fun _ -> raise Not_found)
+ get_nth_repeat k x n (fun _ -> raise Not_found)
| _ -> raise Not_found
and get_nth_list k = function
| head::tail ->
- begin
- match F.repr head with
- | L.Fun( elt , [x] ) when elt == f_elt ->
- get_nth_elt k x (fun k -> get_nth_list k tail)
- | L.Fun( repeat , [x;n] ) when repeat == f_repeat ->
- get_nth_repeat k x n (fun k -> get_nth_list k tail)
- | _ -> raise Not_found
- end
+ begin
+ match F.repr head with
+ | L.Fun( elt , [x] ) when elt == f_elt ->
+ get_nth_elt k x (fun k -> get_nth_list k tail)
+ | L.Fun( repeat , [x;n] ) when repeat == f_repeat ->
+ get_nth_repeat k x n (fun k -> get_nth_list k tail)
+ | _ -> raise Not_found
+ end
| [] -> raise Not_found
and get_nth_elt k x f =
@@ -234,24 +234,24 @@ let rewrite_repeat s n =
let rec leftmost a ms =
match F.repr a with
| L.Fun( concat , e :: es ) when concat == f_concat ->
- leftmost e (es@ms)
+ leftmost e (es@ms)
| L.Fun( repeat , [ u ; n ] ) when repeat == f_repeat -> begin
match (* tries to perform some rolling that do not depend on [n] *)
(match ms with
| b::ms ->
- let b,ms = leftmost b ms in
- let u,us = leftmost u [] in
- if F.decide (F.e_eq u b) then
- (* u=b ==> ((u^us)*^n) ^ b ^ ms == u ^ (us^b)*^n) ^ ms *)
- Some (u, v_repeat (v_concat (us@[b]) (F.typeof a)) n (F.typeof a) :: ms)
- else None
+ let b,ms = leftmost b ms in
+ let u,us = leftmost u [] in
+ if F.decide (F.e_eq u b) then
+ (* u=b ==> ((u^us)*^n) ^ b ^ ms == u ^ (us^b)*^n) ^ ms *)
+ Some (u, v_repeat (v_concat (us@[b]) (F.typeof a)) n (F.typeof a) :: ms)
+ else None
| _ -> None) with
| Some res -> res
| None ->
- if F.decide (F.e_lt F.e_zero n) then
- (* 0<n ==> (u*^n) ^ ms == u ^ (u*^(n-1)) ^ ms *)
- leftmost u (v_repeat u (F.e_sub n F.e_one) (F.typeof a) :: ms)
- else a , ms
+ if F.decide (F.e_lt F.e_zero n) then
+ (* 0<n ==> (u*^n) ^ ms == u ^ (u*^(n-1)) ^ ms *)
+ leftmost u (v_repeat u (F.e_sub n F.e_one) (F.typeof a) :: ms)
+ else a , ms
end
| _ -> a , ms
@@ -267,27 +267,27 @@ let leftmost a =
let rec rightmost ms a =
match F.repr a with
| L.Fun( concat , es ) when concat == f_concat ->
- begin match List.rev es with
- | [] -> ms , a
- | e::es -> rightmost (ms @ List.rev es) e
- end
+ begin match List.rev es with
+ | [] -> ms , a
+ | e::es -> rightmost (ms @ List.rev es) e
+ end
| L.Fun( repeat , [ u ; n ] ) when repeat == f_repeat -> begin
match (* tries to perform some rolling that do not depend on [n] *)
(match List.rev ms with
| b::ms ->
- let ms,b = rightmost (List.rev ms) b in
- let us,u = rightmost [] u in
- if F.decide (F.e_eq u b) then
- (* u=b ==> (ms ^ b ^ (us^u)*^n) == ms ^ (b^us)*^n) ^ u *)
- Some (ms @ [ v_repeat (v_concat (b::us) (F.typeof a)) n (F.typeof a)], u)
- else None
+ let ms,b = rightmost (List.rev ms) b in
+ let us,u = rightmost [] u in
+ if F.decide (F.e_eq u b) then
+ (* u=b ==> (ms ^ b ^ (us^u)*^n) == ms ^ (b^us)*^n) ^ u *)
+ Some (ms @ [ v_repeat (v_concat (b::us) (F.typeof a)) n (F.typeof a)], u)
+ else None
| _ -> None) with
| Some res -> res
| None ->
- if F.decide (F.e_lt F.e_zero n) then
- (* 0<n ==> ms ^ (u*^n) == ms ^ (u*^(n-1)) ^ u *)
- rightmost (ms @ [v_repeat u (F.e_sub n F.e_one) (F.typeof a)]) u
- else ms , a
+ if F.decide (F.e_lt F.e_zero n) then
+ (* 0<n ==> ms ^ (u*^n) == ms ^ (u*^(n-1)) ^ u *)
+ rightmost (ms @ [v_repeat u (F.e_sub n F.e_one) (F.typeof a)]) u
+ else ms , a
end
| _ -> ms , a
@@ -306,11 +306,11 @@ let leftmost_eq a b =
if u <> [] || v <> [] then
match F.is_equal a b with
| L.Yes ->
- (* s ^ u1 ^ ... = s ^ v1 ^ ... <=> u1 ^ ... = v1 ^ ... *)
- F.p_equal (v_concat u (F.typeof a)) (v_concat v (F.typeof a))
+ (* s ^ u1 ^ ... = s ^ v1 ^ ... <=> u1 ^ ... = v1 ^ ... *)
+ F.p_equal (v_concat u (F.typeof a)) (v_concat v (F.typeof a))
| L.No when F.decide (F.e_eq (v_length a) (v_length b)) ->
- (* a <> b && \length(a)=\length(b) ==> a ^ u1 ^ ... <> b ^ v1 ^ ... *)
- F.p_false
+ (* a <> b && \length(a)=\length(b) ==> a ^ u1 ^ ... <> b ^ v1 ^ ... *)
+ F.p_false
| _ -> raise Not_found
else
raise Not_found
@@ -321,11 +321,11 @@ let rightmost_eq a b =
if u <> [] || v <> [] then
match F.is_equal a b with
| L.Yes ->
- (* u1 ^ ... ^ s = v1 ^ ... ^ s <=> u1 ^ ... = v1 ^ ... *)
- F.p_equal (v_concat u (F.typeof a)) (v_concat v (F.typeof a))
+ (* u1 ^ ... ^ s = v1 ^ ... ^ s <=> u1 ^ ... = v1 ^ ... *)
+ F.p_equal (v_concat u (F.typeof a)) (v_concat v (F.typeof a))
| L.No when F.decide (F.e_eq (v_length a) (v_length b)) ->
- (* a <> b && \length(a)=\length(b) ==> u1 ^ ... ^ a <> v1 ^ ... ^ b *)
- F.p_false
+ (* a <> b && \length(a)=\length(b) ==> u1 ^ ... ^ a <> v1 ^ ... ^ b *)
+ F.p_false
| _ -> raise Not_found
else
raise Not_found
@@ -334,14 +334,14 @@ let rewrite_is_nil ~nil a =
let p_is_nil a = F.p_equal nil a in
match F.repr a with
| L.Fun(concat,es) when concat == f_concat ->
- (* \concat (s1,...,sn)==[] <==> (s1==[] && ... && sn==[]) *)
- F.p_all p_is_nil es
+ (* \concat (s1,...,sn)==[] <==> (s1==[] && ... && sn==[]) *)
+ F.p_all p_is_nil es
| L.Fun(elt,[_]) when elt == f_elt -> F.p_false (* [x]==[] <==> false *)
| L.Fun(repeat,[s;n]) when repeat == f_repeat ->
- (* (s *^ n)==[] <==> (s==[] || n<=0) *)
- F.p_or (F.p_leq n F.e_zero) (p_is_nil s)
+ (* (s *^ n)==[] <==> (s==[] || n<=0) *)
+ F.p_or (F.p_leq n F.e_zero) (p_is_nil s)
| _ ->
- raise Not_found
+ raise Not_found
(* Ensures xs to be a sub-sequence of ys, otherwise raise Not_found
In such a case, (concat xs = concat ys) <==> (forall r in result, r = nil) *)
@@ -349,7 +349,7 @@ let rec subsequence xs ys =
match xs , ys with
| [],ys -> ys
| x::rxs, y::rys ->
- if (F.decide (e_eq x y)) then subsequence rxs rys else y :: subsequence xs rys
+ if (F.decide (e_eq x y)) then subsequence rxs rys else y :: subsequence xs rys
| _ -> raise Not_found
let elements a =
@@ -399,46 +399,46 @@ let rewrite_eq_sequence a b =
| L.Fun(nil,[]) , _ when nil == f_nil -> rewrite_is_nil ~nil:a b
| _ , L.Fun(nil,[]) when nil == f_nil -> rewrite_is_nil ~nil:b a
| _ -> try
- match F.repr a , F.repr b with
- | L.Fun(repeat_a, [x;n]), L.Fun(repeat_b, [y;m])
- when repeat_a == f_repeat &&
- repeat_b == f_repeat ->
- repeat_eq a x n b y m
- | _ ->
- try leftmost_eq a b with Not_found ->
- try rightmost_eq a b with Not_found ->
- subsequence a b
- with Not_found ->
- if F.decide (F.e_neq (v_length a) (v_length b)) then
- F.p_false
- else raise Not_found
+ match F.repr a , F.repr b with
+ | L.Fun(repeat_a, [x;n]), L.Fun(repeat_b, [y;m])
+ when repeat_a == f_repeat &&
+ repeat_b == f_repeat ->
+ repeat_eq a x n b y m
+ | _ ->
+ try leftmost_eq a b with Not_found ->
+ try rightmost_eq a b with Not_found ->
+ subsequence a b
+ with Not_found ->
+ if F.decide (F.e_neq (v_length a) (v_length b)) then
+ F.p_false
+ else raise Not_found
let rewrite_eq_length a b =
match F.repr a , F.repr b with
| L.Fun(length_a,[_]), L.Fun(length_b,[_]) when length_a == f_length &&
length_b == f_length ->
- (* N.B. cannot be simplified by the next patterns *)
- raise Not_found
+ (* N.B. cannot be simplified by the next patterns *)
+ raise Not_found
| _, L.Fun(length,[_]) when length == f_length &&
F.decide (e_lt a e_zero) ->
- (* a < 0 ==> ( a=\length(b) <=> false ) *)
- F.p_false
+ (* a < 0 ==> ( a=\length(b) <=> false ) *)
+ F.p_false
| L.Fun(length,[_]), _ when length == f_length &&
F.decide (e_lt b e_zero) ->
- (* b < 0 ==> ( \length(a)<=b <=> false ) *)
- F.p_false
+ (* b < 0 ==> ( \length(a)<=b <=> false ) *)
+ F.p_false
| _ -> raise Not_found
let rewrite_leq_length a b =
match F.repr a , F.repr b with
| L.Fun(length_a,[_]), L.Fun(length_b,[_]) when length_a == f_length &&
length_b == f_length ->
- (* N.B. cannot be simplified by the next patterns *)
- raise Not_found
+ (* N.B. cannot be simplified by the next patterns *)
+ raise Not_found
| L.Fun(length,[_]), _ when length == f_length &&
F.decide (e_lt b e_zero) ->
- (* b < 0 ==> ( \length(a)<=b <=> false ) *)
- F.e_false
+ (* b < 0 ==> ( \length(a)<=b <=> false ) *)
+ F.e_false
(* N.B. the next rule does not allow to split on the sign of \length(a) with TIP
| _, L.Fun(length,[_]) when length == f_length &&
F.decide (e_leq a e_zero) ->
@@ -500,37 +500,37 @@ class type engine =
let rec export (engine : #engine) fmt = function
| [] ->
- begin match engine#callstyle with
- | E.CallVoid -> Format.pp_print_string fmt "nil()"
- | E.CallVar|E.CallApply -> Format.pp_print_string fmt "nil"
- end
+ begin match engine#callstyle with
+ | E.CallVoid -> Format.pp_print_string fmt "nil()"
+ | E.CallVar|E.CallApply -> Format.pp_print_string fmt "nil"
+ end
| e::es ->
- begin match F.repr e with
- | L.Fun( elt , [x] ) when elt == f_elt ->
- apply engine fmt "cons" x es
- | _ ->
- apply engine fmt "concat" e es
- end
+ begin match F.repr e with
+ | L.Fun( elt , [x] ) when elt == f_elt ->
+ apply engine fmt "cons" x es
+ | _ ->
+ apply engine fmt "concat" e es
+ end
and apply (engine : #engine) fmt f x es =
match engine#callstyle with
| E.CallVar | E.CallVoid ->
- Format.fprintf fmt "@[<hov 2>%s(@,%a,@,%a)@]"
- f engine#pp_flow x (export engine) es
+ Format.fprintf fmt "@[<hov 2>%s(@,%a,@,%a)@]"
+ f engine#pp_flow x (export engine) es
| E.CallApply ->
- Format.fprintf fmt "@[<hov 2>(%s@ %a@ %a)@]"
- f engine#pp_atom x (export engine) es
+ Format.fprintf fmt "@[<hov 2>(%s@ %a@ %a)@]"
+ f engine#pp_atom x (export engine) es
let export_rewriter_concat es tau =
match es with
| [] -> v_nil (vlist_get_tau tau)
| e::es ->
- begin match F.repr e with
- | L.Fun( elt , [x] ) when Lang.Fun.equal elt f_elt ->
- e_fun ?result:tau f_cons [x;e_fun ?result:tau f_concat es]
- | _ -> raise Not_found
- end
+ begin match F.repr e with
+ | L.Fun( elt , [x] ) when Lang.Fun.equal elt f_elt ->
+ e_fun ?result:tau f_cons [x;e_fun ?result:tau f_concat es]
+ | _ -> raise Not_found
+ end
let () =
Lang.For_export.set_builtin' f_concat export_rewriter_concat
@@ -540,10 +540,10 @@ let () =
let rec collect xs = function
| [] -> List.rev xs , []
| (e::es) as w ->
- begin match F.repr e with
- | L.Fun( elt , [x] ) when elt == f_elt -> collect (x::xs) es
- | _ -> List.rev xs , w
- end
+ begin match F.repr e with
+ | L.Fun( elt , [x] ) when elt == f_elt -> collect (x::xs) es
+ | _ -> List.rev xs , w
+ end
let list engine fmt xs = Qed.Plib.pp_listsep ~sep:"," engine#pp_flow fmt xs
@@ -557,10 +557,10 @@ let rec pp_concat (engine : #engine) fmt es =
match es with
| [] -> ()
| m::ms ->
- if xs <> [] then Format.fprintf fmt " ^@ " ;
- engine#pp_atom fmt m ;
- if ms <> [] then
- ( Format.fprintf fmt " ^@ " ; pp_concat engine fmt ms )
+ if xs <> [] then Format.fprintf fmt " ^@ " ;
+ engine#pp_atom fmt m ;
+ if ms <> [] then
+ ( Format.fprintf fmt " ^@ " ; pp_concat engine fmt ms )
end
let pretty (engine : #engine) fmt es =
diff --git a/src/plugins/wp/Vset.ml b/src/plugins/wp/Vset.ml
index 29dd98f83d7ac901b5c76f612f03d95cd4b02204..1a7884b9720f7a854c5cc5a360132cc49cf932b0 100644
--- a/src/plugins/wp/Vset.ml
+++ b/src/plugins/wp/Vset.ml
@@ -44,8 +44,8 @@ let occurs_vset x = function
| Singleton t -> occurs x t
| Range(a,b) -> occurs_opt x a || occurs_opt x b
| Descr(xs,t,p) ->
- if List.exists (Var.equal x) xs then false
- else (occurs x t || occursp x p)
+ if List.exists (Var.equal x) xs then false
+ else (occurs x t || occursp x p)
let occurs x = List.exists (occurs_vset x)
@@ -56,9 +56,9 @@ let vars_vset = function
| Singleton t -> F.vars t
| Range(a,b) -> Vars.union (vars_opt a) (vars_opt b)
| Descr(xs,t,p) ->
- List.fold_left
- (fun xs x -> Vars.remove x xs)
- (Vars.union (F.vars t) (F.varsp p)) xs
+ List.fold_left
+ (fun xs x -> Vars.remove x xs)
+ (Vars.union (F.vars t) (F.varsp p)) xs
let vars vset = List.fold_left
(fun xs s -> Vars.union xs (vars_vset s))
@@ -83,9 +83,9 @@ let pretty fmt = function
| [] -> Format.pp_print_string fmt "{}"
| [v] -> pp_vset fmt v
| v::vs ->
- Format.fprintf fmt "@[<hov 2>(%a" pp_vset v ;
- List.iter (fun v -> Format.fprintf fmt "@ + %a" pp_vset v) vs ;
- Format.fprintf fmt ")@]"
+ Format.fprintf fmt "@[<hov 2>(%a" pp_vset v ;
+ List.iter (fun v -> Format.fprintf fmt "@ + %a" pp_vset v) vs ;
+ Format.fprintf fmt ")@]"
(* -------------------------------------------------------------------------- *)
(* --- Set Operations --- *)
@@ -147,16 +147,16 @@ let union xs ys = (xs @ ys)
let descr = function
| Set(t,s) ->
- let x = Lang.freshvar t in
- let e = e_var x in
- [x] , e , p_call p_member [e;s]
+ let x = Lang.freshvar t in
+ let e = e_var x in
+ [x] , e , p_call p_member [e;s]
| Singleton e -> ( [] , e , p_true )
| Range(a,b) ->
- let x = Lang.freshvar ~basename:"k" Logic.Int in
- let e = e_var x in
- [x] , e , in_range e a b
+ let x = Lang.freshvar ~basename:"k" Logic.Int in
+ let e = e_var x in
+ [x] , e , in_range e a b
| Descr(xs,t,p) ->
- xs, t, p
+ xs, t, p
(* -------------------------------------------------------------------------- *)
(* --- Concretize --- *)
@@ -170,14 +170,14 @@ let concretize_vset = function
| Range(Some a,None) -> e_fun f_range_sup [a]
| Range(Some a,Some b) -> e_fun f_range [a;b]
| Descr _ ->
- Warning.error "Concretization for comprehension sets not implemented yet"
+ Warning.error "Concretization for comprehension sets not implemented yet"
let concretize = function
| [] -> e_fun f_empty []
| x::xs ->
- List.fold_left
- (fun w x -> e_fun f_union [w;concretize_vset x])
- (concretize_vset x) xs
+ List.fold_left
+ (fun w x -> e_fun f_union [w;concretize_vset x])
+ (concretize_vset x) xs
let inter xs ys = e_fun f_inter [xs;ys]
@@ -202,35 +202,35 @@ let is_empty xs =
let subrange a b = function
| [Range(c,d)] ->
- p_imply
- (match a,b with
- | Some a , Some b -> p_leq a b
- | _ -> p_true)
- (p_and
- (match c,a with
- | None,_ -> p_true
- | Some _,None -> p_false
- | Some c,Some a -> p_leq c a)
- (match b,d with
- | _,None -> p_true
- | None,Some _ -> p_false
- | Some b,Some d -> p_leq b d))
+ p_imply
+ (match a,b with
+ | Some a , Some b -> p_leq a b
+ | _ -> p_true)
+ (p_and
+ (match c,a with
+ | None,_ -> p_true
+ | Some _,None -> p_false
+ | Some c,Some a -> p_leq c a)
+ (match b,d with
+ | _,None -> p_true
+ | None,Some _ -> p_false
+ | Some b,Some d -> p_leq b d))
| ys ->
- let x = Lang.freshvar ~basename:"k" Logic.Int in
- let k = e_var x in
- p_forall [x] (p_imply (in_range k a b) (member k ys))
+ let x = Lang.freshvar ~basename:"k" Logic.Int in
+ let k = e_var x in
+ p_forall [x] (p_imply (in_range k a b) (member k ys))
let subset xs ys =
p_all (function
| Set(t,s) ->
- let x = Lang.freshvar t in
- let e = e_var x in
- p_forall [x] (p_imply (p_call p_member [e;s]) (member e ys))
+ let x = Lang.freshvar t in
+ let e = e_var x in
+ p_forall [x] (p_imply (p_call p_member [e;s]) (member e ys))
| Singleton e -> member e ys
| Descr(xs,t,p) ->
- p_forall xs (p_imply p (member t ys))
+ p_forall xs (p_imply p (member t ys))
| Range(a,b) ->
- subrange a b ys
+ subrange a b ys
) xs
(* -------------------------------------------------------------------------- *)
@@ -258,46 +258,46 @@ let disjoint_vset x y =
match x , y with
| Singleton x , Singleton y ->
- p_neq x y
+ p_neq x y
| Singleton e , Range(a,b)
| Range(a,b) , Singleton e ->
- p_not (in_range e a b)
+ p_not (in_range e a b)
| Range(a,b) , Range(c,d) ->
- p_disj [
- empty_range a b ;
- empty_range c d ;
- disjoint_bounds b c ;
- disjoint_bounds d a ;
- ]
+ p_disj [
+ empty_range a b ;
+ empty_range c d ;
+ disjoint_bounds b c ;
+ disjoint_bounds d a ;
+ ]
| Singleton x , Descr(xs,t,p)
| Descr(xs,t,p) , Singleton x ->
- p_forall xs (p_imply p (p_neq x t))
+ p_forall xs (p_imply p (p_neq x t))
| Range(a,b) , Descr(xs,t,p)
| Descr(xs,t,p) , Range(a,b) ->
- p_forall xs (p_imply p (p_not (in_range t a b)))
+ p_forall xs (p_imply p (p_not (in_range t a b)))
| Descr(xs,ta,pa) , Descr(ys,tb,pb) ->
- p_forall xs
- (p_forall ys
- (p_hyps [pa;pb] (p_neq ta tb)))
+ p_forall xs
+ (p_forall ys
+ (p_hyps [pa;pb] (p_neq ta tb)))
| Singleton e , Set(_,s)
| Set(_,s) , Singleton e ->
- p_not (p_call p_member [e;s])
+ p_not (p_call p_member [e;s])
| Set _ , Set _ ->
- let xs,a,p = descr x in
- let ys,b,q = descr y in
- p_forall (xs @ ys) (p_hyps [p;q] (p_neq a b))
+ let xs,a,p = descr x in
+ let ys,b,q = descr y in
+ p_forall (xs @ ys) (p_hyps [p;q] (p_neq a b))
| Set(_,s) , w | w , Set(_,s) ->
- let xs,t,p = descr w in
- let t_in_s = p_call p_member [t;s] in
- p_forall xs (p_not (p_and p t_in_s))
+ let xs,t,p = descr w in
+ let t_in_s = p_call p_member [t;s] in
+ p_forall xs (p_not (p_and p t_in_s))
let disjoint xs ys =
let ws =
@@ -369,9 +369,9 @@ let lift_add xs ys =
match x , y with
| Singleton a , Singleton b -> Singleton(e_add a b)
| Singleton u , Range(a,b) | Range(a,b) , Singleton u ->
- Range(map_opt (e_add u) a, map_opt (e_add u) b)
+ Range(map_opt (e_add u) a, map_opt (e_add u) b)
| Range(a,b) , Range(c,d) ->
- Range(bound_add a c,bound_add b d)
+ Range(bound_add a c,bound_add b d)
| _ -> lift_vset e_add x y
) xs ys
@@ -381,11 +381,11 @@ let lift_sub xs ys =
match x , y with
| Singleton a , Singleton b -> Singleton(e_sub a b)
| Singleton u , Range(a,b) ->
- Range(bound_sub (Some u) b , bound_sub (Some u) a)
+ Range(bound_sub (Some u) b , bound_sub (Some u) a)
| Range(a,b) , Singleton u ->
- Range(bound_sub a (Some u) , bound_sub b (Some u))
+ Range(bound_sub a (Some u) , bound_sub b (Some u))
| Range(a,b) , Range(c,d) ->
- Range(bound_sub a d , bound_sub b c)
+ Range(bound_sub a d , bound_sub b c)
| _ -> lift_vset e_sub x y
) xs ys
diff --git a/src/plugins/wp/Why3Provers.ml b/src/plugins/wp/Why3Provers.ml
index 190b02c4d8ee09511a1b55f6d490a3a0a25b2781..975e656a1eb712567fe51106755f7e5de52a78f7 100644
--- a/src/plugins/wp/Why3Provers.ml
+++ b/src/plugins/wp/Why3Provers.ml
@@ -66,7 +66,7 @@ let find_opt s =
| Why3.Whyconf.ProverNotFound _
| Why3.Whyconf.ParseFilterProver _
| Why3.Whyconf.ProverAmbiguity _ ->
- None
+ None
type fallback = Exact of t | Fallback of t | NotFound
@@ -74,18 +74,18 @@ let find_fallback name =
match find_opt name with
| Some prv -> Exact prv
| None ->
- (* Why3 should deal with this intermediate case *)
- match find_opt (String.lowercase_ascii name) with
- | Some prv -> Exact prv
- | None ->
- match String.split_on_char ',' name with
- | shortname :: _ :: _ ->
- begin
- match find_opt (String.lowercase_ascii shortname) with
- | Some prv -> Fallback prv
- | None -> NotFound
- end
- | _ -> NotFound
+ (* Why3 should deal with this intermediate case *)
+ match find_opt (String.lowercase_ascii name) with
+ | Some prv -> Exact prv
+ | None ->
+ match String.split_on_char ',' name with
+ | shortname :: _ :: _ ->
+ begin
+ match find_opt (String.lowercase_ascii shortname) with
+ | Some prv -> Fallback prv
+ | None -> NotFound
+ end
+ | _ -> NotFound
let print_why3 = Why3.Whyconf.prover_parseable_format
let print_wp s =
diff --git a/src/plugins/wp/WpTac.ml b/src/plugins/wp/WpTac.ml
index 339d9c368a19a5db3ee2ad1aa1ee502f4ed7b31a..dba4af376983457f6363ce02e88d6d7417acc787 100644
--- a/src/plugins/wp/WpTac.ml
+++ b/src/plugins/wp/WpTac.ml
@@ -37,7 +37,7 @@ let s_bool p = [p; e_not p]
(* is it an atom for CNF/DNF *)
let is_cnf_dnf_atom_repr = function
| If(_,x,y) | Eq(x,y) | Neq(x,y) ->
- not (is_prop x && is_prop y)
+ not (is_prop x && is_prop y)
| And _ | Or _
| Imply _ | Not _ -> false
| _ -> true
@@ -182,8 +182,8 @@ let pp_xf ~pol fmt = function
| [] -> Format.fprintf fmt "%sf [%s neutral)]"
(if pol then "c" else "d") (if pol then "TRUE" else "FALSE ")
| xf -> Format.printf "%sf [" (if pol then "c" else "d");
- List.iter (fun x -> Format.fprintf fmt "%s %a " (if pol then "&&" else "||") Lang.F.pp_term x) xf;
- Format.printf "]"
+ List.iter (fun x -> Format.fprintf fmt "%s %a " (if pol then "&&" else "||") Lang.F.pp_term x) xf;
+ Format.printf "]"
let pp_xNf ~pol ~depth fmt xNf =
let pp_xNf fmt = function
@@ -195,9 +195,9 @@ let pp_xNf ~pol ~depth fmt xNf =
| [],[] -> Format.fprintf fmt "%sNF %s neutral=[]@?"
(if pol then "C" else "D") (if pol then "TRUE " else "FALSE")
| xf,xnf -> Format.fprintf fmt "%sNF [@?" (if pol then "C" else "D") ;
- if xf <> [] then List.iter (fun x -> Format.fprintf fmt "%s (%a) @?" (if pol then "&&" else "||") Lang.F.pp_term x) xf;
- List.iter (fun x -> Format.fprintf fmt "@.%a %s [%a]@?" (pp_indent ~pol) depth (if pol then "&&" else "||") pp_xNf x) xnf;
- Format.fprintf fmt "]@?"
+ if xf <> [] then List.iter (fun x -> Format.fprintf fmt "%s (%a) @?" (if pol then "&&" else "||") Lang.F.pp_term x) xf;
+ List.iter (fun x -> Format.fprintf fmt "@.%a %s [%a]@?" (pp_indent ~pol) depth (if pol then "&&" else "||") pp_xNf x) xnf;
+ Format.fprintf fmt "]@?"
(** Transforms [e] into CNF/DNF **)
@@ -211,15 +211,15 @@ let cnf_dnf ~pol ~depth e =
and flat acc e =
match repr e with
| Eq(x,y) when (F.is_prop x) && (F.is_prop y) ->
- flatten acc (tool.s_iff x y)
+ flatten acc (tool.s_iff x y)
| Neq(x,y) when (F.is_prop x) && (F.is_prop y) ->
- flatten acc (tool.s_xor x y)
+ flatten acc (tool.s_xor x y)
| If(c,p,q) ->
- flatten acc (tool.s_ite c p q)
+ flatten acc (tool.s_ite c p q)
| Imply _ when pol -> unnormalized acc e
| Imply (xe,x) ->
- flatten acc (x::(List.map (fun x -> e_not x) xe))
+ flatten acc (x::(List.map (fun x -> e_not x) xe))
| Or xs when not pol -> flatten acc xs
| And xs when pol -> flatten acc xs
@@ -241,13 +241,13 @@ let cnf_dnf ~pol ~depth e =
match cnf2 with
| ([]::_) -> raise Absorbant (* @absorbant @ _ = @absorbant *)
| _ ->
- (* TODO: uses Qed.Term.consequence_style *)
- let cf,cnf = List.fold_left
- (fun (cf,cnf) -> function | [] -> raise Absorbant | [x] -> (x::cf),cnf | df -> cf,(df::cnf))
- neutral cnf1
- in
- let cf = if cf1=[] && cf=[] then cf2 else tool.normalize_xf cf@cf1@cf2 in
- cf, (cnf@cnf2)
+ (* TODO: uses Qed.Term.consequence_style *)
+ let cf,cnf = List.fold_left
+ (fun (cf,cnf) -> function | [] -> raise Absorbant | [x] -> (x::cf),cnf | df -> cf,(df::cnf))
+ neutral cnf1
+ in
+ let cf = if cf1=[] && cf=[] then cf2 else tool.normalize_xf cf@cf1@cf2 in
+ cf, (cnf@cnf2)
in
(* distribution for CNF/DNF as literal list list *)
@@ -278,16 +278,16 @@ let cnf_dnf ~pol ~depth e =
let d_cf_cNf2cNf (cf:xf_t) (cNf':xNf_t) : xNf_t =
let r = match cf,cNf' with
| _,([],[]) -> debugN 4 "%a> d_cf_cNf2cNf cas1/4@." pp_i ();
- cNf' (* (c1@...@cn) # @neutral/#absorbant= @neutral *)
+ cNf' (* (c1@...@cn) # @neutral/#absorbant= @neutral *)
| [],_ -> debugN 4 "%a> d_cf_cNf2cNf cas2/4@." pp_i ();
- neutral (* @neutral/#absorbant # (c1'@...@ck'@D1@...@Dm) = @neutral *)
+ neutral (* @neutral/#absorbant # (c1'@...@ck'@D1@...@Dm) = @neutral *)
| _, (_,[]::_) -> debugN 4 "%a> d_cf_cNf2cNf cas3/4@." pp_i ();
- cf,[] (* (c1@...@cn) # #neutral/@absorbant= (c1@...@cn) *)
+ cf,[] (* (c1@...@cn) # #neutral/@absorbant= (c1@...@cn) *)
| _,(cf',cnf') -> debugN 4 "%a> d_cf_cNf2cNf cas4/4 cf(%d) cNf(%d,%d)@." pp_i ()
(List.length cf) (List.length cf') (List.length cnf');
- if 2048 < (List.length cf)*((List.length cf')+(List.length cnf')) then raise TooBig ;
- let cNf1 = List.fold_left (fun (acc:xNf_t) (x:term) -> c_cNf_cNf2cNf ~tool ~pol ~depth (d_df_cf2cNf [x] cf) acc) neutral cf' in
- List.fold_left (fun (acc:xNf_t) (df:xf_t) -> c_cNf_cNf2cNf ~tool ~pol ~depth (d_df_cf2cNf df cf) acc) cNf1 cnf'
+ if 2048 < (List.length cf)*((List.length cf')+(List.length cnf')) then raise TooBig ;
+ let cNf1 = List.fold_left (fun (acc:xNf_t) (x:term) -> c_cNf_cNf2cNf ~tool ~pol ~depth (d_df_cf2cNf [x] cf) acc) neutral cf' in
+ List.fold_left (fun (acc:xNf_t) (df:xf_t) -> c_cNf_cNf2cNf ~tool ~pol ~depth (d_df_cf2cNf df cf) acc) cNf1 cnf'
in
debugN 4 "%a> d_cf_cNf2cNf %sNf(%d,%b) %a %a =@.%a> d_cf_cNf2cNf = %a@." pp_i ()
(if pol then "C" else "D") depth pol (pp_xf ~pol) cf (pp_xNf ~pol ~depth) cNf'
@@ -304,7 +304,7 @@ let cnf_dnf ~pol ~depth e =
| cf::[]-> d_cf_cNf2cNf cf cNf (* (c1@...@ck@D1@...@Dn) # (c11@...@c1k) = (c11@...@c1k) # (c1@...@ck@D1@...@Dn) *)
| cf::dnf -> (* (c1@...@ck@D1@...@Dn) # ((c11@...@c1k)#C2#...#Cm) =
((c11@...@c1k)#(c1@...@ck@D1@...#@n)) @ (C2#...#Cm) *)
- d_cNf_dnf2cNf (d_cf_cNf2cNf cf cNf) dnf
+ d_cNf_dnf2cNf (d_cf_cNf2cNf cf cNf) dnf
in
debugN 3 "%a> %sNf->%sNf(%d,%b) %a=...@." pp_i ()
(if pol then "D" else "C") (if pol then "C" else "D") depth pol (pp_xNf ~pol:(not pol) ~depth) dNf;
@@ -352,14 +352,14 @@ let cnf_dnf ~pol ~depth e =
match cNf with
| [],[] -> tool.neutral
| cf,cnf ->
- let mk_sub = function
- | [] -> raise Absorbant
- | df ->
- let r = tool.mk_sub df in
- if tool.is_absorbant_repr (F.repr r) then raise Absorbant
- else r
- in
- tool.mk_top (cf@(List.map mk_sub cnf))
+ let mk_sub = function
+ | [] -> raise Absorbant
+ | df ->
+ let r = tool.mk_sub df in
+ if tool.is_absorbant_repr (F.repr r) then raise Absorbant
+ else r
+ in
+ tool.mk_top (cf@(List.map mk_sub cnf))
with Absorbant -> tool.absorbant
let cnf_dnf ~pol ?(depth=(-1)) = cnf_dnf ~pol ~depth
@@ -374,15 +374,15 @@ let () = Conditions.at_closure (fun ((step,goal) as sequent) ->
match Wp_parameters.SplitDepth.get () with
| 0 -> sequent
| depth when depth < -1 ->
- (* Unspecified debug mode checking the correctness of CNF algo:
- `H |- P` is replaced by `H |- P <-> CNF(P)` *)
- let cnf = e_cnf ~depth:(-(depth+3)) (e_prop goal) in
- debug " CNF=%a@." pp_term cnf;
- step, p_equiv goal (F.p_bool cnf)
+ (* Unspecified debug mode checking the correctness of CNF algo:
+ `H |- P` is replaced by `H |- P <-> CNF(P)` *)
+ let cnf = e_cnf ~depth:(-(depth+3)) (e_prop goal) in
+ debug " CNF=%a@." pp_term cnf;
+ step, p_equiv goal (F.p_bool cnf)
| depth ->
- (* `H |- P` is replaced by `H |- CNF(P)` *)
- let cnf = e_cnf ~depth (e_prop goal) in
- debug " CNF=%a@." pp_term cnf;
- step, p_bool cnf
+ (* `H |- P` is replaced by `H |- CNF(P)` *)
+ let cnf = e_cnf ~depth (e_prop goal) in
+ debug " CNF=%a@." pp_term cnf;
+ step, p_bool cnf
)
diff --git a/src/plugins/wp/cfgAnnot.ml b/src/plugins/wp/cfgAnnot.ml
index f4e3ffcd184813ff759ad0884a831541f0d82166..84de9c38839f783b139f0bdf779a3490b4fda21b 100644
--- a/src/plugins/wp/cfgAnnot.ml
+++ b/src/plugins/wp/cfgAnnot.ml
@@ -98,18 +98,18 @@ let normalize_froms tk froms =
let normalize_fct_assigns kf ~exits bhv = function
| WritesAny ->
- WpPropId.empty_assigns_info, WpPropId.empty_assigns_info
+ WpPropId.empty_assigns_info, WpPropId.empty_assigns_info
| Writes froms ->
- let make tk =
- match WpPropId.mk_fct_assigns_id kf exits bhv tk froms with
- | None -> WpPropId.empty_assigns_info
- | Some id ->
- let assigns = normalize_froms tk froms in
- let desc = WpPropId.mk_kf_assigns_desc assigns in
- WpPropId.mk_assigns_info id desc
- in
- make Normal,
- if exits then make Exits else WpPropId.empty_assigns_info
+ let make tk =
+ match WpPropId.mk_fct_assigns_id kf exits bhv tk froms with
+ | None -> WpPropId.empty_assigns_info
+ | Some id ->
+ let assigns = normalize_froms tk froms in
+ let desc = WpPropId.mk_kf_assigns_desc assigns in
+ WpPropId.mk_assigns_info id desc
+ in
+ make Normal,
+ if exits then make Exits else WpPropId.empty_assigns_info
let get_behavior_goals kf ?(smoking=false) ?(exits=false) bhv =
let pre_cond = normalize_pre ~goal:false kf bhv in
@@ -218,21 +218,21 @@ let get_terminates_clause kf =
| None
when Cil_builtins.is_builtin kf_vi
|| Cil_builtins.is_special_builtin kf_name ->
- populate_true ~silence:true ()
+ populate_true ~silence:true ()
| None when Kernel_function.is_in_libc kf ->
- if not @@ Wp_parameters.TerminatesStdlibDeclarations.get ()
- then Assumed Logic_const.pfalse
- else populate_true ()
+ if not @@ Wp_parameters.TerminatesStdlibDeclarations.get ()
+ then Assumed Logic_const.pfalse
+ else populate_true ()
| None when Kernel_function.is_definition kf ->
- if not @@ Wp_parameters.TerminatesDefinitions.get ()
- then Assumed Logic_const.pfalse
- else populate_true ()
+ if not @@ Wp_parameters.TerminatesDefinitions.get ()
+ then Assumed Logic_const.pfalse
+ else populate_true ()
| None ->
- if not @@ Wp_parameters.TerminatesExtDeclarations.get ()
- then Assumed Logic_const.pfalse
- else populate_true ()
+ if not @@ Wp_parameters.TerminatesExtDeclarations.get ()
+ then Assumed Logic_const.pfalse
+ else populate_true ()
| Some p ->
- defined p
+ defined p
let get_terminates_goal kf =
match get_terminates_clause kf with
@@ -247,8 +247,8 @@ let get_terminates_hyp kf =
let check_variant_relation = function
| (_, None) -> ()
| (_, Some rel) ->
- Wp_parameters.hypothesis ~once:true
- "'%a' relation must be well-founded" Cil_printer.pp_logic_info rel
+ Wp_parameters.hypothesis ~once:true
+ "'%a' relation must be well-founded" Cil_printer.pp_logic_info rel
let get_decreases_goal kf =
let defined t = WpPropId.mk_decrease_id kf Kglobal t, t in
@@ -366,10 +366,10 @@ let get_call_contract ?smoking kf stmt =
let preconds = List.map (get_precond_at kf stmt) cc.contract_cond in
match smoking with
| None ->
- { cc with contract_cond = preconds }
+ { cc with contract_cond = preconds }
| Some s ->
- let g = smoke kf ~id:"dead_call" ~unreachable:s () in
- { cc with contract_cond = preconds ; contract_smoke = [ g ] }
+ let g = smoke kf ~id:"dead_call" ~unreachable:s () in
+ { cc with contract_cond = preconds ; contract_smoke = [ g ] }
(* -------------------------------------------------------------------------- *)
(* --- Assembly Code --- *)
@@ -386,22 +386,22 @@ let get_stmt_assigns kf stmt =
begin fun _emitter ca l ->
match ca.annot_content with
| AStmtSpec(fors,s) ->
- List.fold_left
- (fun l bhv ->
- match bhv.b_assigns with
- | WritesAny -> l
- | Writes froms ->
- let module L = NormAtLabels in
- let labels = L.labels_stmt_assigns ~kf stmt in
- match
- WpPropId.mk_stmt_assigns_id kf stmt fors bhv froms
- with
- | None -> l
- | Some id ->
- let froms = L.preproc_assigns labels froms in
- let desc = WpPropId.mk_stmt_assigns_desc stmt froms in
- WpPropId.mk_assigns_info id desc :: l
- ) l s.spec_behavior
+ List.fold_left
+ (fun l bhv ->
+ match bhv.b_assigns with
+ | WritesAny -> l
+ | Writes froms ->
+ let module L = NormAtLabels in
+ let labels = L.labels_stmt_assigns ~kf stmt in
+ match
+ WpPropId.mk_stmt_assigns_id kf stmt fors bhv froms
+ with
+ | None -> l
+ | Some id ->
+ let froms = L.preproc_assigns labels froms in
+ let desc = WpPropId.mk_stmt_assigns_desc stmt froms in
+ WpPropId.mk_assigns_info id desc :: l
+ ) l s.spec_behavior
| _ -> l
end stmt []
in if asgn = [] then [WpPropId.mk_stmt_any_assigns_info stmt] else asgn
@@ -433,24 +433,24 @@ module CodeAssertions = WpContext.StaticGenerator(CodeKey)
begin fun l ca ->
match ca.annot_content with
| AStmtSpec _ when not @@ is_assembly stmt ->
- let source = fst (Cil_datatype.Stmt.loc stmt) in
- Wp_parameters.warning ~once:true ~source
- "Statement specifications not yet supported (skipped)." ; l
+ let source = fst (Cil_datatype.Stmt.loc stmt) in
+ Wp_parameters.warning ~once:true ~source
+ "Statement specifications not yet supported (skipped)." ; l
| AInvariant(_,false,_) ->
- let source = fst (Cil_datatype.Stmt.loc stmt) in
- Wp_parameters.warning ~once:true ~source
- "Generalized invariant not yet supported (skipped)." ; l
+ let source = fst (Cil_datatype.Stmt.loc stmt) in
+ Wp_parameters.warning ~once:true ~source
+ "Generalized invariant not yet supported (skipped)." ; l
| AAssert(_,a) ->
- let p =
- WpPropId.mk_assert_id kf stmt ca ,
- normalize_pred a.tp_statement in
- let admit = Logic_utils.use_predicate a.tp_kind in
- let verif = Logic_utils.verify_predicate a.tp_kind in
- let use flag p = if flag then Some p else None in
- {
- code_admitted = use admit p ;
- code_verified = use verif p ;
- } :: l
+ let p =
+ WpPropId.mk_assert_id kf stmt ca ,
+ normalize_pred a.tp_statement in
+ let admit = Logic_utils.use_predicate a.tp_kind in
+ let verif = Logic_utils.verify_predicate a.tp_kind in
+ let use flag p = if flag then Some p else None in
+ {
+ code_admitted = use admit p ;
+ code_verified = use verif p ;
+ } :: l
| _ -> l
end [] all_annot
end)
@@ -553,42 +553,42 @@ module LoopContract = WpContext.StaticGenerator(CodeKey)
begin fun l ca ->
match ca.annot_content with
| AInvariant(_,true,inv) ->
- let g_hyp = WpPropId.mk_inv_hyp_id kf stmt ca in
- let g_est, g_ind = WpPropId.mk_loop_inv kf stmt ca in
- let admit = Logic_utils.use_predicate inv.tp_kind in
- let verif = Logic_utils.verify_predicate inv.tp_kind in
- let loop_hyp = if admit then Always g_hyp else Check g_hyp in
- let use flag id = if flag then Some id else None in
- let inv =
- { loop_pred = normalize_pred inv.tp_statement ;
- loop_hyp ;
- loop_est = use verif g_est ;
- loop_ind = use verif g_ind ; }
- in
- { l with
- loop_invariants = inv :: l.loop_invariants ; }
+ let g_hyp = WpPropId.mk_inv_hyp_id kf stmt ca in
+ let g_est, g_ind = WpPropId.mk_loop_inv kf stmt ca in
+ let admit = Logic_utils.use_predicate inv.tp_kind in
+ let verif = Logic_utils.verify_predicate inv.tp_kind in
+ let loop_hyp = if admit then Always g_hyp else Check g_hyp in
+ let use flag id = if flag then Some id else None in
+ let inv =
+ { loop_pred = normalize_pred inv.tp_statement ;
+ loop_hyp ;
+ loop_est = use verif g_est ;
+ loop_ind = use verif g_ind ; }
+ in
+ { l with
+ loop_invariants = inv :: l.loop_invariants ; }
| AVariant(term, None) ->
- let vpos , vdec = mk_variant_properties kf stmt ca term in
- let vpos = variant_as_inv ~loc:term.term_loc vpos in
- let vdec = variant_as_inv ~loc:term.term_loc vdec in
- { l with loop_terminates = None ;
- loop_invariants = vdec :: vpos :: l.loop_invariants }
+ let vpos , vdec = mk_variant_properties kf stmt ca term in
+ let vpos = variant_as_inv ~loc:term.term_loc vpos in
+ let vdec = variant_as_inv ~loc:term.term_loc vdec in
+ { l with loop_terminates = None ;
+ loop_invariants = vdec :: vpos :: l.loop_invariants }
| AVariant(term, Some rel) ->
- let vrel = mk_variant_relation_property kf stmt ca term rel in
- let vrel = variant_as_inv ~loc:term.term_loc vrel in
- { l with loop_invariants = vrel :: l.loop_invariants }
+ let vrel = mk_variant_relation_property kf stmt ca term rel in
+ let vrel = variant_as_inv ~loc:term.term_loc vrel in
+ { l with loop_invariants = vrel :: l.loop_invariants }
| AAssigns(_,WritesAny) ->
- let asgn = WpPropId.mk_loop_any_assigns_info stmt in
- { l with loop_assigns = asgn :: l.loop_assigns }
+ let asgn = WpPropId.mk_loop_any_assigns_info stmt in
+ { l with loop_assigns = asgn :: l.loop_assigns }
| AAssigns(_,Writes w) ->
- begin match WpPropId.mk_loop_assigns_id kf stmt ca w with
- | None -> l (* shall not occur *)
- | Some id ->
- let w = normalize_assigns w in
- let a = WpPropId.mk_loop_assigns_desc stmt w in
- let asgn = WpPropId.mk_assigns_info id a in
- { l with loop_assigns = asgn :: l.loop_assigns }
- end
+ begin match WpPropId.mk_loop_assigns_id kf stmt ca w with
+ | None -> l (* shall not occur *)
+ | Some id ->
+ let w = normalize_assigns w in
+ let a = WpPropId.mk_loop_assigns_desc stmt w in
+ let asgn = WpPropId.mk_assigns_info id a in
+ { l with loop_assigns = asgn :: l.loop_assigns }
+ end
| _ -> l
end
{ loop_terminates = Some Logic_const.pfalse ;
@@ -608,12 +608,12 @@ let get_loop_contract ?(smoking=false) ?terminates kf stmt =
in
match lc_smoke.loop_terminates, terminates with
| None, _ ->
- lc_smoke
+ lc_smoke
| Some _, None ->
- { lc_smoke with loop_terminates = None }
+ { lc_smoke with loop_terminates = None }
| Some loop_terminates, Some terminates ->
- let prop = Logic_const.pimplies(terminates, loop_terminates) in
- { lc_smoke with loop_terminates = Some prop }
+ let prop = Logic_const.pimplies(terminates, loop_terminates) in
+ { lc_smoke with loop_terminates = Some prop }
(* -------------------------------------------------------------------------- *)
(* --- Clear Tablesnts --- *)
diff --git a/src/plugins/wp/cfgCalculus.ml b/src/plugins/wp/cfgCalculus.ml
index 04e1f4b0f710fbafba1e9d667c044ed8562c3118..49c8254c68710ef03b6a6b0a774be78b588613a1 100644
--- a/src/plugins/wp/cfgCalculus.ml
+++ b/src/plugins/wp/cfgCalculus.ml
@@ -77,23 +77,23 @@ let is_selected_ca (m: mode) ~goal (ca: code_annotation) =
-> is_selected_for m ~goal forb
| AVariant _ -> is_default_bhv m
| AExtended _ | AStmtSpec _ | APragma _ ->
- assert false (* n/a *)
+ assert false (* n/a *)
let is_active_mode ~mode ~goal (p: Property.t) =
let open Property in
match p with
| IPCodeAnnot { ica_ca } -> is_selected_ca mode ~goal ica_ca
| IPPredicate { ip_kind } ->
- begin match ip_kind with
- | PKRequires _ | PKAssumes _ -> true
- | PKEnsures(bhv,_) -> is_selected_bhv mode bhv
- | PKTerminates -> is_default_bhv mode
- end
+ begin match ip_kind with
+ | PKRequires _ | PKAssumes _ -> true
+ | PKEnsures(bhv,_) -> is_selected_bhv mode bhv
+ | PKTerminates -> is_default_bhv mode
+ end
| IPAllocation { ial_bhv = bhv } | IPAssigns { ias_bhv = bhv } ->
- begin match bhv with
- | Id_loop ca -> is_selected_ca mode ~goal ca
- | Id_contract(_,bhv) -> is_selected_bhv mode bhv
- end
+ begin match bhv with
+ | Id_loop ca -> is_selected_ca mode ~goal ca
+ | Id_contract(_,bhv) -> is_selected_bhv mode bhv
+ end
| IPDecrease { id_ca = None } -> is_default_bhv mode
| IPDecrease { id_ca = Some ca } -> is_selected_ca mode ~goal ca
| IPComplete _ | IPDisjoint _ -> is_default_bhv mode
@@ -110,9 +110,9 @@ let is_selected_props (props : props) ?pi pid =
| `All | `Names [] -> WpPropId.select_default pid
| `Names ps -> WpPropId.select_by_name ps pid
| `PropId p ->
- Property.equal p @@ match pi with
- | Some q -> q
- | None -> WpPropId.property_of_id pid
+ Property.equal p @@ match pi with
+ | Some q -> q
+ | None -> WpPropId.property_of_id pid
let rec factorize ~wdefault = function
| (_,w)::wcs when w==wdefault -> factorize ~wdefault wcs
@@ -154,8 +154,8 @@ struct
| [] -> W.empty
| [x] -> f x
| x::xs ->
- let cup = W.merge env.we in
- List.fold_left (fun p y -> cup (f y) p) (f x) xs
+ let cup = W.merge env.we in
+ List.fold_left (fun p y -> cup (f y) p) (f x) xs
let is_selected ~goal { mode ; props } (pid,_) =
let pi = WpPropId.property_of_id pid in
@@ -169,18 +169,18 @@ struct
match a with
| NoAssignsInfo -> assert false
| AssignsAny ad ->
- WpLog.warning ~current:true ~once:true
- "Missing assigns clause (assigns 'everything' instead)" ;
- W.use_assigns env.we None ad w
+ WpLog.warning ~current:true ~once:true
+ "Missing assigns clause (assigns 'everything' instead)" ;
+ W.use_assigns env.we None ad w
| AssignsLocations(ap,ad) -> W.use_assigns env.we (Some ap) ad w
let prove_assigns env (a : assigns) w =
match a with
| NoAssignsInfo | AssignsAny _ -> w
| AssignsLocations ai ->
- if is_selected ~goal:true env ai
- then W.add_assigns env.we ai w
- else w
+ if is_selected ~goal:true env ai
+ then W.add_assigns env.we ai w
+ else w
let use_property ?for_pid env (p : WpPropId.pred_info) w =
if is_selected ~goal:false env p then W.add_hyp ?for_pid env.we p w else w
@@ -196,9 +196,9 @@ struct
let on_selected_terminates env f =
match env.terminates with
| Some t when is_default_bhv env.mode && is_selected ~goal:true env t ->
- f env t
+ f env t
| _ ->
- Extlib.id
+ Extlib.id
(* --- Decomposition of WP Rules --- *)
@@ -207,12 +207,12 @@ struct
| None -> raise (NonNaturalLoop (Cil.CurrentLoc.get()));
| Some pi -> pi
| exception Not_found ->
- (* cut circularities *)
- Vhash.add env.wp a None ;
- let pi = match a.vertex_start_of with
- | None -> successors env a
- | Some s -> stmt env a s
- in Vhash.replace env.wp a (Some pi) ; pi
+ (* cut circularities *)
+ Vhash.add env.wp a None ;
+ let pi = match a.vertex_start_of with
+ | None -> successors env a
+ | Some s -> stmt env a s
+ in Vhash.replace env.wp a (Some pi) ; pi
(* Compute a stmt node *)
and stmt env a (s: stmt) : W.t_prop =
@@ -240,21 +240,21 @@ struct
and control env a s : W.t_prop =
match a.vertex_control with
| If { cond ; vthen ; velse } ->
- let wthen = wp env vthen in
- let welse = wp env velse in
- W.test env.we s cond wthen welse
+ let wthen = wp env vthen in
+ let welse = wp env velse in
+ W.test env.we s cond wthen welse
| Switch { value ; cases ; default } ->
- let wcases = List.map (fun (e,v) -> e,wp env v) cases in
- let wdefault = wp env default in
- W.switch env.we s value (factorize ~wdefault wcases) wdefault
+ let wcases = List.map (fun (e,v) -> e,wp env v) cases in
+ let wdefault = wp env default in
+ W.switch env.we s value (factorize ~wdefault wcases) wdefault
| Loop _ ->
- let m = env.mode in
- let smoking =
- is_default_bhv m &&
- WpLog.SmokeTests.get () &&
- WpLog.SmokeDeadloop.get () in
- let terminates = Option.map snd env.terminates in
- loop env a s (CfgAnnot.get_loop_contract ~smoking ?terminates m.kf s)
+ let m = env.mode in
+ let smoking =
+ is_default_bhv m &&
+ WpLog.SmokeTests.get () &&
+ WpLog.SmokeDeadloop.get () in
+ let terminates = Option.map snd env.terminates in
+ loop env a s (CfgAnnot.get_loop_contract ~smoking ?terminates m.kf s)
| Edges -> successors env a
(* Compute loops *)
@@ -319,37 +319,37 @@ struct
| Set(lv,e,_) -> W.assign env.we s lv e w
| Local_init(x,AssignInit i,_) -> W.init env.we x (Some i) w
| Local_init(x,ConsInit (vf, args, kind), loc) ->
- Cil.treat_constructor_as_func
- begin fun r fct args _loc ->
- match Kf.get_called fct with
- | Some kf -> call env s r kf args w
- | None ->
- WpLog.warning ~once:true "No function for constructor '%s'"
- vf.vname ;
- let any = WpPropId.mk_stmt_assigns_any_desc s in
- W.use_assigns env.we None any (W.merge env.we w env.wk)
- end x vf args kind loc
- | Call(res,fct,args,_loc) ->
- begin
+ Cil.treat_constructor_as_func
+ begin fun r fct args _loc ->
match Kf.get_called fct with
- | Some kf -> call env s res kf args w
+ | Some kf -> call env s r kf args w
+ | None ->
+ WpLog.warning ~once:true "No function for constructor '%s'"
+ vf.vname ;
+ let any = WpPropId.mk_stmt_assigns_any_desc s in
+ W.use_assigns env.we None any (W.merge env.we w env.wk)
+ end x vf args kind loc
+ | Call(res,fct,args,_loc) ->
+ begin
+ match Kf.get_called fct with
+ | Some kf -> call env s res kf args w
+ | None ->
+ match Dyncall.get ~bhv:env.mode.bhv.b_name s with
| None ->
- match Dyncall.get ~bhv:env.mode.bhv.b_name s with
- | None ->
- WpLog.warning ~once:true "Missing 'calls' for %s"
- (if Cil.is_default_behavior env.mode.bhv
- then "default behavior"
- else env.mode.bhv.b_name) ;
- let any = WpPropId.mk_stmt_assigns_any_desc s in
- W.use_assigns env.we None any (W.merge env.we w env.wk)
- | Some(prop,kfs) ->
- let id = WpPropId.mk_property prop in
- W.call_dynamic env.we s id fct @@
- List.map (fun kf -> kf, call env s res kf args w) kfs
- end
+ WpLog.warning ~once:true "Missing 'calls' for %s"
+ (if Cil.is_default_behavior env.mode.bhv
+ then "default behavior"
+ else env.mode.bhv.b_name) ;
+ let any = WpPropId.mk_stmt_assigns_any_desc s in
+ W.use_assigns env.we None any (W.merge env.we w env.wk)
+ | Some(prop,kfs) ->
+ let id = WpPropId.mk_property prop in
+ W.call_dynamic env.we s id fct @@
+ List.map (fun kf -> kf, call env s res kf args w) kfs
+ end
| Asm _ ->
- let assigns = CfgAnnot.get_stmt_assigns env.mode.kf s in
- List.fold_right (use_assigns env) assigns w
+ let assigns = CfgAnnot.get_stmt_assigns env.mode.kf s in
+ List.fold_right (use_assigns env) assigns w
and call env s r kf es wr : W.t_prop =
let smoking =
@@ -384,15 +384,15 @@ struct
let in_cluster = CfgInfos.in_cluster ~caller:env.mode.kf kf in
let w_term = match env.terminates with
| Some t when selected t ->
- W.call_terminates env.we s kf es t ?callee_t w_pre
+ W.call_terminates env.we s kf es t ?callee_t w_pre
| _ -> w_pre
in
let w_decr = match env.decreases with
| Some d when selected d && in_cluster ->
- W.call_decreases env.we s kf es d
- ?caller_t:(Option.map snd env.terminates)
- ?callee_d:c.contract_decreases
- w_term
+ W.call_decreases env.we s kf es d
+ ?caller_t:(Option.map snd env.terminates)
+ ?callee_d:c.contract_decreases
+ w_term
| _ -> w_term
in
w_decr
@@ -410,28 +410,28 @@ struct
match env.body with
| None -> w
| Some _ ->
- let deps = CfgInfos.terminates_deps env.mode.infos in
- let return = Kernel_function.find_return env.mode.kf in
- let prove goal env t w =
- prove_subproperty env t ~deps goal return FromReturn w
+ let deps = CfgInfos.terminates_deps env.mode.infos in
+ let return = Kernel_function.find_return env.mode.kf in
+ let prove goal env t w =
+ prove_subproperty env t ~deps goal return FromReturn w
+ in
+ if CfgInfos.is_recursive env.mode.kf then
+ (* there is a dependency on terminates or decreases is missing *)
+ let goal =
+ if None <> env.decreases then Logic_const.ptrue
+ else begin
+ WpLog.warning ~once:true
+ "No 'decreases' clause on recursive function '%a', \
+ cannot prove termination"
+ Kernel_function.pretty env.mode.kf ;
+ Logic_const.pfalse
+ end
in
- if CfgInfos.is_recursive env.mode.kf then
- (* there is a dependency on terminates or decreases is missing *)
- let goal =
- if None <> env.decreases then Logic_const.ptrue
- else begin
- WpLog.warning ~once:true
- "No 'decreases' clause on recursive function '%a', \
- cannot prove termination"
- Kernel_function.pretty env.mode.kf ;
- Logic_const.pfalse
- end
- in
- on_selected_terminates env (prove goal) w
- else
- if not @@ Property.Set.is_empty deps then
- on_selected_terminates env (prove Logic_const.ptrue) w
- else w
+ on_selected_terminates env (prove goal) w
+ else
+ if not @@ Property.Set.is_empty deps then
+ on_selected_terminates env (prove Logic_const.ptrue) w
+ else w
let do_global_init env w =
I.process_global_init env.we env.mode.kf @@
@@ -472,10 +472,10 @@ struct
match env.body with
| None -> w
| Some cfg ->
- let wpost = do_post env ~formals b w in
- Vhash.add env.wp cfg.return_point (Some wpost) ;
- env.wk <- if exits then do_exit env ~formals b w else w ;
- wp env cfg.entry_point
+ let wpost = do_post env ~formals b w in
+ Vhash.add env.wp cfg.return_point (Some wpost) ;
+ env.wk <- if exits then do_exit env ~formals b w else w ;
+ wp env cfg.entry_point
(* Putting everything together *)
let compute ~mode ~props =
diff --git a/src/plugins/wp/cfgDump.ml b/src/plugins/wp/cfgDump.ml
index 6b348971f63e6ac6627e1b827337de79d0c9fc12..3dbc75c70b2801cc10d412698cdf4de3e07b827d 100644
--- a/src/plugins/wp/cfgDump.ml
+++ b/src/plugins/wp/cfgDump.ml
@@ -54,9 +54,9 @@ let flush () =
match !fc with
| None -> ()
| Some (fout,file) ->
- close_out fout ;
- ignore (Sys.command
- (Printf.sprintf "dot -Tpdf %s.dot > %s.pdf" file file))
+ close_out fout ;
+ ignore (Sys.command
+ (Printf.sprintf "dot -Tpdf %s.dot > %s.pdf" file file))
end
(* -------------------------------------------------------------------------- *)
@@ -128,9 +128,9 @@ let pp_assigns fmt = function
| Cil_types.WritesAny -> Format.pp_print_string fmt " \\everything"
| Cil_types.Writes [] -> Format.pp_print_string fmt " \\nothing"
| Cil_types.Writes froms ->
- List.iter
- (fun (t,_) -> Format.fprintf fmt "@ %a" Printer.pp_identified_term t)
- froms
+ List.iter
+ (fun (t,_) -> Format.fprintf fmt "@ %a" Printer.pp_identified_term t)
+ froms
let add_assigns env (pid,_) k =
let u = node () in
@@ -142,11 +142,11 @@ let use_assigns _env region d k =
let u = node () in
begin match region with
| None ->
- Format.fprintf !out " %a [ color=orange , label=\"Havoc All\" ] ;@." pretty u
+ Format.fprintf !out " %a [ color=orange , label=\"Havoc All\" ] ;@." pretty u
| Some pid ->
- Format.fprintf !out " %a [ color=orange , label=\"Havoc %a:\n@[<hov 2>assigns%a;@]\" ] ;@."
- pretty u WpPropId.pp_propid pid
- pp_assigns d.WpPropId.a_assigns
+ Format.fprintf !out " %a [ color=orange , label=\"Havoc %a:\n@[<hov 2>assigns%a;@]\" ] ;@."
+ pretty u WpPropId.pp_propid pid
+ pp_assigns d.WpPropId.a_assigns
end ;
link u k ; u
@@ -155,9 +155,9 @@ let label _env stmt label k =
let u = node () in
( match stmt with
| None ->
- Format.fprintf !out " %a [ label=\"Label %a\" ] ;@." pretty u Clabels.pretty label
+ Format.fprintf !out " %a [ label=\"Label %a\" ] ;@." pretty u Clabels.pretty label
| Some s ->
- Format.fprintf !out " %a [ label=\"Label %a (Stmt s%d)\" ] ;@." pretty u Clabels.pretty label s.Cil_types.sid
+ Format.fprintf !out " %a [ label=\"Label %a (Stmt s%d)\" ] ;@." pretty u Clabels.pretty label s.Cil_types.sid
) ;
link u k ; u
@@ -172,10 +172,10 @@ let return _env _stmt r k =
begin
match r with
| None ->
- Format.fprintf !out " %a [ color=orange , label=\"Return\" ] ;@." pretty u
+ Format.fprintf !out " %a [ color=orange , label=\"Return\" ] ;@." pretty u
| Some e ->
- Format.fprintf !out " %a [ color=orange , label=\"Return %a\" ] ;@." pretty u
- Printer.pp_exp e
+ Format.fprintf !out " %a [ color=orange , label=\"Return %a\" ] ;@." pretty u
+ Printer.pp_exp e
end ;
link u k ; u
@@ -265,28 +265,28 @@ let call_decreases env _s kf _es (_id, (caller_d, rel)) ?caller_t ?callee_d k =
let pp_rel fmt callee_d =
match rel with
| None ->
- Format.fprintf fmt "%a ==> %a[%a] < %a[%s] && %a[%a] >= 0"
- pp_opt_pred caller_t
- Printer.pp_term callee_d Kernel_function.pretty kf
- Printer.pp_term caller_d "Caller"
- Printer.pp_term callee_d Kernel_function.pretty kf
+ Format.fprintf fmt "%a ==> %a[%a] < %a[%s] && %a[%a] >= 0"
+ pp_opt_pred caller_t
+ Printer.pp_term callee_d Kernel_function.pretty kf
+ Printer.pp_term caller_d "Caller"
+ Printer.pp_term callee_d Kernel_function.pretty kf
| Some rel ->
- Format.fprintf fmt "%a ==> %a(%a[%s], %a[%a])"
- pp_opt_pred caller_t
- Printer.pp_logic_info rel
- Printer.pp_term caller_d "Caller"
- Printer.pp_term callee_d Kernel_function.pretty kf
+ Format.fprintf fmt "%a ==> %a(%a[%s], %a[%a])"
+ pp_opt_pred caller_t
+ Printer.pp_logic_info rel
+ Printer.pp_term caller_d "Caller"
+ Printer.pp_term callee_d Kernel_function.pretty kf
in
Format.fprintf !out " %a [ color=red , label=\"Prove Decreases %a%t\" ] ;@."
pretty u Kernel_function.pretty kf
begin fun fmt ->
match callee_d with
| None ->
- Format.fprintf fmt "\n@[<hov 2>Decreases if %a ==> FALSE;@]"
- pp_opt_pred caller_t
+ Format.fprintf fmt "\n@[<hov 2>Decreases if %a ==> FALSE;@]"
+ pp_opt_pred caller_t
| Some (callee_d, _) ->
- if Wp_parameters.debug_atleast 1 then
- Format.fprintf fmt "\n@[<hov 2>Decreases if %a;@]" pp_rel callee_d
+ if Wp_parameters.debug_atleast 1 then
+ Format.fprintf fmt "\n@[<hov 2>Decreases if %a;@]" pp_rel callee_d
end ;
Format.fprintf !out " %a -> %a [ style=dotted ] ;@." pretty u pretty k ;
merge env u k
diff --git a/src/plugins/wp/cfgGenerator.ml b/src/plugins/wp/cfgGenerator.ml
index f59ab9189ee81c883b34211abc9cf7593dadaa93..8882f1bb64d7d054f95c3525a8a78bdeec5394ea 100644
--- a/src/plugins/wp/cfgGenerator.ml
+++ b/src/plugins/wp/cfgGenerator.ml
@@ -77,9 +77,9 @@ let select kf bnames =
match Annotations.behaviors kf with
| [] -> if bnames = [] then [empty_default_behavior] else []
| bhvs -> if bnames = [] then bhvs else
- List.filter
- (fun b -> List.mem b.b_name bnames)
- bhvs
+ List.filter
+ (fun b -> List.mem b.b_name bnames)
+ bhvs
(* -------------------------------------------------------------------------- *)
(* --- Elementary Tasks --- *)
@@ -97,9 +97,9 @@ let add_fun_task model pool ~kf ?infos ?bhvs ?target () =
let bhvs = match bhvs with
| Some bhvs -> bhvs
| None ->
- let bhvs = Annotations.behaviors kf in
- if List.exists (Cil.is_default_behavior) bhvs then bhvs
- else empty_default_behavior :: bhvs in
+ let bhvs = Annotations.behaviors kf in
+ if List.exists (Cil.is_default_behavior) bhvs then bhvs
+ else empty_default_behavior :: bhvs in
let add_mode kf m =
let ms = try KFmap.find kf pool.modes with Not_found -> [] in
pool.modes <- KFmap.add kf (m :: ms) pool.modes in
@@ -120,50 +120,50 @@ let rec strategy_ip model pool target =
let open Property in
match target with
| IPLemma { il_name } ->
- add_lemma_task pool (LogicUsage.logic_lemma il_name)
+ add_lemma_task pool (LogicUsage.logic_lemma il_name)
| IPAxiomatic { iax_props } ->
- List.iter (strategy_ip model pool) iax_props
+ List.iter (strategy_ip model pool) iax_props
| IPBehavior { ib_kf = kf ; ib_bhv = bhv } ->
- add_fun_task model pool ~kf ~bhvs:[bhv] ()
+ add_fun_task model pool ~kf ~bhvs:[bhv] ()
| IPPredicate { ip_kf = kf ; ip_kind ; ip_kinstr = ki } ->
- begin match ip_kind with
- | PKAssumes _ -> ()
- | PKRequires bhv ->
- begin
- match ki with
- | Kglobal -> (*TODO*) notyet target
- | Kstmt _ -> add_fun_task model pool ~kf ~bhvs:[bhv] ~target ()
- end
- | PKEnsures(bhv,_) ->
- add_fun_task model pool ~kf ~bhvs:[bhv] ~target ()
- | PKTerminates ->
- add_fun_task model pool ~kf ~bhvs:(default kf) ~target ()
- end
+ begin match ip_kind with
+ | PKAssumes _ -> ()
+ | PKRequires bhv ->
+ begin
+ match ki with
+ | Kglobal -> (*TODO*) notyet target
+ | Kstmt _ -> add_fun_task model pool ~kf ~bhvs:[bhv] ~target ()
+ end
+ | PKEnsures(bhv,_) ->
+ add_fun_task model pool ~kf ~bhvs:[bhv] ~target ()
+ | PKTerminates ->
+ add_fun_task model pool ~kf ~bhvs:(default kf) ~target ()
+ end
| IPDecrease { id_kf = kf } ->
- add_fun_task model pool ~kf ~bhvs:(default kf) ~target ()
+ add_fun_task model pool ~kf ~bhvs:(default kf) ~target ()
| IPAssigns { ias_kf=kf ; ias_bhv=Id_loop ca }
| IPAllocation { ial_kf=kf ; ial_bhv=Id_loop ca } ->
- let bhvs = match ca.annot_content with
- | AAssigns(bhvs,_) | AAllocation(bhvs,_) -> bhvs
- | _ -> [] in
- add_fun_task model pool ~kf ~bhvs:(select kf bhvs) ~target ()
+ let bhvs = match ca.annot_content with
+ | AAssigns(bhvs,_) | AAllocation(bhvs,_) -> bhvs
+ | _ -> [] in
+ add_fun_task model pool ~kf ~bhvs:(select kf bhvs) ~target ()
| IPAssigns { ias_kf=kf ; ias_bhv=Id_contract(_,bhv) }
| IPAllocation { ial_kf=kf ; ial_bhv=Id_contract(_,bhv) }
-> add_fun_task model pool ~kf ~bhvs:[bhv] ~target ()
| IPCodeAnnot { ica_kf = kf ; ica_ca = ca } ->
- begin match ca.annot_content with
- | AExtended _ | APragma _ -> ()
- | AStmtSpec(fors,_) ->
- (*TODO*) notyet target ;
- add_fun_task model pool ~kf ~bhvs:(select kf fors) ()
- | AVariant _ ->
- add_fun_task model pool ~kf ~target ()
- | AAssert(fors, _)
- | AInvariant(fors, _, _)
- | AAssigns(fors, _)
- | AAllocation(fors, _) ->
- add_fun_task model pool ~kf ~bhvs:(select kf fors) ~target ()
- end
+ begin match ca.annot_content with
+ | AExtended _ | APragma _ -> ()
+ | AStmtSpec(fors,_) ->
+ (*TODO*) notyet target ;
+ add_fun_task model pool ~kf ~bhvs:(select kf fors) ()
+ | AVariant _ ->
+ add_fun_task model pool ~kf ~target ()
+ | AAssert(fors, _)
+ | AInvariant(fors, _, _)
+ | AAssigns(fors, _)
+ | AAllocation(fors, _) ->
+ add_fun_task model pool ~kf ~bhvs:(select kf fors) ~target ()
+ end
| IPComplete _ -> (*TODO*) notyet target
| IPDisjoint _ -> (*TODO*) notyet target
| IPFrom _ | IPReachable _ | IPTypeInvariant _ | IPGlobalInvariant _
diff --git a/src/plugins/wp/cfgInfos.ml b/src/plugins/wp/cfgInfos.ml
index f0a57aa80c91133588299430e0d3fc4c6ea19614..4ff31f401e0d7f60e7b9bec62d8cd57ea20784f6 100644
--- a/src/plugins/wp/cfgInfos.ml
+++ b/src/plugins/wp/cfgInfos.ml
@@ -60,7 +60,7 @@ let smoking infos s = wpreached s infos.reachability
let unreachable infos v =
match infos.body, infos.checkpath with
| Some cfg , Some checkpath ->
- not @@ CheckPath.check_path checkpath cfg.entry_point v
+ not @@ CheckPath.check_path checkpath cfg.entry_point v
| _ -> true
let terminates_deps infos = infos.terminates_deps
@@ -83,11 +83,11 @@ let selected_assigns ~prop = function
| Cil_types.WritesAny -> false
| Writes _ when prop = [] -> true
| Writes l ->
- let collect_names l (t, _) =
- WpPropId.ident_names t.Cil_types.it_content.term_name @ l
- in
- let names = List.fold_left collect_names ["@assigns"] l in
- WpPropId.are_selected_names prop names
+ let collect_names l (t, _) =
+ WpPropId.ident_names t.Cil_types.it_content.term_name @ l
+ in
+ let names = List.fold_left collect_names ["@assigns"] l in
+ WpPropId.are_selected_names prop names
let selected_allocates ~prop = function
| Cil_types.FreeAllocAny -> false
@@ -117,19 +117,19 @@ let selected_clause ~prop name getter kf =
let selected_terminates ~prop kf =
match Annotations.terminates kf with
| None ->
- Wp_parameters.TerminatesDefinitions.get ()
+ Wp_parameters.TerminatesDefinitions.get ()
| Some ip ->
- let tk_name = "@terminates" in
- let tp_names = WpPropId.user_pred_names ip.Cil_types.ip_content in
- WpPropId.are_selected_names prop (tk_name :: tp_names)
+ let tk_name = "@terminates" in
+ let tp_names = WpPropId.user_pred_names ip.Cil_types.ip_content in
+ WpPropId.are_selected_names prop (tk_name :: tp_names)
let selected_decreases ~prop kf =
match Annotations.decreases kf with
| None -> false
| Some (it, _) ->
- let tk_name = "@decreases" in
- let tp_names = WpPropId.ident_names it.term_name in
- WpPropId.are_selected_names prop (tk_name :: tp_names)
+ let tk_name = "@decreases" in
+ let tp_names = WpPropId.ident_names it.term_name in
+ WpPropId.are_selected_names prop (tk_name :: tp_names)
let selected_disjoint_complete kf ~bhv ~prop =
selected_default ~bhv &&
@@ -156,32 +156,32 @@ let collect_calls ~bhv ?(on_missing_calls=fun _ -> ()) kf stmt =
let open Cil_types in
match stmt.skind with
| Instr(Call(_,fct,_,_)) ->
- begin
- match Kernel_function.get_called fct with
- | Some kf -> Fset.singleton kf
- | None ->
- let bhvs =
- if bhv = []
- then List.map (fun b -> b.b_name) (Annotations.behaviors kf)
- else bhv in
- let calls =
- List.fold_left
- (fun fs bhv -> match Dyncall.get ~bhv stmt with
- | None -> fs
- | Some(_,kfs) -> List.fold_right Fset.add kfs fs
- ) Fset.empty bhvs
- in
- if Fset.is_empty calls then
- on_missing_calls stmt ;
- calls
- end
+ begin
+ match Kernel_function.get_called fct with
+ | Some kf -> Fset.singleton kf
+ | None ->
+ let bhvs =
+ if bhv = []
+ then List.map (fun b -> b.b_name) (Annotations.behaviors kf)
+ else bhv in
+ let calls =
+ List.fold_left
+ (fun fs bhv -> match Dyncall.get ~bhv stmt with
+ | None -> fs
+ | Some(_,kfs) -> List.fold_right Fset.add kfs fs
+ ) Fset.empty bhvs
+ in
+ if Fset.is_empty calls then
+ on_missing_calls stmt ;
+ calls
+ end
| Instr(Local_init(x,ConsInit(vf, args, kind), loc)) ->
- Cil.treat_constructor_as_func
- (fun _r fct _args _loc ->
- match Kernel_function.get_called fct with
- | Some kf -> Fset.singleton kf
- | None -> Fset.empty)
- x vf args kind loc
+ Cil.treat_constructor_as_func
+ (fun _r fct _args _loc ->
+ match Kernel_function.get_called fct with
+ | Some kf -> Fset.singleton kf
+ | None -> Fset.empty)
+ x vf args kind loc
| _ -> Fset.empty
(* -------------------------------------------------------------------------- *)
@@ -196,13 +196,13 @@ module Callees = WpContext.StaticGenerator(Kernel_function)
let name = "Wp.CfgInfos.SCallees"
let compile = function
| { Cil_types.fundec = Definition(fd, _ ) } as kf ->
- let stmts = ref [] in
- let on_missing_calls s = stmts := s :: !stmts in
- let fold e s =
- Fset.union e (collect_calls ~on_missing_calls ~bhv:[] kf s)
- in
- let kfs = List.fold_left fold Fset.empty fd.sallstmts in
- kfs, !stmts
+ let stmts = ref [] in
+ let on_missing_calls s = stmts := s :: !stmts in
+ let fold e s =
+ Fset.union e (collect_calls ~on_missing_calls ~bhv:[] kf s)
+ in
+ let kfs = List.fold_left fold Fset.empty fd.sallstmts in
+ kfs, !stmts
| _ -> Fset.empty, []
end)
@@ -254,10 +254,10 @@ struct
env.stack <- stack;
begin match cluster with
| [ x ] when base = max_int ->
- HT.add env.clusters x None
+ HT.add env.clusters x None
| cluster ->
- let set = Some (Fset.of_list cluster) in
- List.iter (fun kf -> HT.add env.clusters kf set) cluster
+ let set = Some (Fset.of_list cluster) in
+ List.iter (fun kf -> HT.add env.clusters kf set) cluster
end ;
max_int
end
@@ -315,12 +315,12 @@ let collect_loops_no_variant kf stmt =
in
match stmt.skind with
| Loop _ ->
- begin match Annotations.fold_code_annot fold_no_variant stmt None with
- | None -> Sset.singleton stmt, Pset.empty
- | Some (ca, v) -> Sset.empty, props_of_v ca (fst v)
- end
+ begin match Annotations.fold_code_annot fold_no_variant stmt None with
+ | None -> Sset.singleton stmt, Pset.empty
+ | Some (ca, v) -> Sset.empty, props_of_v ca (fst v)
+ end
| _ ->
- Sset.empty, Pset.empty
+ Sset.empty, Pset.empty
(* -------------------------------------------------------------------------- *)
(* --- Trivially terminates --- *)
@@ -368,8 +368,8 @@ struct
match xs with
| [] -> ()
| x::xs ->
- Format.fprintf fmt "~%s:%s" kind x ;
- List.iter (Format.fprintf fmt ",%s") xs
+ Format.fprintf fmt "~%s:%s" kind x ;
+ List.iter (Format.fprintf fmt ",%s") xs
let pretty fmt k =
begin
@@ -399,18 +399,18 @@ let dead_posts ~bhv ~prop tk (bhvs : CfgAnnot.behavior list) =
let loop_contract_pids kf stmt =
match stmt.Cil_types.skind with
| Loop _ ->
- let invs = CfgAnnot.get_loop_contract kf stmt in
- let add_assigns assigns l =
- match assigns with
- | WpPropId.NoAssignsInfo | AssignsAny _ -> l
- | AssignsLocations (pid, _) -> pid :: l
- in
- let verif_fold CfgAnnot.{ loop_est ; loop_ind } l =
- let l = Option.fold ~none:l ~some:(fun i -> i :: l) loop_est in
- Option.fold ~none:l ~some:(fun i -> i :: l) loop_ind
- in
- List.fold_right verif_fold invs.loop_invariants @@
- List.fold_right add_assigns invs.loop_assigns []
+ let invs = CfgAnnot.get_loop_contract kf stmt in
+ let add_assigns assigns l =
+ match assigns with
+ | WpPropId.NoAssignsInfo | AssignsAny _ -> l
+ | AssignsLocations (pid, _) -> pid :: l
+ in
+ let verif_fold CfgAnnot.{ loop_est ; loop_ind } l =
+ let l = Option.fold ~none:l ~some:(fun i -> i :: l) loop_est in
+ Option.fold ~none:l ~some:(fun i -> i :: l) loop_ind
+ in
+ List.fold_right verif_fold invs.loop_invariants @@
+ List.fold_right add_assigns invs.loop_assigns []
| _ -> []
let compile Key.{ kf ; smoking ; bhv ; prop } =
@@ -500,36 +500,36 @@ let compile Key.{ kf ; smoking ; bhv ; prop } =
if Kernel_function.is_definition kf then
match CfgAnnot.get_terminates_goal kf with
| Some (id, _) when selected_terminates ~prop kf ->
- let warning_locs =
- List.map Cil_datatype.Stmt.loc @@ snd @@ Callees.get kf
- in
- if warning_locs <> [] then
- Wp_parameters.warning ~once:true
- "In '%a', no 'calls' specification for statement(s) on \
- line(s): %a, @\nAssuming that they can call '%a'"
- Kernel_function.pretty kf
- (Pretty_utils.pp_list ~sep:", " Cil_datatype.Location.pretty_line)
- warning_locs
- Kernel_function.pretty kf ;
- if is_recursive kf then
- (* Notes:
- - a recursive function never trivially terminates,
- - in absence of decreases, CfgCalculus will warn *)
- begin match CfgAnnot.get_decreases_goal kf with
- | None -> infos
- | Some (id, _) ->
- let deps =
- Pset.add (WpPropId.property_of_id id) infos.terminates_deps
- in
- { infos with terminates_deps = deps }
- end
- else if infos.calls = Fset.empty
- && infos.no_variant_loops = Sset.empty then begin
- set_trivially_terminates id infos.terminates_deps ;
- (* Drop dependencies for this terminates, we've used it. *)
- { infos with terminates_deps = Pset.empty }
+ let warning_locs =
+ List.map Cil_datatype.Stmt.loc @@ snd @@ Callees.get kf
+ in
+ if warning_locs <> [] then
+ Wp_parameters.warning ~once:true
+ "In '%a', no 'calls' specification for statement(s) on \
+ line(s): %a, @\nAssuming that they can call '%a'"
+ Kernel_function.pretty kf
+ (Pretty_utils.pp_list ~sep:", " Cil_datatype.Location.pretty_line)
+ warning_locs
+ Kernel_function.pretty kf ;
+ if is_recursive kf then
+ (* Notes:
+ - a recursive function never trivially terminates,
+ - in absence of decreases, CfgCalculus will warn *)
+ begin match CfgAnnot.get_decreases_goal kf with
+ | None -> infos
+ | Some (id, _) ->
+ let deps =
+ Pset.add (WpPropId.property_of_id id) infos.terminates_deps
+ in
+ { infos with terminates_deps = deps }
end
- else infos
+ else if infos.calls = Fset.empty
+ && infos.no_variant_loops = Sset.empty then begin
+ set_trivially_terminates id infos.terminates_deps ;
+ (* Drop dependencies for this terminates, we've used it. *)
+ { infos with terminates_deps = Pset.empty }
+ end
+ else infos
| _ -> infos
else infos
in
diff --git a/src/plugins/wp/cfgWP.ml b/src/plugins/wp/cfgWP.ml
index 2ce1303333b56c06b634c2717998687d367e9361..d895121639455be3648e40beb29dfee4c96a4e5d 100644
--- a/src/plugins/wp/cfgWP.ml
+++ b/src/plugins/wp/cfgWP.ml
@@ -73,11 +73,11 @@ struct
| Gprop _ , _ -> (-1)
| _ , Gprop _ -> 1
| Gsource(p1,s1,e1) , Gsource(p2,s2,e2) ->
- let c = P.compare p1 p2 in
+ let c = P.compare p1 p2 in
+ if c <> 0 then c else
+ let c = Stmt.compare s1 s2 in
if c <> 0 then c else
- let c = Stmt.compare s1 s2 in
- if c <> 0 then c else
- hsrc e1 - hsrc e2
+ hsrc e1 - hsrc e2
| Gsource _ , _ -> (-1)
| _ , Gsource _ -> 1
| Gposteffect p1 , Gposteffect p2 -> P.compare p1 p2
@@ -171,9 +171,9 @@ struct
match tags with
| [] -> ()
| t::ts ->
- Format.fprintf fmt " (%a" Splitter.pretty t ;
- List.iter (fun t -> Format.fprintf fmt ",%a" Splitter.pretty t) ts ;
- Format.fprintf fmt ")@\n" ;
+ Format.fprintf fmt " (%a" Splitter.pretty t ;
+ List.iter (fun t -> Format.fprintf fmt ",%a" Splitter.pretty t) ts ;
+ Format.fprintf fmt ")@\n" ;
end ;
Format.fprintf fmt "@[<hov 5> (%d) %a@]@\n" !k pp_vc vc)
vcs
@@ -320,18 +320,18 @@ struct
| [] -> empty_vc
| [vc] -> vc
| vcs ->
- let hyps = Conditions.merge (List.map (fun vc -> vc.hyps) vcs) in
- let goal = p_all (fun vc -> vc.goal) vcs in
- let vars = List.fold_left (fun d vc -> V.union d vc.vars) V.empty vcs in
- let deps = List.fold_left (fun d vc -> D.union d vc.deps) D.empty vcs in
- let warn = List.fold_left (fun d vc -> W.union d vc.warn) W.empty vcs in
- let path = List.fold_left (fun d vc -> S.union d vc.path) S.empty vcs in
- { hyps = hyps ;
- goal = goal ;
- vars = vars ;
- deps = deps ;
- warn = warn ;
- path = path }
+ let hyps = Conditions.merge (List.map (fun vc -> vc.hyps) vcs) in
+ let goal = p_all (fun vc -> vc.goal) vcs in
+ let vars = List.fold_left (fun d vc -> V.union d vc.vars) V.empty vcs in
+ let deps = List.fold_left (fun d vc -> D.union d vc.deps) D.empty vcs in
+ let warn = List.fold_left (fun d vc -> W.union d vc.warn) W.empty vcs in
+ let path = List.fold_left (fun d vc -> S.union d vc.path) S.empty vcs in
+ { hyps = hyps ;
+ goal = goal ;
+ vars = vars ;
+ deps = deps ;
+ warn = warn ;
+ path = path }
(* -------------------------------------------------------------------------- *)
(* --- Merging and Branching with Splitters --- *)
@@ -348,11 +348,11 @@ struct
match w1 , w2 with
| None , None -> None
| Some vcs1 , None ->
- Some (Splitter.map left vcs1)
+ Some (Splitter.map left vcs1)
| None , Some vcs2 ->
- Some (Splitter.map right vcs2)
+ Some (Splitter.map right vcs2)
| Some vcs1 , Some vcs2 ->
- Some (Splitter.merge ~left ~both ~right vcs1 vcs2)
+ Some (Splitter.merge ~left ~both ~right vcs1 vcs2)
) vcs1 vcs2
let merge_all_vcs : vc Splitter.t Gmap.t list -> vc Splitter.t Gmap.t =
@@ -422,10 +422,10 @@ struct
(fun wp ->
match wp.sigma with
| None ->
- let s = Sigma.create () in
- phi (L.move_at wenv.main s) { wp with sigma = Some s }
+ let s = Sigma.create () in
+ phi (L.move_at wenv.main s) { wp with sigma = Some s }
| Some s ->
- phi (L.move_at wenv.main s) wp) wp
+ phi (L.move_at wenv.main s) wp) wp
(* -------------------------------------------------------------------------- *)
(* --- Compilation of Goals --- *)
@@ -461,17 +461,17 @@ struct
in match authorized_region with
| None -> None
| Some region ->
- let post = match ainfo.a_kind with
- | LoopAssigns -> true
- | StmtAssigns -> NormAtLabels.has_postassigns ainfo.a_assigns
- in Some {
- e_pid = pid ;
- e_post = post ;
- e_label = from ;
- e_valid = sigma ;
- e_region = region ;
- e_warn = Warning.Set.empty ;
- }
+ let post = match ainfo.a_kind with
+ | LoopAssigns -> true
+ | StmtAssigns -> NormAtLabels.has_postassigns ainfo.a_assigns
+ in Some {
+ e_pid = pid ;
+ e_post = post ;
+ e_label = from ;
+ e_valid = sigma ;
+ e_region = region ;
+ e_warn = Warning.Set.empty ;
+ }
let cc_posteffect e vcs =
if not e.e_post then vcs else
@@ -532,13 +532,13 @@ struct
in match outcome with
| Warning.Result (_,None) -> wp
| Warning.Result (warn,Some e) ->
- let e = { e with e_warn = warn } in
- let effects = Eset.add e wp.effects in
- let vcs = cc_posteffect e wp.vcs in
- { wp with effects = effects ; vcs = vcs }
+ let e = { e with e_warn = warn } in
+ let effects = Eset.add e wp.effects in
+ let vcs = cc_posteffect e wp.vcs in
+ { wp with effects = effects ; vcs = vcs }
| Warning.Failed warn ->
- let vcs = add_vc (Gprop gpid) ~warn p_false wp.vcs in
- { wp with vcs = vcs }
+ let vcs = add_vc (Gprop gpid) ~warn p_false wp.vcs in
+ { wp with vcs = vcs }
end
let add_warnings wrns vcs =
@@ -636,28 +636,28 @@ struct
match ainfo.a_assigns with
| WritesAny ->
- let sigma = Sigma.havoc_any ~call:false (L.current env) in
- let vcs = do_assigns_everything ?stmt wp.effects wp.vcs in
- { sigma = Some sigma ; vcs=vcs ; effects = wp.effects }
+ let sigma = Sigma.havoc_any ~call:false (L.current env) in
+ let vcs = do_assigns_everything ?stmt wp.effects wp.vcs in
+ { sigma = Some sigma ; vcs=vcs ; effects = wp.effects }
| Writes froms ->
- let kind = ainfo.WpPropId.a_kind in
- let outcome =
- Warning.catch ~severe:true ~effect:"Assigns everything"
- (cc_assigned env kind) froms
- in
- match outcome with
- | Warning.Result(warn,(sequence,assigned)) ->
- let vcs =
- do_assigns ~source:FromCode
- ?hpid ?stmt ~warn sequence
- ~assigned
- wp.effects wp.vcs in
- { sigma = Some sequence.pre ; vcs=vcs ; effects = wp.effects }
- | Warning.Failed warn ->
- let sigma = Sigma.havoc_any ~call:false (L.current env) in
- let vcs = do_assigns_everything ?stmt ~warn wp.effects wp.vcs in
- { sigma = Some sigma ; vcs=vcs ; effects = wp.effects }
+ let kind = ainfo.WpPropId.a_kind in
+ let outcome =
+ Warning.catch ~severe:true ~effect:"Assigns everything"
+ (cc_assigned env kind) froms
+ in
+ match outcome with
+ | Warning.Result(warn,(sequence,assigned)) ->
+ let vcs =
+ do_assigns ~source:FromCode
+ ?hpid ?stmt ~warn sequence
+ ~assigned
+ wp.effects wp.vcs in
+ { sigma = Some sequence.pre ; vcs=vcs ; effects = wp.effects }
+ | Warning.Failed warn ->
+ let sigma = Sigma.havoc_any ~call:false (L.current env) in
+ let vcs = do_assigns_everything ?stmt ~warn wp.effects wp.vcs in
+ { sigma = Some sigma ; vcs=vcs ; effects = wp.effects }
end
(* -------------------------------------------------------------------------- *)
@@ -674,7 +674,7 @@ struct
let descr : string option = match stmt with
| None | Some { labels=[] } -> None
| Some { labels = lbl::_ } ->
- Some (Pretty_utils.to_string Printer.pp_label lbl) in
+ Some (Pretty_utils.to_string Printer.pp_label lbl) in
let state = Mstate.state state sigma in
gmap (state_vc ?descr ?stmt sigma state) vcs
with Not_found -> vcs
@@ -722,18 +722,18 @@ struct
else
let value = match expr.enode with
| Lval lv when not @@ intercept_volatile "read" lv ->
- M.copied seq obj loc (C.lval seq.pre lv)
+ M.copied seq obj loc (C.lval seq.pre lv)
| _ ->
- (* Note: a volatile lval will be compiled to an unknown value *)
- M.stored seq obj loc (C.val_of_exp seq.pre expr)
+ (* Note: a volatile lval will be compiled to an unknown value *)
+ M.stored seq obj loc (C.val_of_exp seq.pre expr)
in
let init = match expr.enode with
| Lval lv when intercept_volatile "read" lv ->
- M.stored_init seq obj loc (Cvalues.initialized_obj obj)
+ M.stored_init seq obj loc (Cvalues.initialized_obj obj)
| Lval lv when Cil.(isStructOrUnionType @@ typeOfLval lv) ->
- M.copied_init seq obj loc (C.lval seq.pre lv)
+ M.copied_init seq obj loc (C.lval seq.pre lv)
| _ ->
- M.stored_init seq obj loc (Cvalues.initialized_obj obj)
+ M.stored_init seq obj loc (Cvalues.initialized_obj obj)
in
Some (value @ init)
@@ -744,40 +744,40 @@ struct
(cc_lval env) lv in
match outcome with
| Warning.Failed warn ->
- (* L-Value is unknown *)
- let sigma = Sigma.havoc_any ~call:false (L.current env) in
- let vcs = do_assigns_everything ~stmt ~warn wp.effects wp.vcs in
- { sigma = Some sigma ; vcs=vcs ; effects = wp.effects }
+ (* L-Value is unknown *)
+ let sigma = Sigma.havoc_any ~call:false (L.current env) in
+ let vcs = do_assigns_everything ~stmt ~warn wp.effects wp.vcs in
+ { sigma = Some sigma ; vcs=vcs ; effects = wp.effects }
| Warning.Result(l_warn,(obj,dom,seq,loc)) ->
- (* L-Value has been translated *)
- let assigned = [obj,Sloc loc] in
- let outcome = Warning.catch
- ~severe:false ~effect:"Havoc l-value (unknown r-value)"
- (cc_stored lv seq loc obj) expr in
- match outcome with
- | Warning.Failed r_warn
- | Warning.Result(r_warn,None) ->
- (* R-Value is unknown or L-Value is volatile *)
- let warn = Warning.Set.union l_warn r_warn in
- let vcs = do_assigns ~source:FromCode
- ~stmt ~warn seq ~assigned wp.effects wp.vcs in
- { sigma = Some seq.pre ; vcs=vcs ; effects = wp.effects }
- | Warning.Result(r_warn,Some stored) ->
- (* R-Value and effects has been translated *)
- let warn = Warning.Set.union l_warn r_warn in
- let ft = M.Heap.Set.fold_sorted
- (fun chunk ft -> M.Sigma.get seq.post chunk :: ft) dom []
- in
- let update vc =
- if List.exists (occurs_vc vc) ft
- then
- let eqs = List.map Cvalues.equation stored in
- assume_vc ~stmt ~warn eqs vc
- else vc in
- let vcs = gmap update wp.vcs in
- let vcs =
- check_assigns (Some stmt) FromCode assigned wp.effects vcs in
- { sigma = Some seq.pre ; vcs=vcs ; effects = wp.effects }
+ (* L-Value has been translated *)
+ let assigned = [obj,Sloc loc] in
+ let outcome = Warning.catch
+ ~severe:false ~effect:"Havoc l-value (unknown r-value)"
+ (cc_stored lv seq loc obj) expr in
+ match outcome with
+ | Warning.Failed r_warn
+ | Warning.Result(r_warn,None) ->
+ (* R-Value is unknown or L-Value is volatile *)
+ let warn = Warning.Set.union l_warn r_warn in
+ let vcs = do_assigns ~source:FromCode
+ ~stmt ~warn seq ~assigned wp.effects wp.vcs in
+ { sigma = Some seq.pre ; vcs=vcs ; effects = wp.effects }
+ | Warning.Result(r_warn,Some stored) ->
+ (* R-Value and effects has been translated *)
+ let warn = Warning.Set.union l_warn r_warn in
+ let ft = M.Heap.Set.fold_sorted
+ (fun chunk ft -> M.Sigma.get seq.post chunk :: ft) dom []
+ in
+ let update vc =
+ if List.exists (occurs_vc vc) ft
+ then
+ let eqs = List.map Cvalues.equation stored in
+ assume_vc ~stmt ~warn eqs vc
+ else vc in
+ let vcs = gmap update wp.vcs in
+ let vcs =
+ check_assigns (Some stmt) FromCode assigned wp.effects vcs in
+ { sigma = Some seq.pre ; vcs=vcs ; effects = wp.effects }
end
(* -------------------------------------------------------------------------- *)
@@ -788,27 +788,27 @@ struct
match result with
| None -> wp
| Some exp ->
- in_wenv wenv wp
- begin fun env wp ->
- let compile () =
- let sigma = L.current env in
- let vr = L.result () in
- let tr = L.return () in
- p_equal (C.result sigma tr vr) (C.return sigma tr exp) in
- let outcome = Warning.catch
- ~severe:false ~effect:"Result value discarded (unknown)"
- compile () in
- let warn, condition =
- match outcome with
- | Warning.Failed warn ->
- warn , p_true
- | Warning.Result(warn,condition) ->
- warn , condition in
- let vcs = gmap (
- assume_vc ~descr:"Return" ~stmt ~warn [condition]
- ) wp.vcs in
- { wp with vcs = vcs }
- end
+ in_wenv wenv wp
+ begin fun env wp ->
+ let compile () =
+ let sigma = L.current env in
+ let vr = L.result () in
+ let tr = L.return () in
+ p_equal (C.result sigma tr vr) (C.return sigma tr exp) in
+ let outcome = Warning.catch
+ ~severe:false ~effect:"Result value discarded (unknown)"
+ compile () in
+ let warn, condition =
+ match outcome with
+ | Warning.Failed warn ->
+ warn , p_true
+ | Warning.Result(warn,condition) ->
+ warn , condition in
+ let vcs = gmap (
+ assume_vc ~descr:"Return" ~stmt ~warn [condition]
+ ) wp.vcs in
+ { wp with vcs = vcs }
+ end
(* -------------------------------------------------------------------------- *)
(* --- WP RULE : conditional --- *)
@@ -878,11 +878,11 @@ struct
let rec cc_case_values ks vs sigma = function
| [] -> ks , vs
| e::es ->
- match Ctypes.get_int64 e with
- | Some k ->
- cc_case_values (k::ks) (F.e_int64 k::vs) sigma es
- | None ->
- cc_case_values ks (C.val_of_exp sigma e::vs) sigma es
+ match Ctypes.get_int64 e with
+ | Some k ->
+ cc_case_values (k::ks) (F.e_int64 k::vs) sigma es
+ | None ->
+ cc_case_values ks (C.val_of_exp sigma e::vs) sigma es
let cc_group_case stmt warn descr tag pa cond vcs : vc Splitter.t Gmap.t =
Gmap.map
@@ -923,8 +923,8 @@ struct
with
| Warning.Result(warn,value) -> warn,value
| Warning.Failed(warn) ->
- let tau = Lang.tau_of_ctype (Cil.typeOf exp) in
- warn,e_var (Lang.freshvar tau)
+ let tau = Lang.tau_of_ctype (Cil.typeOf exp) in
+ warn,e_var (Lang.freshvar tau)
in
let vcs_cases = List.map (cc_case stmt warn sigma value) cases in
let neq = List.map (fun (vs,_) -> p_all (p_neq value) vs) vcs_cases in
@@ -1026,29 +1026,29 @@ struct
(List.map (C.exp sigma)) es in
match outcome with
| Warning.Failed warn ->
- let vcs = List.fold_left
- (fun vcs (gid,_) -> add_vc (Gprop gid) ~warn p_false vcs)
- wp.vcs pre
- in { wp with vcs = vcs }
+ let vcs = List.fold_left
+ (fun vcs (gid,_) -> add_vc (Gprop gid) ~warn p_false vcs)
+ wp.vcs pre
+ in { wp with vcs = vcs }
| Warning.Result(warn,vs) ->
- let init = L.mem_at env Clabels.init in
- let call = L.call kf vs in
- let call_e = L.mk_env ~here:sigma () in
- let call_f = L.call_pre init call sigma in
- let vcs = List.fold_left
- (fun vcs (gid,p) ->
- let outcome = Warning.catch
- ~severe:true ~effect:"Can not prove call precondition"
- (L.in_frame call_f (L.pred `Positive call_e)) p in
- match outcome with
- | Warning.Result(warn2,goal) ->
- let warn = W.union warn warn2 in
- add_vc (Gprop gid) ~warn goal vcs
- | Warning.Failed warn2 ->
- let warn = W.union warn warn2 in
- add_vc (Gprop gid) ~warn p_false vcs
- ) wp.vcs pre
- in { wp with vcs = vcs })
+ let init = L.mem_at env Clabels.init in
+ let call = L.call kf vs in
+ let call_e = L.mk_env ~here:sigma () in
+ let call_f = L.call_pre init call sigma in
+ let vcs = List.fold_left
+ (fun vcs (gid,p) ->
+ let outcome = Warning.catch
+ ~severe:true ~effect:"Can not prove call precondition"
+ (L.in_frame call_f (L.pred `Positive call_e)) p in
+ match outcome with
+ | Warning.Result(warn2,goal) ->
+ let warn = W.union warn warn2 in
+ add_vc (Gprop gid) ~warn goal vcs
+ | Warning.Failed warn2 ->
+ let warn = W.union warn warn2 in
+ add_vc (Gprop gid) ~warn p_false vcs
+ ) wp.vcs pre
+ in { wp with vcs = vcs })
(* -------------------------------------------------------------------------- *)
(* --- WP RULE : call terminates --- *)
@@ -1076,34 +1076,34 @@ struct
(List.map (C.exp sigma)) args in
match outcome with
| Warning.Failed warn2 ->
- let warn = W.union warn warn2 in
- let vcs = prove_terminates ~warn p_false wp.vcs in
- { wp with vcs = vcs }
+ let warn = W.union warn warn2 in
+ let vcs = prove_terminates ~warn p_false wp.vcs in
+ { wp with vcs = vcs }
| Warning.Result(warn2, args) ->
- let warn = W.union warn warn2 in
- let compile_callee = function
- | None ->
- Warning.error "No terminates clause for %a"
- Kernel_function.pretty kf
- | Some callee_t ->
- let init = L.mem_at env Clabels.init in
- let call = L.call kf args in
- let call_e = L.mk_env ~here:sigma () in
- let call_f = L.call_pre init call sigma in
- L.in_frame call_f (L.pred `Positive call_e) callee_t
- in
- let outcome =
- Warning.catch
- ~severe:true ~effect:"Considering non terminating callee"
- compile_callee callee_t
- in
- let warn2, callee_t = match outcome with
- | Warning.Failed warn -> warn, p_false
- | Warning.Result(warn,callee_t) -> warn, callee_t
- in
- let warn = W.union warn warn2 in
- let vcs = prove_terminates ~warn callee_t wp.vcs in
- { wp with vcs = vcs })
+ let warn = W.union warn warn2 in
+ let compile_callee = function
+ | None ->
+ Warning.error "No terminates clause for %a"
+ Kernel_function.pretty kf
+ | Some callee_t ->
+ let init = L.mem_at env Clabels.init in
+ let call = L.call kf args in
+ let call_e = L.mk_env ~here:sigma () in
+ let call_f = L.call_pre init call sigma in
+ L.in_frame call_f (L.pred `Positive call_e) callee_t
+ in
+ let outcome =
+ Warning.catch
+ ~severe:true ~effect:"Considering non terminating callee"
+ compile_callee callee_t
+ in
+ let warn2, callee_t = match outcome with
+ | Warning.Failed warn -> warn, p_false
+ | Warning.Result(warn,callee_t) -> warn, callee_t
+ in
+ let warn = W.union warn warn2 in
+ let vcs = prove_terminates ~warn callee_t wp.vcs in
+ { wp with vcs = vcs })
(* -------------------------------------------------------------------------- *)
(* --- WP RULE : call decreases --- *)
@@ -1137,53 +1137,53 @@ struct
(List.map (C.exp sigma)) args in
match outcome with
| Warning.Failed warn2 ->
- let warn = W.union warn warn2 in
- let vcs = prove_decreases ~warn p_false wp.vcs in
- { wp with vcs = vcs }
+ let warn = W.union warn warn2 in
+ let vcs = prove_decreases ~warn p_false wp.vcs in
+ { wp with vcs = vcs }
| Warning.Result(warn2, args) ->
- let warn = W.union warn warn2 in
- let init = L.mem_at env Clabels.init in
- let call = L.call kf args in
- let call_e = L.mk_env ~here:sigma () in
- let call_f = L.call_pre init call sigma in
- let compile_decreases (caller_d, callee_d) =
- match caller_d, callee_d with
- | _, None ->
- Warning.error "No decreases clause for %a"
- Kernel_function.pretty kf
- | (_, r), Some (_, r')
- when not @@ Option.equal Logic_utils.is_same_logic_info r r' ->
- let none : Pretty_utils.sformat = "<None>" in
- Warning.error
- "On call to %a, relation (%a) does not match caller (%a)"
- Kernel_function.pretty kf
- (Pretty_utils.pp_opt ~none Cil_printer.pp_logic_info) r
- (Pretty_utils.pp_opt ~none Cil_printer.pp_logic_info) r'
- | (caller_d, rel), Some (callee_d,_ ) ->
- let rel caller callee = match rel with
- | None ->
- p_and (p_leq e_zero callee) (p_lt callee caller)
- | Some rel ->
- (L.in_frame call_f (L.call_pred call_e))
- rel [] [caller ; callee]
- in
- let caller_d = L.term env caller_d in
- let callee_d =
- (L.in_frame call_f (L.term call_e)) callee_d in
- rel caller_d callee_d
- in
- let outcome =
- Warning.catch
- ~severe:true ~effect:"Considering non decreasing call"
- compile_decreases (caller_d, callee_d)
- in
- let warn2, pred = match outcome with
- | Warning.Failed warn -> warn, p_false
- | Warning.Result (warn, p) -> warn, p
- in
- let warn = W.union warn warn2 in
- let vcs = prove_decreases ~warn pred wp.vcs in
- { wp with vcs = vcs })
+ let warn = W.union warn warn2 in
+ let init = L.mem_at env Clabels.init in
+ let call = L.call kf args in
+ let call_e = L.mk_env ~here:sigma () in
+ let call_f = L.call_pre init call sigma in
+ let compile_decreases (caller_d, callee_d) =
+ match caller_d, callee_d with
+ | _, None ->
+ Warning.error "No decreases clause for %a"
+ Kernel_function.pretty kf
+ | (_, r), Some (_, r')
+ when not @@ Option.equal Logic_utils.is_same_logic_info r r' ->
+ let none : Pretty_utils.sformat = "<None>" in
+ Warning.error
+ "On call to %a, relation (%a) does not match caller (%a)"
+ Kernel_function.pretty kf
+ (Pretty_utils.pp_opt ~none Cil_printer.pp_logic_info) r
+ (Pretty_utils.pp_opt ~none Cil_printer.pp_logic_info) r'
+ | (caller_d, rel), Some (callee_d,_ ) ->
+ let rel caller callee = match rel with
+ | None ->
+ p_and (p_leq e_zero callee) (p_lt callee caller)
+ | Some rel ->
+ (L.in_frame call_f (L.call_pred call_e))
+ rel [] [caller ; callee]
+ in
+ let caller_d = L.term env caller_d in
+ let callee_d =
+ (L.in_frame call_f (L.term call_e)) callee_d in
+ rel caller_d callee_d
+ in
+ let outcome =
+ Warning.catch
+ ~severe:true ~effect:"Considering non decreasing call"
+ compile_decreases (caller_d, callee_d)
+ in
+ let warn2, pred = match outcome with
+ | Warning.Failed warn -> warn, p_false
+ | Warning.Result (warn, p) -> warn, p
+ in
+ let warn = W.union warn warn2 in
+ let vcs = prove_decreases ~warn pred wp.vcs in
+ { wp with vcs = vcs })
(* -------------------------------------------------------------------------- *)
@@ -1205,22 +1205,22 @@ struct
let cc_result_domain = function
| Some lv ->
- let dummy = Sigma.create () in
- let tr = Cil.typeOfLval lv in
- let lr = C.lval dummy lv in
- Some (M.domain (Ctypes.object_of tr) lr)
+ let dummy = Sigma.create () in
+ let tr = Cil.typeOfLval lv in
+ let lr = C.lval dummy lv in
+ Some (M.domain (Ctypes.object_of tr) lr)
| None -> Some (M.Heap.Set.empty)
let cc_call_domain env0 kf es = function
| WritesAny -> None
| Writes froms ->
- let dummy = Sigma.create () in
- let vs = List.map (C.exp dummy) es in
- let env = L.move_at env0 dummy in
- let init = L.mem_at env0 Clabels.init in
- let frame = L.call_pre init (L.call kf vs) dummy in
- let cc_froms = L.assigned_of_froms env in
- Some (A.domain (L.in_frame frame cc_froms froms))
+ let dummy = Sigma.create () in
+ let vs = List.map (C.exp dummy) es in
+ let env = L.move_at env0 dummy in
+ let init = L.mem_at env0 Clabels.init in
+ let frame = L.call_pre init (L.call kf vs) dummy in
+ let cc_froms = L.assigned_of_froms env in
+ Some (A.domain (L.in_frame frame cc_froms froms))
let cc_havoc d s = match d with
| None -> { pre = Sigma.havoc_any ~call:true s ; post = s }
@@ -1242,10 +1242,10 @@ struct
let result = match lvr with
| None -> None
| Some lv ->
- let tr = Cil.typeOfLval lv in
- let obj = Ctypes.object_of tr in
- let loc = C.lval sigma_pre lv in
- Some (tr,obj,loc)
+ let tr = Cil.typeOfLval lv in
+ let obj = Ctypes.object_of tr in
+ let loc = C.lval sigma_pre lv in
+ Some (tr,obj,loc)
in
{
sigma_pre = sigma_pre ;
@@ -1266,31 +1266,31 @@ struct
let cc_call_effects stmt cenv env0 assigns wpost wexit =
match assigns with
| WritesAny ->
- {
- vcs_post = do_assigns_everything ~stmt wpost.effects wpost.vcs ;
- vcs_exit = do_assigns_everything ~stmt wexit.effects wexit.vcs ;
- }
+ {
+ vcs_post = do_assigns_everything ~stmt wpost.effects wpost.vcs ;
+ vcs_exit = do_assigns_everything ~stmt wexit.effects wexit.vcs ;
+ }
| Writes froms ->
- let env = L.move_at env0 cenv.sigma_pre in
- let cc_region = L.assigned_of_froms env in
- let vcs_post =
- let assigned = L.in_frame cenv.frame_post cc_region froms in
- do_assigns ~descr:"Call Effects" ~source:FromCall
- ~stmt cenv.seq_post ~assigned wpost.effects wpost.vcs in
- let vcs_exit =
- let assigned = L.in_frame cenv.frame_exit cc_region froms in
- do_assigns ~descr:"Exit Effects" ~source:FromCall
- ~stmt cenv.seq_exit ~assigned wexit.effects wexit.vcs in
- let vcs_result =
- match cenv.loc_result with
- | None -> vcs_post (* no result *)
- | Some(_,obj,loc) ->
- let assigned = [obj,Sloc loc] in
- do_assigns ~descr:"Return Effects"
- ~source:FromReturn ~stmt cenv.seq_result
- ~assigned wpost.effects vcs_post
- in
- { vcs_post = vcs_result ; vcs_exit = vcs_exit }
+ let env = L.move_at env0 cenv.sigma_pre in
+ let cc_region = L.assigned_of_froms env in
+ let vcs_post =
+ let assigned = L.in_frame cenv.frame_post cc_region froms in
+ do_assigns ~descr:"Call Effects" ~source:FromCall
+ ~stmt cenv.seq_post ~assigned wpost.effects wpost.vcs in
+ let vcs_exit =
+ let assigned = L.in_frame cenv.frame_exit cc_region froms in
+ do_assigns ~descr:"Exit Effects" ~source:FromCall
+ ~stmt cenv.seq_exit ~assigned wexit.effects wexit.vcs in
+ let vcs_result =
+ match cenv.loc_result with
+ | None -> vcs_post (* no result *)
+ | Some(_,obj,loc) ->
+ let assigned = [obj,Sloc loc] in
+ do_assigns ~descr:"Return Effects"
+ ~source:FromReturn ~stmt cenv.seq_result
+ ~assigned wpost.effects vcs_post
+ in
+ { vcs_post = vcs_result ; vcs_exit = vcs_exit }
(* --- Compiling Contracts --- *)
@@ -1303,17 +1303,17 @@ struct
let cc_result call = match call.loc_result with
| None -> []
| Some(tr,obj,loc) ->
- let handler () = [ p_true ] in
- let compile () =
- (* [LC,VP] : the C left unspecified where to compute the lv *)
- (* [LC,BY] : lv computed before, like in Value Analysis *)
- let vr = M.load call.seq_result.post obj loc in
- let re = L.in_frame call.frame_post L.result () in
- let te = L.in_frame call.frame_post L.return () in
- let value = C.result call.sigma_pre tr re in
- [ C.equal_typ tr vr (C.cast tr te (Val value)) ]
- in
- Warning.handle ~handler ~severe:false ~effect:"Hide \\result" compile ()
+ let handler () = [ p_true ] in
+ let compile () =
+ (* [LC,VP] : the C left unspecified where to compute the lv *)
+ (* [LC,BY] : lv computed before, like in Value Analysis *)
+ let vr = M.load call.seq_result.post obj loc in
+ let re = L.in_frame call.frame_post L.result () in
+ let te = L.in_frame call.frame_post L.return () in
+ let value = C.result call.sigma_pre tr re in
+ [ C.equal_typ tr vr (C.cast tr te (Val value)) ]
+ in
+ Warning.handle ~handler ~severe:false ~effect:"Hide \\result" compile ()
let cc_status f_caller f_callee =
p_equal
@@ -1371,12 +1371,12 @@ struct
match outcome with
| Warning.Result(warn , wp) -> { wp with vcs = add_warnings warn wp.vcs }
| Warning.Failed warn ->
- let v_post = do_assigns_everything ~stmt ~warn p_post.effects p_post.vcs in
- let v_exit = do_assigns_everything ~stmt ~warn p_exit.effects p_exit.vcs in
- let effects = Eset.union p_post.effects p_exit.effects in
- let vcs = gmerge v_post v_exit in
- let sigma = Sigma.create () in
- { sigma = Some sigma ; vcs = vcs ; effects = effects }
+ let v_post = do_assigns_everything ~stmt ~warn p_post.effects p_post.vcs in
+ let v_exit = do_assigns_everything ~stmt ~warn p_exit.effects p_exit.vcs in
+ let effects = Eset.union p_post.effects p_exit.effects in
+ let vcs = gmerge v_post v_exit in
+ let sigma = Sigma.create () in
+ { sigma = Some sigma ; vcs = vcs ; effects = effects }
) ()
(* -------------------------------------------------------------------------- *)
@@ -1394,17 +1394,17 @@ struct
begin fun env wp ->
match sc with
| Mcfg.SC_Global ->
- let hs = M.frame (L.current env) in
- let vcs = gmap (assume_vc ~descr:"Heap" ~domain:true hs) wp.vcs in
- { wp with vcs }
+ let hs = M.frame (L.current env) in
+ let vcs = gmap (assume_vc ~descr:"Heap" ~domain:true hs) wp.vcs in
+ { wp with vcs }
| Mcfg.SC_Frame_in ->
- wp_scope env wp ~descr:"Frame In" Enter xs
+ wp_scope env wp ~descr:"Frame In" Enter xs
| Mcfg.SC_Frame_out ->
- wp_scope env wp ~descr:"Frame Out" Leave xs
+ wp_scope env wp ~descr:"Frame Out" Leave xs
| Mcfg.SC_Block_in ->
- wp_scope env wp ~descr:"Block In" Enter xs
+ wp_scope env wp ~descr:"Block In" Enter xs
| Mcfg.SC_Block_out ->
- wp_scope env wp ~descr:"Block Out" Leave xs
+ wp_scope env wp ~descr:"Block Out" Leave xs
end
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/ctypes.ml b/src/plugins/wp/ctypes.ml
index cdf647d13bec57f4b12eed8dcf16e004e201d1bf..bf19f468d507631bc9a6fb905a3fa84ad9908f35 100644
--- a/src/plugins/wp/ctypes.ml
+++ b/src/plugins/wp/ctypes.ml
@@ -238,20 +238,20 @@ let char c = Integer.to_int64_exn (Cil.charConstToInt c)
let constant e =
match (Cil.constFold true e).enode with
| Const(CInt64(k,_,_)) ->
- begin
- try Integer.to_int64_exn k
- with Z.Overflow ->
- Warning.error "Array size too large (%a)" Integer.pretty_hex k
- end
+ begin
+ try Integer.to_int64_exn k
+ with Z.Overflow ->
+ Warning.error "Array size too large (%a)" Integer.pretty_hex k
+ end
| _ -> Warning.error "Non-constant expression (%a)" Printer.pp_exp e
let array_size = function
| None -> None
| Some e ->
- match constant e with
- | 0L when Cil.gccMode () || Cil.msvcMode () -> None
- | 0L -> Warning.error "0 sized array %s" (Cil.allowed_machdep "GCC/MSVC")
- | n -> Some n
+ match constant e with
+ | 0L when Cil.gccMode () || Cil.msvcMode () -> None
+ | 0L -> Warning.error "0 sized array %s" (Cil.allowed_machdep "GCC/MSVC")
+ | n -> Some n
let get_int e =
match (Cil.constFold true e).enode with
@@ -267,7 +267,7 @@ let dimension t =
let rec flat k d = function
| TNamed (r,_) -> flat k d r.ttype
| TArray(ty,Some e,_) ->
- flat (succ k) (Int64.mul d (constant e)) ty
+ flat (succ k) (Int64.mul d (constant e)) ty
| te -> k , d , te
in flat 1 Int64.one t
@@ -288,31 +288,31 @@ let rec object_of typ =
| TEnum ({ekind=i},_) -> C_int (c_int i)
| TComp (comp,_) -> C_comp comp
| TArray (typ_elt,e_opt,_) ->
- begin
- match array_size e_opt with
- | None ->
- C_array {
- arr_element = typ_elt;
- arr_flat = None;
+ begin
+ match array_size e_opt with
+ | None ->
+ C_array {
+ arr_element = typ_elt;
+ arr_flat = None;
+ }
+ | Some e ->
+ let dim,ncells,ty_cell = dimension typ in
+ C_array {
+ arr_element = typ_elt ;
+ arr_flat = Some {
+ arr_size = Int64.to_int e ;
+ arr_dim = dim ;
+ arr_cell = ty_cell ;
+ arr_cell_nbr = ncells ;
}
- | Some e ->
- let dim,ncells,ty_cell = dimension typ in
- C_array {
- arr_element = typ_elt ;
- arr_flat = Some {
- arr_size = Int64.to_int e ;
- arr_dim = dim ;
- arr_cell = ty_cell ;
- arr_cell_nbr = ncells ;
- }
- }
- end
+ }
+ end
| TBuiltin_va_list _ ->
- WpLog.warning ~current:true ~once:true "variadyc type (considered as void*)" ;
- C_pointer (TVoid [])
+ WpLog.warning ~current:true ~once:true "variadyc type (considered as void*)" ;
+ C_pointer (TVoid [])
| TVoid _ ->
- WpLog.warning ~current:true "void object" ;
- C_int (c_int IInt)
+ WpLog.warning ~current:true "void object" ;
+ C_int (c_int IInt)
| TNamed (r,_) -> object_of r.ttype
(* ------------------------------------------------------------------------ *)
@@ -390,8 +390,8 @@ let () =
let object_of_pointed = function
C_int _ | C_float _ | C_comp _ as o ->
- Wp_parameters.fatal
- "object_of_pointed called on non-pointer %a@." pp_object o
+ Wp_parameters.fatal
+ "object_of_pointed called on non-pointer %a@." pp_object o
| C_array info -> object_of info.arr_element
| C_pointer typ -> object_of typ
@@ -447,7 +447,7 @@ let is_array obj ~elt = match obj with
let array_size = function
| { arr_flat = Some { arr_size=s } } -> Some s
| { arr_flat = None } ->
- if Wp_parameters.ExternArrays.get () then Some max_int else None
+ if Wp_parameters.ExternArrays.get () then Some max_int else None
let get_array_size = function
| C_array a -> array_size a
@@ -477,15 +477,15 @@ let bits_sizeof_comp cinfo = Cil.bitsSizeOf (typ_comp cinfo)
let bits_sizeof_array ainfo =
match ainfo.arr_flat with
| Some a ->
- let csize = Cil.kinteger64
- ~loc:Cil_builtins.builtinLoc (Z.of_int64 a.arr_cell_nbr) in
- let ctype = TArray(a.arr_cell,Some csize,[]) in
- Cil.bitsSizeOf ctype
+ let csize = Cil.kinteger64
+ ~loc:Cil_builtins.builtinLoc (Z.of_int64 a.arr_cell_nbr) in
+ let ctype = TArray(a.arr_cell,Some csize,[]) in
+ Cil.bitsSizeOf ctype
| None ->
- if WpLog.ExternArrays.get () then
- max_int
- else
- WpLog.fatal ~current:true "Sizeof unknown-size array"
+ if WpLog.ExternArrays.get () then
+ max_int
+ else
+ WpLog.fatal ~current:true "Sizeof unknown-size array"
let sizeof_object = function
@@ -542,10 +542,10 @@ let rec basename = function
| C_pointer _ -> "pointer"
| C_comp c -> c.cname
| C_array a ->
- let te = basename (object_of a.arr_element) in
- match a.arr_flat with
- | None -> te ^ "_array"
- | Some f -> te ^ "_" ^ string_of_int f.arr_size
+ let te = basename (object_of a.arr_element) in
+ match a.arr_flat with
+ | None -> te ^ "_array"
+ | Some f -> te ^ "_" ^ string_of_int f.arr_size
let is_atomic = function
| TVoid _ | TInt _ | TFloat _ | TNamed _ -> true
@@ -556,15 +556,15 @@ let rec pretty fmt = function
| C_float f -> pp_float fmt f
| C_comp c -> Format.pp_print_string fmt c.cname
| C_pointer ty ->
- if is_atomic ty then
- Format.fprintf fmt "%a*" Printer.pp_typ ty
- else
- Format.fprintf fmt "(%a)*" Printer.pp_typ ty
+ if is_atomic ty then
+ Format.fprintf fmt "%a*" Printer.pp_typ ty
+ else
+ Format.fprintf fmt "(%a)*" Printer.pp_typ ty
| C_array a ->
- let te = object_of a.arr_element in
- match a.arr_flat with
- | None -> Format.fprintf fmt "%a[]" pretty te
- | Some f -> Format.fprintf fmt "%a[%d]" pretty te f.arr_size
+ let te = object_of a.arr_element in
+ match a.arr_flat with
+ | None -> Format.fprintf fmt "%a[]" pretty te
+ | Some f -> Format.fprintf fmt "%a[%d]" pretty te f.arr_size
module C_object = Datatype.Make(struct
type t = c_object
diff --git a/src/plugins/wp/dyncall.ml b/src/plugins/wp/dyncall.ml
index 9916a6db66860336c96696337081e83a1ebc4838..6dde0c27353111c3b6df17af5827a2a4e7fd6a7d 100644
--- a/src/plugins/wp/dyncall.ml
+++ b/src/plugins/wp/dyncall.ml
@@ -45,10 +45,10 @@ let typecheck typing_context loc ps =
let loc = p.lexpr_loc in
match p.lexpr_node with
| PLvar f ->
- let fv = find_call typing_context loc f in
- Logic_const.term ~loc (TLval(TVar fv,TNoOffset)) fv.lv_type
+ let fv = find_call typing_context loc f in
+ Logic_const.term ~loc (TLval(TVar fv,TNoOffset)) fv.lv_type
| _ ->
- typing_context.error loc "Function name expected for calls"
+ typing_context.error loc "Function name expected for calls"
) ps
in
Ext_terms fs
@@ -68,7 +68,7 @@ let get_calls ecmd bhvs : (string * Kernel_function.t list) list =
List.iter
(function
| {ext_name; ext_kind = Ext_terms ts} when ext_name = ecmd ->
- fs := !fs @ List.map get_call ts
+ fs := !fs @ List.map get_call ts
| _ -> ())
bhv.Cil_types.b_extended ;
let fs = !fs in
@@ -140,47 +140,47 @@ class dyncall =
| Cil_types.AExtended
(bhvs, _,
({ext_name = "calls"; ext_kind = Ext_terms calls} as extended)) ->
- if calls <> [] && (scope <> [] || not (Stack.is_empty block_calls))
- then begin
- let bhvs =
- match bhvs with
- | [] -> [ Cil.default_behavior_name ]
- | bhvs -> bhvs
- in
- let debug_calls bhv stmt kfs =
- if Wp_parameters.has_dkey dkey_calls then
- let source = snd (Stmt.loc stmt) in
- if Cil.default_behavior_name = bhv then
- Wp_parameters.result ~source
- "@[<hov 2>Calls%a@]" pp_calls kfs
- else
- Wp_parameters.result ~source
- "@[<hov 2>Calls (for %s)%a@]" bhv pp_calls kfs
- in
- let pool = ref [] in (* collect emitted properties *)
- let add_calls_info kf stmt =
- count <- succ count ;
- List.iter
- (fun bhv ->
- let kfs = List.map get_call calls in
- debug_calls bhv stmt kfs ;
- let prop = property ~kf ~bhv ~stmt kfs in
- pool := prop :: !pool ;
- CallPoints.add (bhv,stmt) (prop,kfs))
- bhvs
- in
- let kf = self#kf in
+ if calls <> [] && (scope <> [] || not (Stack.is_empty block_calls))
+ then begin
+ let bhvs =
+ match bhvs with
+ | [] -> [ Cil.default_behavior_name ]
+ | bhvs -> bhvs
+ in
+ let debug_calls bhv stmt kfs =
+ if Wp_parameters.has_dkey dkey_calls then
+ let source = snd (Stmt.loc stmt) in
+ if Cil.default_behavior_name = bhv then
+ Wp_parameters.result ~source
+ "@[<hov 2>Calls%a@]" pp_calls kfs
+ else
+ Wp_parameters.result ~source
+ "@[<hov 2>Calls (for %s)%a@]" bhv pp_calls kfs
+ in
+ let pool = ref [] in (* collect emitted properties *)
+ let add_calls_info kf stmt =
+ count <- succ count ;
List.iter
- (add_calls_info kf)
- (if scope <> [] then scope else Stack.top block_calls) ;
- if !pool <> [] then
- begin
- let eloc = Property.ELStmt(kf,self#stmt) in
- let annot = Property.ip_of_extended eloc extended in
- Property_status.logical_consequence emitter annot !pool ;
- end
- end;
- SkipChildren
+ (fun bhv ->
+ let kfs = List.map get_call calls in
+ debug_calls bhv stmt kfs ;
+ let prop = property ~kf ~bhv ~stmt kfs in
+ pool := prop :: !pool ;
+ CallPoints.add (bhv,stmt) (prop,kfs))
+ bhvs
+ in
+ let kf = self#kf in
+ List.iter
+ (add_calls_info kf)
+ (if scope <> [] then scope else Stack.top block_calls) ;
+ if !pool <> [] then
+ begin
+ let eloc = Property.ELStmt(kf,self#stmt) in
+ let annot = Property.ip_of_extended eloc extended in
+ Property_status.logical_consequence emitter annot !pool ;
+ end
+ end;
+ SkipChildren
| _ -> SkipChildren
method! vspec spec =
@@ -201,18 +201,18 @@ class dyncall =
match s.skind with
| Instr (Call( _ , fct , _ , _ ))
when Kernel_function.get_called fct = None ->
- if not (Stack.is_empty block_calls) then
- Stack.push (self#stmt :: Stack.pop block_calls) block_calls;
- scope <- self#stmt :: scope ;
- Cil.DoChildrenPost (fun s -> scope <- []; s)
+ if not (Stack.is_empty block_calls) then
+ Stack.push (self#stmt :: Stack.pop block_calls) block_calls;
+ scope <- self#stmt :: scope ;
+ Cil.DoChildrenPost (fun s -> scope <- []; s)
| Block _ ->
- Stack.push [] block_calls;
- Cil.DoChildrenPost
- (fun s ->
- let calls = Stack.pop block_calls in
- if not (Stack.is_empty block_calls) then
- Stack.push (calls @ Stack.pop block_calls) block_calls;
- s)
+ Stack.push [] block_calls;
+ Cil.DoChildrenPost
+ (fun s ->
+ let calls = Stack.pop block_calls in
+ if not (Stack.is_empty block_calls) then
+ Stack.push (calls @ Stack.pop block_calls) block_calls;
+ s)
| _ -> Cil.DoChildren
end
@@ -247,9 +247,9 @@ let get ?bhv stmt =
match bhv with
| None -> get Cil.default_behavior_name
| Some bhv ->
- (match get bhv with
- | None -> get Cil.default_behavior_name
- | result -> result)
+ (match get bhv with
+ | None -> get Cil.default_behavior_name
+ | result -> result)
(* -------------------------------------------------------------------------- *)
(* --- Registry --- *)
diff --git a/src/plugins/wp/filter_axioms.ml b/src/plugins/wp/filter_axioms.ml
index ebb9ebb4d0995d3bcf759b079299b2227b7d5b5d..4d18258195f9ba4c3043d76fbb671fb508743b15 100644
--- a/src/plugins/wp/filter_axioms.ml
+++ b/src/plugins/wp/filter_axioms.ml
@@ -42,14 +42,14 @@ let meta_remove_ =
let elim_abstract remove_pr d = match d.d_node with
| Dprop (Paxiom,pr,_) when Spr.mem pr remove_pr ->
- (* Format.eprintf "Remove %a@." Pretty.print_pr pr; *)
- []
+ (* Format.eprintf "Remove %a@." Pretty.print_pr pr; *)
+ []
| Dprop (Paxiom,_,_) ->
- (* Format.eprintf "Not Remove %a@." Pretty.print_pr pr; *)
- [d]
+ (* Format.eprintf "Not Remove %a@." Pretty.print_pr pr; *)
+ [d]
| _ ->
- (* Format.eprintf "Not Seen %a@." Pretty.print_decl d; *)
- [d]
+ (* Format.eprintf "Not Seen %a@." Pretty.print_decl d; *)
+ [d]
let remove_prop meta =
Trans.on_tagged_pr meta
@@ -85,12 +85,12 @@ let meta_inline_in =
let t_unfold defs fs tl ty =
match Mls.find_opt fs defs with
| None ->
- assert false (** absurd: it is in mpr so it is in sls so added in defs *)
+ assert false (** absurd: it is in mpr so it is in sls so added in defs *)
| Some (vl,e) ->
- let add (mt,mv) x y = Ty.ty_match mt x.vs_ty (t_type y), Mvs.add x y mv in
- let (mt,mv) = List.fold_left2 add (Ty.Mtv.empty, Mvs.empty) vl tl in
- let mt = Ty.oty_match mt e.t_ty ty in
- t_ty_subst mt mv e
+ let add (mt,mv) x y = Ty.ty_match mt x.vs_ty (t_type y), Mvs.add x y mv in
+ let (mt,mv) = List.fold_left2 add (Ty.Mtv.empty, Mvs.empty) vl tl in
+ let mt = Ty.oty_match mt e.t_ty ty in
+ t_ty_subst mt mv e
(* inline every symbol *)
@@ -98,39 +98,39 @@ let rec t_replace_all defs s t =
let t = t_map (t_replace_all defs s) t in
match t.t_node with
| Tapp (fs,tl) when Sls.mem fs s ->
- t_attr_copy t (t_unfold defs fs tl t.t_ty)
+ t_attr_copy t (t_unfold defs fs tl t.t_ty)
| _ -> t
let fold mpr sls d (defs, task) =
(** replace *)
let d = match d.d_node with
| Dprop (k,pr,f) ->
- let s = Mpr.find_def Sls.empty pr mpr in
- if Sls.is_empty s then d
- else create_prop_decl k pr (t_replace_all defs s f)
+ let s = Mpr.find_def Sls.empty pr mpr in
+ if Sls.is_empty s then d
+ else create_prop_decl k pr (t_replace_all defs s f)
| _ -> d
in
(** add to defs if needed *)
match d.d_node with
| Dlogic [ls,ld] when Sls.mem ls sls ->
- let vl,e = open_ls_defn ld in
- Mls.add ls (vl,e) defs, Task.add_decl task d
+ let vl,e = open_ls_defn ld in
+ Mls.add ls (vl,e) defs, Task.add_decl task d
| _ ->
- defs, Task.add_decl task d
+ defs, Task.add_decl task d
let fold mpr sls task_hd (defs, task) =
match task_hd.Task.task_decl.Theory.td_node with
| Theory.Decl d ->
- fold mpr sls d (defs, task)
+ fold mpr sls d (defs, task)
| _ ->
- defs, Task.add_tdecl task task_hd.Task.task_decl
+ defs, Task.add_tdecl task task_hd.Task.task_decl
let trans =
let add (mpr,sls) = function
| [Theory.MAls ls; Theory.MApr pr] ->
- Mpr.change (function None -> Some (Sls.singleton ls)
- | Some s -> Some (Sls.add ls s)) pr mpr,
- Sls.add ls sls
+ Mpr.change (function None -> Some (Sls.singleton ls)
+ | Some s -> Some (Sls.add ls s)) pr mpr,
+ Sls.add ls sls
| _ -> assert false
in
Trans.on_meta meta_inline_in (fun l ->
diff --git a/src/plugins/wp/normAtLabels.ml b/src/plugins/wp/normAtLabels.ml
index f72ca1ee71a532afb23ce34bb39d34deae742d5b..785e05a7ed94cf211a6667cb53792af9494762bd 100644
--- a/src/plugins/wp/normAtLabels.ml
+++ b/src/plugins/wp/normAtLabels.ml
@@ -60,47 +60,47 @@ class norm_at (mapping : label_mapping) =
method! vterm t =
match t.term_node with
| Tat (t, l) ->
- let old_label = self#change_label l in
- let new_t = {t with term_node = Ttypeof t} in
- Cil.ChangeDoChildrenPost (new_t, self#restore_term old_label)
+ let old_label = self#change_label l in
+ let new_t = {t with term_node = Ttypeof t} in
+ Cil.ChangeDoChildrenPost (new_t, self#restore_term old_label)
| TAddrOf (h, _) | TLval (h, _) | TStartOf (h, _) ->
- let old_label = current_label in
- let at_label = match h with
- | TResult _ | TVar{lv_name="\\exit_status"} -> Some Clabels.post
- | _ -> old_label
- in
- current_label <- None;
- let post t =
- current_label <- old_label;
- match at_label with
- | Some label -> {t with term_node = Tat (t, Clabels.to_logic label)}
- | None -> t
- in Cil.ChangeDoChildrenPost (t, post)
+ let old_label = current_label in
+ let at_label = match h with
+ | TResult _ | TVar{lv_name="\\exit_status"} -> Some Clabels.post
+ | _ -> old_label
+ in
+ current_label <- None;
+ let post t =
+ current_label <- old_label;
+ match at_label with
+ | Some label -> {t with term_node = Tat (t, Clabels.to_logic label)}
+ | None -> t
+ in Cil.ChangeDoChildrenPost (t, post)
| Tapp _ ->
- let post = function
- | {term_node=Tapp(predicate,labels,args)} as t ->
- let normalize l = mapping l |> Clabels.to_logic in
- let new_labels = List.map normalize labels in
- { t with term_node=Tapp(predicate,new_labels,args) }
- | _ -> assert false
- in
- Cil.ChangeDoChildrenPost (t,post)
+ let post = function
+ | {term_node=Tapp(predicate,labels,args)} as t ->
+ let normalize l = mapping l |> Clabels.to_logic in
+ let new_labels = List.map normalize labels in
+ { t with term_node=Tapp(predicate,new_labels,args) }
+ | _ -> assert false
+ in
+ Cil.ChangeDoChildrenPost (t,post)
| _ -> Cil.DoChildren
method! vpredicate p = match p.pred_content with
| Pat (p, l) ->
- let old_label = self#change_label l in
- let new_p = {p with pred_content = Pnot p} in
- Cil.ChangeDoChildrenPost (new_p, self#restore_pred old_label)
+ let old_label = self#change_label l in
+ let new_p = {p with pred_content = Pnot p} in
+ Cil.ChangeDoChildrenPost (new_p, self#restore_pred old_label)
| Papp _ ->
- let post = function
- | {pred_content=Papp(predicate,labels,args)} as p ->
- let normalize l = mapping l |> Clabels.to_logic in
- let new_labels = List.map normalize labels in
- { p with pred_content=Papp(predicate,new_labels,args) }
- | _ -> assert false
- in
- Cil.ChangeDoChildrenPost (p,post)
+ let post = function
+ | {pred_content=Papp(predicate,labels,args)} as p ->
+ let normalize l = mapping l |> Clabels.to_logic in
+ let new_labels = List.map normalize labels in
+ { p with pred_content=Papp(predicate,new_labels,args) }
+ | _ -> assert false
+ in
+ Cil.ChangeDoChildrenPost (p,post)
| _ -> Cil.DoChildren
end
@@ -223,24 +223,24 @@ let preproc_assigns labels asgns =
let has_postassigns = function
| WritesAny -> false
| Writes froms ->
- let exception HAS_POST in
- let visitor = new norm_at (fun l ->
- if Clabels.is_post l then raise HAS_POST
- else Clabels.of_logic l
- ) in
- try
- List.iter
- (fun fr -> ignore @@ Visitor.visitFramacFrom visitor fr)
- froms ;
- false
- with HAS_POST ->
- true
+ let exception HAS_POST in
+ let visitor = new norm_at (fun l ->
+ if Clabels.is_post l then raise HAS_POST
+ else Clabels.of_logic l
+ ) in
+ try
+ List.iter
+ (fun fr -> ignore @@ Visitor.visitFramacFrom visitor fr)
+ froms ;
+ false
+ with HAS_POST ->
+ true
let catch_label_error ex txt1 txt2 = match ex with
| LabelError lab ->
- Wp_parameters.warning
- "Unexpected label %a in %s : ignored %s"
- Wp_error.pp_logic_label lab txt1 txt2
+ Wp_parameters.warning
+ "Unexpected label %a in %s : ignored %s"
+ Wp_error.pp_logic_label lab txt1 txt2
| _ -> raise ex
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/prover.ml b/src/plugins/wp/prover.ml
index 4483cf24c32f0571871134cd696ecbded8eb93cb..4292b56a6dc04ecc61ba9d78705544dbde206cd1 100644
--- a/src/plugins/wp/prover.ml
+++ b/src/plugins/wp/prover.ml
@@ -34,11 +34,11 @@ let dispatch ?(config=VCS.default) mode prover wpo =
match prover with
| Qed | Tactical -> Task.return VCS.no_result
| Why3 prover ->
- let smoke = Wpo.is_smoke_test wpo in
- ProverWhy3.prove
- ~timeout:(VCS.get_timeout ~smoke config)
- ~steplimit:(VCS.get_stepout config)
- ~mode ~prover wpo
+ let smoke = Wpo.is_smoke_test wpo in
+ ProverWhy3.prove
+ ~timeout:(VCS.get_timeout ~smoke config)
+ ~steplimit:(VCS.get_stepout config)
+ ~mode ~prover wpo
end
let started ?start wpo =
@@ -98,15 +98,15 @@ let spawn wpo ~delayed
let monitor = match success with
| None -> None
| Some on_success ->
- Some
- begin function
- | None -> on_success wpo None
- | Some prover ->
- let r = Wpo.get_result wpo VCS.Qed in
- let prover =
- if VCS.( r.verdict == Valid ) then VCS.Qed else prover in
- on_success wpo (Some prover)
- end in
+ Some
+ begin function
+ | None -> on_success wpo None
+ | Some prover ->
+ let r = Wpo.get_result wpo VCS.Qed in
+ let prover =
+ if VCS.( r.verdict == Valid ) then VCS.Qed else prover in
+ on_success wpo (Some prover)
+ end in
let process (mode,prover) =
prove wpo ?config ~mode ?start ?progress ?result prover in
let all = Wp_parameters.RunAllProvers.get() in
@@ -124,7 +124,7 @@ let spawn wpo ~delayed
match success with
| None -> ()
| Some on_success ->
- on_success wpo (if ok then Some VCS.Qed else None) ;
+ on_success wpo (if ok then Some VCS.Qed else None) ;
end ;
Task.return ()
in
diff --git a/src/plugins/wp/register.ml b/src/plugins/wp/register.ml
index a141dbb8301552cde45306ca2832a0b675654a17..926dd65369dd9befbc868c99c82b8cc8bacdb8ff 100644
--- a/src/plugins/wp/register.ml
+++ b/src/plugins/wp/register.ml
@@ -88,11 +88,11 @@ let do_wp_report model =
match String.split_on_char ':' jreport with
| [] | [""] -> ()
| [joutput] ->
- WpReport.export_json stats ~joutput () ;
+ WpReport.export_json stats ~joutput () ;
| [jinput;joutput] ->
- WpReport.export_json stats ~jinput ~joutput () ;
+ WpReport.export_json stats ~jinput ~joutput () ;
| _ ->
- Wp_parameters.error "Invalid format for option -wp-report-json"
+ Wp_parameters.error "Invalid format for option -wp-report-json"
end ;
List.iter (WpReport.export stats) reports ;
end ;
@@ -245,21 +245,21 @@ let do_report_cache_usage mode =
match mode with
| Cache.NoCache -> ()
| Cache.Replay ->
- pp_cache fmt hits "found" ;
- pp_cache fmt miss "missed" ;
- Format.pp_print_newline fmt () ;
+ pp_cache fmt hits "found" ;
+ pp_cache fmt miss "missed" ;
+ Format.pp_print_newline fmt () ;
| Cache.Offline ->
- pp_cache fmt hits "found" ;
- pp_cache fmt miss "failed" ;
- Format.pp_print_newline fmt () ;
+ pp_cache fmt hits "found" ;
+ pp_cache fmt miss "failed" ;
+ Format.pp_print_newline fmt () ;
| Cache.Update | Cache.Cleanup ->
- pp_cache fmt hits "found" ;
- pp_cache fmt miss "updated" ;
- Format.pp_print_newline fmt () ;
+ pp_cache fmt hits "found" ;
+ pp_cache fmt miss "updated" ;
+ Format.pp_print_newline fmt () ;
| Cache.Rebuild ->
- pp_cache fmt hits "replaced" ;
- pp_cache fmt miss "updated" ;
- Format.pp_print_newline fmt () ;
+ pp_cache fmt hits "replaced" ;
+ pp_cache fmt miss "updated" ;
+ Format.pp_print_newline fmt () ;
end
(* -------------------------------------------------------------------------- *)
@@ -274,17 +274,17 @@ let do_wpo_stat goal prover res =
let verdict = VCS.verdict ~smoke res in
match verdict with
| NoResult | Computing _ | Unknown ->
- s.unknown <- succ s.unknown
+ s.unknown <- succ s.unknown
| Stepout | Timeout ->
- s.interrupted <- succ s.interrupted
+ s.interrupted <- succ s.interrupted
| Failed | Invalid ->
- s.failed <- succ s.failed
+ s.failed <- succ s.failed
| Valid ->
- s.proved <- succ s.proved ;
- add_step s res.prover_steps ;
- add_time s res.prover_time ;
- if prover <> Qed then
- add_time (get_pstat Qed) res.solver_time
+ s.proved <- succ s.proved ;
+ add_step s res.prover_steps ;
+ add_time s res.prover_time ;
+ if prover <> Qed then
+ add_time (get_pstat Qed) res.solver_time
let do_wpo_result goal prover res =
if VCS.is_verdict res then
@@ -302,20 +302,20 @@ let do_wpo_failed goal =
let updating = Cache.is_updating () in
match results goal with
| [p,r] ->
- Wp_parameters.result "[%a] Goal %s : %t%a"
- VCS.pp_prover p (Wpo.get_gid goal)
- (VCS.pp_result_qualif ~updating p r) pp_warnings goal
+ Wp_parameters.result "[%a] Goal %s : %t%a"
+ VCS.pp_prover p (Wpo.get_gid goal)
+ (VCS.pp_result_qualif ~updating p r) pp_warnings goal
| pres ->
- Wp_parameters.result "[Failed] Goal %s%t" (Wpo.get_gid goal)
- begin fun fmt ->
- pp_warnings fmt goal ;
- List.iter
- (fun (p,r) ->
- Format.fprintf fmt "@\n%8s: @[<hv>%t@]"
- (VCS.title_of_prover p)
- (VCS.pp_result_qualif ~updating p r)
- ) pres ;
- end
+ Wp_parameters.result "[Failed] Goal %s%t" (Wpo.get_gid goal)
+ begin fun fmt ->
+ pp_warnings fmt goal ;
+ List.iter
+ (fun (p,r) ->
+ Format.fprintf fmt "@\n%8s: @[<hv>%t@]"
+ (VCS.title_of_prover p)
+ (VCS.pp_result_qualif ~updating p r)
+ ) pres ;
+ end
let do_wpo_smoke status goal =
Wp_parameters.result "[%s] Smoke-test %s%t"
@@ -340,35 +340,35 @@ let do_wpo_success goal s =
match s with
| None -> ()
| Some prover ->
- Wp_parameters.feedback ~ontty:`Silent
- "[%a] Goal %s : Valid" VCS.pp_prover prover (Wpo.get_gid goal)
+ Wp_parameters.feedback ~ontty:`Silent
+ "[%a] Goal %s : Valid" VCS.pp_prover prover (Wpo.get_gid goal)
else
if Wpo.is_smoke_test goal then
begin match s with
| None ->
- Wp_parameters.feedback ~ontty:`Silent
- "[Passed] Smoke-test %s" (Wpo.get_gid goal)
+ Wp_parameters.feedback ~ontty:`Silent
+ "[Passed] Smoke-test %s" (Wpo.get_gid goal)
| Some _ ->
- let status,target = Wpo.get_proof goal in
- do_wpo_smoke status goal ;
- if status = `Failed then
- let source = fst (Property.location target) in
- Wp_parameters.warning ~source "Failed smoke-test"
+ let status,target = Wpo.get_proof goal in
+ do_wpo_smoke status goal ;
+ if status = `Failed then
+ let source = fst (Property.location target) in
+ Wp_parameters.warning ~source "Failed smoke-test"
end
else
begin match s with
| None -> do_wpo_failed goal
| Some (VCS.Tactical as script) ->
- Wp_parameters.feedback ~ontty:`Silent
- "[%a] Goal %s : Valid"
- VCS.pp_prover script (Wpo.get_gid goal)
+ Wp_parameters.feedback ~ontty:`Silent
+ "[%a] Goal %s : Valid"
+ VCS.pp_prover script (Wpo.get_gid goal)
| Some prover ->
- let result = Wpo.get_result goal prover in
- let updating = Cache.is_updating () in
- Wp_parameters.feedback ~ontty:`Silent
- "[%a] Goal %s : %t"
- VCS.pp_prover prover (Wpo.get_gid goal)
- (VCS.pp_result_qualif ~updating prover result)
+ let result = Wpo.get_result goal prover in
+ let updating = Cache.is_updating () in
+ Wp_parameters.feedback ~ontty:`Silent
+ "[%a] Goal %s : %t"
+ VCS.pp_prover prover (Wpo.get_gid goal)
+ (VCS.pp_result_qualif ~updating prover result)
end
let do_report_time fmt s =
@@ -534,13 +534,13 @@ let compute_provers ~mode ~script =
match VCS.parse_prover pname with
| None -> prvs
| Some VCS.Tactical ->
- script.tactical <- true ;
- if pname = "tip" || env_script_update () then
- script.update <- true ;
- prvs
+ script.tactical <- true ;
+ if pname = "tip" || env_script_update () then
+ script.update <- true ;
+ prvs
| Some prover ->
- let pmode = if VCS.is_auto prover then VCS.Batch else mode in
- (pmode , prover) :: prvs
+ let pmode = if VCS.is_auto prover then VCS.Batch else mode in
+ (pmode , prover) :: prvs
end (get_prover_names ()) []
let dump_strategies =
@@ -804,7 +804,7 @@ let do_prover_detect () =
let rec try_sequence jobs () = match jobs with
| [] -> ()
| head :: tail ->
- Extlib.try_finally ~finally:(try_sequence tail) head ()
+ Extlib.try_finally ~finally:(try_sequence tail) head ()
let sequence jobs () =
if Wp_parameters.has_dkey dkey_raised
diff --git a/src/plugins/wp/share/install.ml b/src/plugins/wp/share/install.ml
index a3e637acfd382a980c58f5fadfed443439d7ad2e..6add0ae00a7c9eff7d1a9809fac61332525a30a1 100644
--- a/src/plugins/wp/share/install.ml
+++ b/src/plugins/wp/share/install.ml
@@ -121,16 +121,16 @@ let do_install file =
Format.printf "[install] File %S not found@." src
with
| Failure msg | Sys_error msg ->
- Format.printf "[install] %s@." msg ;
- exit 1
+ Format.printf "[install] %s@." msg ;
+ exit 1
| Unix.Unix_error (e,_,_) ->
- let msg = Unix.error_message e in
- Format.printf "[install] Error: %s@." msg ;
- exit 2
+ let msg = Unix.error_message e in
+ Format.printf "[install] Error: %s@." msg ;
+ exit 2
| e ->
- let msg = Printexc.to_string e in
- Format.printf "[install] Error: %s@." msg ;
- exit 2
+ let msg = Printexc.to_string e in
+ Format.printf "[install] Error: %s@." msg ;
+ exit 2
let () =
Arg.parse [
diff --git a/src/plugins/wp/wpPropId.ml b/src/plugins/wp/wpPropId.ml
index e9347956373a913c73e20a456495b8b6b4c06209..262edfc47daf27db26d6868e2c4e51398c7b7b7f 100644
--- a/src/plugins/wp/wpPropId.ml
+++ b/src/plugins/wp/wpPropId.ml
@@ -89,16 +89,16 @@ let num_of_bhv_from bhv (out, _) =
match bhv.b_assigns with
WritesAny -> Wp_parameters.fatal "no \\from in this behavior ???"
| Writes l ->
- let add n (o, f) = match f with FromAny -> n
- | From _ ->
- if Logic_utils.is_same_identified_term out o then
- raise (Found n)
- else n+1
- in
- try
- let _ = List.fold_left add 1 l in
- Wp_parameters.fatal "didn't found this \\from"
- with Found n -> n
+ let add n (o, f) = match f with FromAny -> n
+ | From _ ->
+ if Logic_utils.is_same_identified_term out o then
+ raise (Found n)
+ else n+1
+ in
+ try
+ let _ = List.fold_left add 1 l in
+ Wp_parameters.fatal "didn't found this \\from"
+ with Found n -> n
(*----------------------------------------------------------------------------*)
(* Constructors *)
@@ -138,7 +138,7 @@ let mk_bhv_from_id kf ki a bhv from =
let get_kind_for_tk tkind has_exit = match tkind with
| Normal ->
- if has_exit then PKAFctOut else PKProp
+ if has_exit then PKAFctOut else PKProp
| Exits -> PKAFctExit
| _ -> assert false
@@ -226,13 +226,13 @@ let kind_order = function
let compare_kind k1 k2 = match k1, k2 with
PKPre (kf1, ki1, p1), PKPre (kf2, ki2, p2) ->
- let cmp = Kernel_function.compare kf1 kf2 in
+ let cmp = Kernel_function.compare kf1 kf2 in
+ if cmp <> 0 then cmp
+ else
+ let cmp = Stmt.compare ki1 ki2 in
if cmp <> 0 then cmp
else
- let cmp = Stmt.compare ki1 ki2 in
- if cmp <> 0 then cmp
- else
- Property.compare p1 p2
+ Property.compare p1 p2
| _,_ -> Stdlib.compare (kind_order k1) (kind_order k2)
let compare_prop_id pid1 pid2 =
@@ -370,21 +370,21 @@ struct
| PKAFctOut , p -> get_ip p ^ "_normal"
| PKAFctExit , p -> get_ip p ^ "_exit"
| PKPre(callee_kf,stmt,pre) , _ ->
- let caller_kf = Kernel_function.find_englobing_kf stmt in
- let call_string =
- Uniquify_Stmt.unique_basename (caller_kf,callee_kf,stmt)
- in
- (** remove name of callee kernel function given by get_ip *)
- let ip_string = get_ip pre in
- let ip_string =
- Option.value ~default:ip_string
- (Extlib.string_del_prefix
- ((Kernel_function.get_name callee_kf)^"_")
- ip_string)
- in
- call_string^"_"^ip_string
+ let caller_kf = Kernel_function.find_englobing_kf stmt in
+ let call_string =
+ Uniquify_Stmt.unique_basename (caller_kf,callee_kf,stmt)
+ in
+ (** remove name of callee kernel function given by get_ip *)
+ let ip_string = get_ip pre in
+ let ip_string =
+ Option.value ~default:ip_string
+ (Extlib.string_del_prefix
+ ((Kernel_function.get_name callee_kf)^"_")
+ ip_string)
+ in
+ call_string^"_"^ip_string
| _ , p ->
- get_ip p
+ get_ip p
let get_prop_id_basename p =
@@ -392,10 +392,10 @@ struct
match p.p_part with
| None -> basename
| Some(k,n) ->
- if n < 10 then Printf.sprintf "%s_part%d" basename (succ k) else
- if n < 100 then Printf.sprintf "%s_part%02d" basename (succ k) else
- if n < 1000 then Printf.sprintf "%s_part%03d" basename (succ k) else
- Printf.sprintf "%s_part%06d" basename (succ k)
+ if n < 10 then Printf.sprintf "%s_part%d" basename (succ k) else
+ if n < 100 then Printf.sprintf "%s_part%02d" basename (succ k) else
+ if n < 1000 then Printf.sprintf "%s_part%03d" basename (succ k) else
+ Printf.sprintf "%s_part%06d" basename (succ k)
module Uniquify2 = NameUniquify(PropIdRaw)(struct
let name = "Wp.WpPropId.Names2."
@@ -443,31 +443,31 @@ let code_annot_names ca = match ca.annot_content with
let user_prop_names p =
let open Property in match p with
| IPPredicate {ip_kind; ip_pred} ->
- Format.asprintf "@@%a" Property.pretty_predicate_kind ip_kind ::
- user_pred_names ip_pred.ip_content
+ Format.asprintf "@@%a" Property.pretty_predicate_kind ip_kind ::
+ user_pred_names ip_pred.ip_content
| IPExtended {ie_ext={ext_name}} -> [ Printf.sprintf "@%s" ext_name ]
| IPCodeAnnot {ica_ca} -> code_annot_names ica_ca
| IPComplete {ic_bhvs} ->
- let kind_name = "@complete_behaviors" in
- let name = Format.asprintf "complete_behaviors%a" pp_names ic_bhvs
- in kind_name::[name]
+ let kind_name = "@complete_behaviors" in
+ let name = Format.asprintf "complete_behaviors%a" pp_names ic_bhvs
+ in kind_name::[name]
| IPDisjoint {ic_bhvs} ->
- let kind_name = "@disjoint_behaviors" in
- let name = Format.asprintf "disjoint_behaviors%a" pp_names ic_bhvs
- in kind_name::[name]
+ let kind_name = "@disjoint_behaviors" in
+ let name = Format.asprintf "disjoint_behaviors%a" pp_names ic_bhvs
+ in kind_name::[name]
| IPAssigns {ias_froms} ->
- List.fold_left
- (fun acc (t,_) -> (ident_names t.it_content.term_name) @ acc)
- ["@assigns"] ias_froms
+ List.fold_left
+ (fun acc (t,_) -> (ident_names t.it_content.term_name) @ acc)
+ ["@assigns"] ias_froms
| IPDecrease {id_ca=Some ca} -> "@decreases"::code_annot_names ca
| IPDecrease _ -> [ "@decreases" ]
| IPLemma {il_name = a; il_pred = l} ->
- let names = "@lemma"::a::user_pred_names l in
- begin
- match LogicUsage.section_of_lemma a with
- | LogicUsage.Toplevel _ -> names
- | LogicUsage.Axiomatic ax -> ax.LogicUsage.ax_name::names
- end
+ let names = "@lemma"::a::user_pred_names l in
+ begin
+ match LogicUsage.section_of_lemma a with
+ | LogicUsage.Toplevel _ -> names
+ | LogicUsage.Axiomatic ax -> ax.LogicUsage.ax_name::names
+ end
(* TODO *)
| IPFrom _
| IPAllocation _
@@ -483,15 +483,15 @@ let user_bhv_names p =
let open Property in
let fors = match p with
| Property.IPCodeAnnot { ica_ca } ->
- let fors = match ica_ca.annot_content with
- | Cil_types.AAssert (fors, _)
- | Cil_types.AStmtSpec (fors, _)
- | Cil_types.AInvariant (fors, _, _)
- | Cil_types.AAssigns (fors, _)
- | Cil_types.AAllocation (fors, _)
- | Cil_types.AExtended (fors, _, _) -> fors
- | _ -> []
- in fors
+ let fors = match ica_ca.annot_content with
+ | Cil_types.AAssert (fors, _)
+ | Cil_types.AStmtSpec (fors, _)
+ | Cil_types.AInvariant (fors, _, _)
+ | Cil_types.AAssigns (fors, _)
+ | Cil_types.AAllocation (fors, _)
+ | Cil_types.AExtended (fors, _, _) -> fors
+ | _ -> []
+ in fors
| _ -> []
in Option.fold ~none:fors ~some:(fun b -> b.b_name :: fors) (get_behavior p)
@@ -518,13 +518,13 @@ let label_of_kind = function
| PKTerminates -> "Terminates"
| PKDecreases -> "Decreases"
| PKPre(kf,_,_) ->
- Printf.sprintf "Precondition for '%s'" (Kernel_function.get_name kf)
+ Printf.sprintf "Precondition for '%s'" (Kernel_function.get_name kf)
let label_of_prop_id p =
match p.p_part with
| None -> label_of_kind p.p_kind
| Some(k,n) ->
- Printf.sprintf "%s (%d/%d)" (label_of_kind p.p_kind) (succ k) n
+ Printf.sprintf "%s (%d/%d)" (label_of_kind p.p_kind) (succ k) n
module Pretty =
struct
@@ -600,9 +600,9 @@ let propid_hints hs p =
| PKCheck , _ -> ()
| PKSmoke , _ -> add_required hs "smoke-test"
| PKProp , IPAssigns {ias_kinstr=Kstmt _} ->
- add_required hs "stmt-assigns"
+ add_required hs "stmt-assigns"
| PKProp , IPAssigns {ias_kinstr=Kglobal} ->
- add_required hs "fct-assigns"
+ add_required hs "fct-assigns"
| PKPropLoop , Property.IPAssigns _ -> add_required hs "loop-assigns"
| PKPropLoop , _ -> add_required hs "invariant"
| PKProp , _ -> add_required hs "property"
@@ -617,8 +617,8 @@ let propid_hints hs p =
| PKTerminates , _ -> add_required hs "terminates"
| PKDecreases , _ -> add_required hs "decreases"
| PKPre(kf,st,_) , _ ->
- add_required hs ("precond-" ^ Kernel_function.get_name kf) ;
- stmt_hints hs st
+ add_required hs ("precond-" ^ Kernel_function.get_name kf) ;
+ stmt_hints hs st
let rec term_hints hs t =
match t.term_node with
@@ -640,23 +640,23 @@ let assigns_hints hs froms =
let annot_hints hs = function
| AAssert(bs,ipred) | AInvariant(bs,_,ipred) ->
- List.iter (add_hint hs) (ident_names ipred.tp_statement.pred_name) ;
- List.iter (add_hint hs) bs
+ List.iter (add_hint hs) (ident_names ipred.tp_statement.pred_name) ;
+ List.iter (add_hint hs) bs
| AAssigns(bs,Writes froms) ->
- List.iter (add_hint hs) bs ;
- assigns_hints hs froms
+ List.iter (add_hint hs) bs ;
+ assigns_hints hs froms
| AAllocation _ | AAssigns(_,WritesAny) | AStmtSpec _
| AVariant _ | APragma _ | AExtended _ -> ()
let property_hints hs =
let open Property in function
| IPLemma {il_name; il_pred} ->
- List.iter (add_required hs) (il_name::il_pred.tp_statement.pred_name)
+ List.iter (add_required hs) (il_name::il_pred.tp_statement.pred_name)
| IPBehavior _ -> ()
| IPComplete {ic_bhvs} | IPDisjoint {ic_bhvs} ->
- Datatype.String.Set.iter (add_required hs) ic_bhvs
+ Datatype.String.Set.iter (add_required hs) ic_bhvs
| IPPredicate {ip_pred} ->
- List.iter (add_hint hs) ip_pred.ip_content.tp_statement.pred_name
+ List.iter (add_hint hs) ip_pred.ip_content.tp_statement.pred_name
| IPExtended {ie_ext={ext_name}} -> List.iter (add_hint hs) [ext_name]
| IPCodeAnnot {ica_ca} -> annot_hints hs ica_ca.annot_content
| IPAssigns {ias_froms} -> assigns_hints hs ias_froms
@@ -737,11 +737,11 @@ let is_requires =
let is_loop_preservation p =
match p.p_kind with
| PKPreserved ->
- begin
- match Property.get_kinstr p.p_prop with
- | Kglobal -> Wp_parameters.fatal "Loop Preservation ? (%a)" Property.pretty p.p_prop
- | Kstmt st -> Some st
- end
+ begin
+ match Property.get_kinstr p.p_prop with
+ | Kglobal -> Wp_parameters.fatal "Loop Preservation ? (%a)" Property.pretty p.p_prop
+ | Kstmt st -> Some st
+ end
| _ -> None
let user_prop_pid pid =
@@ -787,10 +787,10 @@ let select_for_behaviors bhvs pid =
let select_call_pre s_call asked_pre pid =
match pid.p_kind with
| PKPre (_, p_stmt, p_prop) ->
- Stmt.equal s_call p_stmt &&
- (match asked_pre with
- | None -> true
- | Some asked_pre -> Property.equal p_prop asked_pre)
+ Stmt.equal s_call p_stmt &&
+ (match asked_pre with
+ | None -> true
+ | Some asked_pre -> Property.equal p_prop asked_pre)
| _ -> false
(*----------------------------------------------------------------------------*)
@@ -938,23 +938,23 @@ let mk_loop_any_assigns_info s =
let pp_assign_info k fmt a = match a with
| NoAssignsInfo -> ()
| AssignsAny a ->
- let pkind =
- match a.a_kind with
- | StmtAssigns -> ""
- | LoopAssigns -> "loop"
- in
- Format.fprintf fmt "%s(@@%a): %s assigns everything@."
- k Clabels.pretty a.a_label pkind
+ let pkind =
+ match a.a_kind with
+ | StmtAssigns -> ""
+ | LoopAssigns -> "loop"
+ in
+ Format.fprintf fmt "%s(@@%a): %s assigns everything@."
+ k Clabels.pretty a.a_label pkind
| AssignsLocations (_,a) ->
- Format.fprintf fmt "%s(@@%a): %a@." k
- Clabels.pretty a.a_label
- pp_assigns_desc a
+ Format.fprintf fmt "%s(@@%a): %a@." k
+ Clabels.pretty a.a_label
+ pp_assigns_desc a
let merge_assign_info a1 a2 = match a1,a2 with
| NoAssignsInfo, a | a, NoAssignsInfo -> a
| (AssignsLocations _ | AssignsAny _),
(AssignsLocations _ | AssignsAny _) ->
- Wp_parameters.fatal "Several assigns ?"
+ Wp_parameters.fatal "Several assigns ?"
(* -------------------------------------------------------------------------- *)
@@ -1028,25 +1028,25 @@ let get_loop_stmt kf stmt =
| If (_, b1, b2,_) -> is_in_blk b1 || is_in_blk b2
| Switch (_, b, _, _) | Block b -> is_in_blk b
| UnspecifiedSequence seq ->
- let b = Cil.block_from_unspecified_sequence seq in
- is_in_blk b
+ let b = Cil.block_from_unspecified_sequence seq in
+ is_in_blk b
| Loop (_, b, _, _, _) -> is_in_blk b
| _ -> false
and find_loop_in_blk blk = find_loop_in_stmts blk.bstmts
and find_loop_in_stmts l = match l with
| [] -> None
| s::tl ->
- (match find_loop_in_stmt s with Some l -> Some l
- | None -> find_loop_in_stmts tl)
+ (match find_loop_in_stmt s with Some l -> Some l
+ | None -> find_loop_in_stmts tl)
and find_loop_in_stmt s = match s.skind with
| (Loop _) -> if is_in_stmt s then Some s else None
| If (_, b1, b2,_) ->
- (match find_loop_in_blk b1 with Some l -> Some l
- | None -> find_loop_in_blk b2)
+ (match find_loop_in_blk b1 with Some l -> Some l
+ | None -> find_loop_in_blk b2)
| Switch (_, b, _, _) | Block b -> find_loop_in_blk b
| UnspecifiedSequence seq ->
- let b = Cil.block_from_unspecified_sequence seq in
- find_loop_in_blk b
+ let b = Cil.block_from_unspecified_sequence seq in
+ find_loop_in_blk b
| _ -> None
in let f = Kernel_function.get_definition kf in
find_loop_in_blk f.sbody
@@ -1062,26 +1062,26 @@ let get_induction p =
in match p.p_kind with
| PKCheck | PKSmoke | PKAFctOut | PKAFctExit | PKPre _
| PKTactic | PKTerminates | PKDecreases ->
- None
+ None
| PKProp ->
- let loop_stmt_opt = match get_stmt (property_of_id p) with
- | None -> None
- | Some (kf, s) -> get_loop_stmt kf s
- in loop_stmt_opt
+ let loop_stmt_opt = match get_stmt (property_of_id p) with
+ | None -> None
+ | Some (kf, s) -> get_loop_stmt kf s
+ in loop_stmt_opt
| PKPropLoop ->
- let open Property in
- let loop_stmt_opt = match property_of_id p with
- | IPCodeAnnot {ica_kf; ica_stmt;
- ica_ca = {annot_content = AInvariant(_, loop, _)}} ->
- if loop then (*loop invariant *) Some ica_stmt
- else (* invariant inside loop *) get_loop_stmt ica_kf ica_stmt
- | IPAssigns {ias_kinstr=Kstmt stmt; ias_bhv = Id_loop _} ->
- (* loop assigns *) Some stmt
- | _ -> None (* assert false ??? *)
- in loop_stmt_opt
+ let open Property in
+ let loop_stmt_opt = match property_of_id p with
+ | IPCodeAnnot {ica_kf; ica_stmt;
+ ica_ca = {annot_content = AInvariant(_, loop, _)}} ->
+ if loop then (*loop invariant *) Some ica_stmt
+ else (* invariant inside loop *) get_loop_stmt ica_kf ica_stmt
+ | IPAssigns {ias_kinstr=Kstmt stmt; ias_bhv = Id_loop _} ->
+ (* loop assigns *) Some stmt
+ | _ -> None (* assert false ??? *)
+ in loop_stmt_opt
| PKEstablished|PKVarDecr|PKVarPos|PKVarRel|PKPreserved ->
- (match get_stmt (property_of_id p) with
- | None -> None | Some (_, s) -> Some s)
+ (match get_stmt (property_of_id p) with
+ | None -> None | Some (_, s) -> Some s)
(* -------------------------------------------------------------------------- *)
(* --- Filter according to status --- *)
@@ -1096,7 +1096,7 @@ let filter_status pid =
| C.Considered_valid | C.Inconsistent _ -> false
| C.Valid _ | C.Valid_under_hyp _
| C.Invalid_but_dead _ | C.Valid_but_dead _ | C.Unknown_but_dead _ ->
- Wp_parameters.StatusTrue.get ()
+ Wp_parameters.StatusTrue.get ()
| C.Unknown _ -> Wp_parameters.StatusMaybe.get ()
| C.Invalid _ | C.Invalid_under_hyp _ -> Wp_parameters.StatusFalse.get ()
end
@@ -1141,17 +1141,17 @@ let add_proof pf ip hs =
match parts_of_id ip with
| None -> pf.proved.(k) <- Complete
| Some(p,n) ->
- match pf.proved.(k) with
- | Complete -> ()
- | Noproof ->
- let bv = Bitvector.create n in
- Bitvector.set_range bv 0 (p-1) ;
- Bitvector.set_range bv (p+1) (n-1) ;
- pf.proved.(k) <- Parts bv
- | Parts bv ->
- Bitvector.clear bv p ;
- if Bitvector.is_empty bv
- then pf.proved.(k) <- Complete
+ match pf.proved.(k) with
+ | Complete -> ()
+ | Noproof ->
+ let bv = Bitvector.create n in
+ Bitvector.set_range bv 0 (p-1) ;
+ Bitvector.set_range bv (p+1) (n-1) ;
+ pf.proved.(k) <- Parts bv
+ | Parts bv ->
+ Bitvector.clear bv p ;
+ if Bitvector.is_empty bv
+ then pf.proved.(k) <- Complete
end
let add_invalid_proof pf = pf.invalid <- true
diff --git a/src/plugins/wp/wpRTE.ml b/src/plugins/wp/wpRTE.ml
index e7f12fe261c44cef1b09d65529d40a29317d52c6..130778bd2504019b8e90467f16bb736d45a4028a 100644
--- a/src/plugins/wp/wpRTE.ml
+++ b/src/plugins/wp/wpRTE.ml
@@ -67,8 +67,8 @@ let configure ~update ~generate kf cint rte =
match cint with
| Cint.Machine -> () (* RTE has been set *)
| Cint.Natural ->
- Wp_parameters.warning ~once:true ~current:false
- "-wp-rte and model nat require kernel to warn against %s" rte.name
+ Wp_parameters.warning ~once:true ~current:false
+ "-wp-rte and model nat require kernel to warn against %s" rte.name
let generator =
[
diff --git a/src/plugins/wp/wpReached.ml b/src/plugins/wp/wpReached.ml
index 972e0e19ff29f5ba4cfba30c092d349825d5f306..060d749f3a421f32fb62834a8a6bc8b0b162aefe 100644
--- a/src/plugins/wp/wpReached.ml
+++ b/src/plugins/wp/wpReached.ml
@@ -73,26 +73,26 @@ let rec is_predicate cond p =
| Pif(_,p,q) -> is_predicate cond p && is_predicate cond q
| Pat(p,_) -> is_predicate cond p
| Pand(p,q) ->
- if cond
- then is_predicate true p && is_predicate true q
- else is_predicate false p || is_predicate false q
+ if cond
+ then is_predicate true p && is_predicate true q
+ else is_predicate false p || is_predicate false q
| Por(p,q) ->
- if cond
- then is_predicate true p && is_predicate true q
- else is_predicate false p && is_predicate false q
+ if cond
+ then is_predicate true p && is_predicate true q
+ else is_predicate false p && is_predicate false q
| Pimplies(p,q) ->
- if cond
- then is_predicate false p || is_predicate true q
- else is_predicate true p && is_predicate false q
+ if cond
+ then is_predicate false p || is_predicate true q
+ else is_predicate true p && is_predicate false q
| _ -> false
let is_dead_annot ca =
match ca.annot_content with
| APragma (Loop_pragma (Unroll_specs [ spec ; _ ])) ->
- is_unrolled_completely spec
+ is_unrolled_completely spec
| AAssert([],p)
| AInvariant([],_,p) ->
- Logic_utils.use_predicate p.tp_kind && is_predicate false p.tp_statement
+ Logic_utils.use_predicate p.tp_kind && is_predicate false p.tp_statement
| _ -> false
let is_dead_code stmt =
@@ -125,9 +125,9 @@ let flow i f =
match i with
| Asm _ | Set _ -> F_effect
| Local_init _ ->
- if Wp_parameters.SmokeDeadlocalinit.get ()
- then F_effect
- else F_goto
+ if Wp_parameters.SmokeDeadlocalinit.get ()
+ then F_effect
+ else F_goto
| Call _ -> F_call
| Skip _ | Code_annot _ -> F_goto
@@ -154,26 +154,26 @@ and skind env a b = function
| Break _ -> goto a env.break
| Continue _ -> goto a env.continue
| If(_,bthen,belse,_) ->
- let ft = goto a (block env bthen b) in
- let fe = goto a (block env belse b) in
- merge ft fe
+ let ft = goto a (block env bthen b) in
+ let fe = goto a (block env belse b) in
+ merge ft fe
| Switch(_,body,cases,_) ->
- ignore (block { env with break = b } body b) ;
- List.fold_left
- (fun f s -> merge f (goto a (of_stmt env.cfg s)))
- F_dead cases
+ ignore (block { env with break = b } body b) ;
+ List.fold_left
+ (fun f s -> merge f (goto a (of_stmt env.cfg s)))
+ F_dead cases
| Loop(_,body,_,_,_) ->
- let continue = node () in
- let lenv = { env with continue ; break = b } in
- let flow = goto a (block lenv body continue) in
- if flow = F_dead then F_dead else F_entry
+ let continue = node () in
+ let lenv = { env with continue ; break = b } in
+ let flow = goto a (block lenv body continue) in
+ if flow = F_dead then F_dead else F_entry
| Block body ->
- goto a (block env body b)
+ goto a (block env body b)
| UnspecifiedSequence s ->
- let body = Cil.block_from_unspecified_sequence s in
- goto a (block env body b)
+ let body = Cil.block_from_unspecified_sequence s in
+ goto a (block env body b)
| Throw _ | TryCatch _ | TryFinally _ | TryExcept _ ->
- Wp_parameters.not_yet_implemented "try-catch blocks"
+ Wp_parameters.not_yet_implemented "try-catch blocks"
and block env blk b = sequence env blk.bstmts b
and sequence env seq b = match seq with
@@ -188,26 +188,26 @@ let rec unreachable node =
match node.unreachable with
| Some r -> r
| None ->
- node.unreachable <- Some true ; (* cut loops *)
- let r =
- match node.flow with
- | F_dead -> true
- | F_entry -> false
- | F_goto | F_effect | F_return | F_branch | F_call ->
- List.for_all unreachable node.prev
- in node.unreachable <- Some r ; r
+ node.unreachable <- Some true ; (* cut loops *)
+ let r =
+ match node.flow with
+ | F_dead -> true
+ | F_entry -> false
+ | F_goto | F_effect | F_return | F_branch | F_call ->
+ List.for_all unreachable node.prev
+ in node.unreachable <- Some r ; r
let rec protected node =
match node.protected with
| Some r -> r
| None ->
- node.protected <- Some false ; (* cut loops *)
- let r =
- match node.flow with
- | F_dead | F_entry -> true
- | F_goto | F_effect | F_return | F_branch | F_call ->
- node.prev <> [] && List.for_all protected_by node.prev
- in node.protected <- Some r ; r
+ node.protected <- Some false ; (* cut loops *)
+ let r =
+ match node.flow with
+ | F_dead | F_entry -> true
+ | F_goto | F_effect | F_return | F_branch | F_call ->
+ node.prev <> [] && List.for_all protected_by node.prev
+ in node.protected <- Some r ; r
and protected_by prev =
match prev.flow with
@@ -274,14 +274,14 @@ let dump ~dir kf reached =
let module Pr = Printer in
match s.skind with
| Instr _ | Return _ | Break _ | Continue _ | Goto _ ->
- Pu.to_string Pr.pp_stmt s
+ Pu.to_string Pr.pp_stmt s
| If(e,_,_,_) -> Pu.sfprintf "@[<hov 2>if (%a)@]" Pr.pp_exp e
| Switch(e,_,_,_) -> Pu.sfprintf "@[<hov 2>switch (%a)@]" Pr.pp_exp e
| Loop _ -> Printf.sprintf "Loop s%d" s.sid
| Block _ -> Printf.sprintf "Block s%d" s.sid
| UnspecifiedSequence _ -> Printf.sprintf "Seq. s%d" s.sid
| Throw _ | TryExcept _ | TryCatch _ | TryFinally _ ->
- Printf.sprintf "Exn. s%d" s.sid
+ Printf.sprintf "Exn. s%d" s.sid
in G.node dot (N.get n)
[`Box;`Label (Printf.sprintf "s%d n%d: %s" s.sid n.id label)])
reached ;
@@ -349,35 +349,35 @@ let set_invalid emitter tgt =
match tgt with
(* For invalid assumes, introduce "ensures false" in behavior on need *)
| Property.IPPredicate { ip_kind = PKAssumes(bhv) ; ip_kf ; ip_pred } ->
- if not (Invalid_behaviors.mem ip_kf bhv) then begin
- Invalid_behaviors.add ip_kf bhv ;
- let pred_name = [ "Wp" ; "SmokeTest" ] in
- let pred_loc = ip_pred.ip_content.tp_statement.pred_loc in
- let p = { Logic_const.pfalse with pred_loc ; pred_name } in
- let p = Logic_const.(new_predicate p) in
- let pid = Property.ip_of_ensures ip_kf Kglobal bhv (Normal, p) in
- Annotations.add_ensures emitter ip_kf ~behavior:bhv.b_name [Normal, p];
- emit emitter ~hyps:[] pid False_if_reachable
- end
+ if not (Invalid_behaviors.mem ip_kf bhv) then begin
+ Invalid_behaviors.add ip_kf bhv ;
+ let pred_name = [ "Wp" ; "SmokeTest" ] in
+ let pred_loc = ip_pred.ip_content.tp_statement.pred_loc in
+ let p = { Logic_const.pfalse with pred_loc ; pred_name } in
+ let p = Logic_const.(new_predicate p) in
+ let pid = Property.ip_of_ensures ip_kf Kglobal bhv (Normal, p) in
+ Annotations.add_ensures emitter ip_kf ~behavior:bhv.b_name [Normal, p];
+ emit emitter ~hyps:[] pid False_if_reachable
+ end
| p ->
- emit emitter ~hyps:[] p False_if_reachable
+ emit emitter ~hyps:[] p False_if_reachable
let set_doomed emitter pid =
List.iter (set_invalid emitter) (WpPropId.doomed_if_valid pid) ;
match WpPropId.unreachable_if_valid pid with
| Property.OLStmt(kf,stmt) ->
- let ca =
- match Annotations.code_annot ~emitter ~filter:is_dead_annot stmt with
- | ca::_ -> ca
- | [] ->
- let pred_loc = Stmt.loc stmt in
- let pred_name = [ "Wp" ; "SmokeTest" ] in
- let pf = { Logic_const.pfalse with pred_loc ; pred_name } in
- let pf = Logic_const.toplevel_predicate pf in
- let ca = Logic_const.new_code_annotation (AAssert ([],pf)) in
- Annotations.add_code_annot emitter ~kf stmt ca ; ca
- in
- List.iter (set_invalid emitter) (Property.ip_of_code_annot kf stmt ca)
+ let ca =
+ match Annotations.code_annot ~emitter ~filter:is_dead_annot stmt with
+ | ca::_ -> ca
+ | [] ->
+ let pred_loc = Stmt.loc stmt in
+ let pred_name = [ "Wp" ; "SmokeTest" ] in
+ let pf = { Logic_const.pfalse with pred_loc ; pred_name } in
+ let pf = Logic_const.toplevel_predicate pf in
+ let ca = Logic_const.new_code_annotation (AAssert ([],pf)) in
+ Annotations.add_code_annot emitter ~kf stmt ca ; ca
+ in
+ List.iter (set_invalid emitter) (Property.ip_of_code_annot kf stmt ca)
| Property.OLGlob _ | Property.OLContract _ -> ()
(* -------------------------------------------------------------------------- *)
@@ -410,22 +410,22 @@ let set_unreachable pid =
let emit = function
| IPPredicate {ip_kind = PKAssumes _} -> ()
| p ->
- debug "unreachable annotation %a@." Property.pretty p;
- Property_status.emit wp_unreachable ~hyps:[] p Property_status.True
+ debug "unreachable annotation %a@." Property.pretty p;
+ Property_status.emit wp_unreachable ~hyps:[] p Property_status.True
in
let pids = match WpPropId.property_of_id pid with
| IPPredicate {ip_kind = PKAssumes _} -> []
| IPBehavior {ib_kf; ib_kinstr; ib_active; ib_bhv} ->
- let active = Datatype.String.Set.elements ib_active in
- (ip_post_cond_of_behavior ib_kf ib_kinstr active ib_bhv) @
- (ip_requires_of_behavior ib_kf ib_kinstr ib_bhv)
+ let active = Datatype.String.Set.elements ib_active in
+ (ip_post_cond_of_behavior ib_kf ib_kinstr active ib_bhv) @
+ (ip_requires_of_behavior ib_kf ib_kinstr ib_bhv)
| IPExtended _ -> []
(* Extended clauses might concern anything. Don't validate them
unless we know exactly what is going on. *)
| p ->
- incr unreachable_proved ;
- Wp_parameters.result "[CFG] Goal %a : Valid (Unreachable)"
- WpPropId.pp_propid pid ; [p]
+ incr unreachable_proved ;
+ Wp_parameters.result "[CFG] Goal %a : Valid (Unreachable)"
+ WpPropId.pp_propid pid ; [p]
in
List.iter emit pids
diff --git a/src/plugins/wp/wpReport.ml b/src/plugins/wp/wpReport.ml
index 71868c87da7af7108c78fe8b9beb20e0b4e0b422..a928be3ade20adc612670b33913617f18003ca93 100644
--- a/src/plugins/wp/wpReport.ml
+++ b/src/plugins/wp/wpReport.ml
@@ -94,11 +94,11 @@ let result ~status ~smoke (r:VCS.result) =
match status with
| `Passed when smoke -> VALID
| _ ->
- match VCS.verdict ~smoke r with
- | VCS.NoResult | VCS.Computing _ -> NORESULT
- | VCS.Failed -> INCONCLUSIVE
- | VCS.Invalid | VCS.Unknown | VCS.Timeout | VCS.Stepout -> UNSUCCESS
- | VCS.Valid -> VALID
+ match VCS.verdict ~smoke r with
+ | VCS.NoResult | VCS.Computing _ -> NORESULT
+ | VCS.Failed -> INCONCLUSIVE
+ | VCS.Invalid | VCS.Unknown | VCS.Timeout | VCS.Stepout -> UNSUCCESS
+ | VCS.Valid -> VALID
let best_result a b = match a,b with
| NORESULT,c | c,NORESULT -> c
@@ -126,9 +126,9 @@ let add_stat (r:res) (st:int) (tm:float) (s:stats) =
s.total <- succ s.total ;
match r with
| VALID ->
- if tm > s.time then s.time <- tm ;
- if st > s.steps then s.steps <- st ;
- s.valid <- succ s.valid
+ if tm > s.time then s.time <- tm ;
+ if st > s.steps then s.steps <- st ;
+ s.valid <- succ s.valid
| NORESULT | UNSUCCESS -> s.unsuccess <- succ s.unsuccess
| INCONCLUSIVE -> s.inconclusive <- succ s.inconclusive
end
@@ -465,12 +465,12 @@ let start_stat4prop cistat =
match cistat.sections with
| [] -> None
| ((_,ds) as s)::_ ->
- Some { sfcstat = cistat.cfcstat;
- schapter = cistat.chapter;
- section = s;
- properties = List.rev (Property.Map.fold
- (fun p ps acc -> (p,ps)::acc) ds.dmap []);
- }
+ Some { sfcstat = cistat.cfcstat;
+ schapter = cistat.chapter;
+ section = s;
+ properties = List.rev (Property.Map.fold
+ (fun p ps acc -> (p,ps)::acc) ds.dmap []);
+ }
(** next property stats *)
let next_stat4prop sistat =
@@ -581,26 +581,26 @@ let stat ~config fmt s = function
| "valid" | "" -> number config fmt s.valid
| "failed" -> number config fmt (s.unsuccess + s.inconclusive)
| "status" ->
- let msg =
- if s.inconclusive > 0 then config.status_inconclusive else
- if s.unsuccess > 0 then config.status_failed else
- if s.valid >= s.total then config.status_passed else
- config.status_untried
- in Format.pp_print_string fmt msg
+ let msg =
+ if s.inconclusive > 0 then config.status_inconclusive else
+ if s.unsuccess > 0 then config.status_failed else
+ if s.valid >= s.total then config.status_passed else
+ config.status_untried
+ in Format.pp_print_string fmt msg
| "inconclusive" -> number config fmt s.inconclusive
| "unsuccess" -> number config fmt s.unsuccess
| "time" ->
- if s.time > 0.0 then
- Rformat.pp_time_range ladder fmt s.time
+ if s.time > 0.0 then
+ Rformat.pp_time_range ladder fmt s.time
| "perf" ->
- if s.time > Rformat.epsilon then
- Format.fprintf fmt "(%a)" Rformat.pp_time s.time
+ if s.time > Rformat.epsilon then
+ Format.fprintf fmt "(%a)" Rformat.pp_time s.time
| "steps" ->
- if s.steps > 0 then Format.fprintf fmt "(%d)" s.steps
+ if s.steps > 0 then Format.fprintf fmt "(%d)" s.steps
| "range" ->
- if s.rank >= 0 then
- let a,b = range s.rank in
- Format.fprintf fmt "(%d..%d)" a b
+ if s.rank >= 0 then
+ let a,b = range s.rank in
+ Format.fprintf fmt "(%d..%d)" a b
| _ -> raise Exit
let pstats ~config fmt s cmd arg =
@@ -608,9 +608,9 @@ let pstats ~config fmt s cmd arg =
| "wp" | "qed" -> stat ~config fmt (get_prover s VCS.Qed) arg
| cmd when is_stat_name cmd -> stat ~config fmt s.main cmd
| prover ->
- match (VCS.parse_prover prover) with
- | None -> Wp_parameters.error ~once:true "Unknown prover name %s" prover
- | Some prover -> stat ~config fmt (get_prover s prover) arg
+ match (VCS.parse_prover prover) with
+ | None -> Wp_parameters.error ~once:true "Unknown prover name %s" prover
+ | Some prover -> stat ~config fmt (get_prover s prover) arg
let pcstats ~config fmt (s,c) cmd arg =
match cmd with
@@ -633,7 +633,7 @@ let env_chapter chapter_name fmt cmd arg =
try
match cmd with
| "chapter" | "name" ->
- Format.pp_print_string fmt chapter_name
+ Format.pp_print_string fmt chapter_name
| _ -> raise Exit
with Exit ->
if arg=""
@@ -647,20 +647,20 @@ let env_section ~config ~name sstat fmt cmd arg =
| _ -> raise Exit
in match cmd with
| "chapter" ->
- let chapter = match entry with
- | Axiom _ -> config.axiomatic_section
- | Fun _ -> config.function_section
- in Format.pp_print_string fmt chapter
+ let chapter = match entry with
+ | Axiom _ -> config.axiomatic_section
+ | Fun _ -> config.function_section
+ in Format.pp_print_string fmt chapter
| "name" | "section" | "global" | "axiomatic" | "function" ->
- if cmd <> "name" && cmd <> "section" && name <> cmd then
- Wp_parameters.error "Invalid section-format '%%%s' inside a section %s" cmd name;
- let prefix,name = match entry with
- | Axiom "" -> config.lemma_prefix,""
- | Axiom a -> config.axiomatic_prefix,a
- | Fun kf -> config.function_prefix, ( Kernel_function.get_name kf)
- in Format.fprintf fmt "%s%s" prefix name
+ if cmd <> "name" && cmd <> "section" && name <> cmd then
+ Wp_parameters.error "Invalid section-format '%%%s' inside a section %s" cmd name;
+ let prefix,name = match entry with
+ | Axiom "" -> config.lemma_prefix,""
+ | Axiom a -> config.axiomatic_prefix,a
+ | Fun kf -> config.function_prefix, ( Kernel_function.get_name kf)
+ in Format.fprintf fmt "%s%s" prefix name
| _ ->
- pcstats config fmt (ds.dstats, ds.dcoverage) cmd arg
+ pcstats config fmt (ds.dstats, ds.dcoverage) cmd arg
with Exit ->
if arg=""
then Wp_parameters.error ~once:true "Unknown section-format '%%%s'" cmd
@@ -674,25 +674,25 @@ let env_property ~config ~name pstat fmt cmd arg =
| _ -> raise Exit
in match cmd with
| "chapter" ->
- let chapter = match entry with
- | Axiom _ -> config.axiomatic_section
- | Fun _ -> config.function_section
- in Format.pp_print_string fmt chapter
+ let chapter = match entry with
+ | Axiom _ -> config.axiomatic_section
+ | Fun _ -> config.function_section
+ in Format.pp_print_string fmt chapter
| "section" | "global" | "axiomatic" | "function" ->
- if cmd <> "section" && name <> cmd then
- Wp_parameters.error "Invalid property-format '%%%s' inside a section %s" cmd name;
- let prefix,name = match entry with
- | Axiom "" -> config.lemma_prefix,""
- | Axiom a -> config.axiomatic_prefix,a
- | Fun kf -> config.function_prefix, ( Kernel_function.get_name kf)
- in Format.fprintf fmt "%s%s" prefix name
+ if cmd <> "section" && name <> cmd then
+ Wp_parameters.error "Invalid property-format '%%%s' inside a section %s" cmd name;
+ let prefix,name = match entry with
+ | Axiom "" -> config.lemma_prefix,""
+ | Axiom a -> config.axiomatic_prefix,a
+ | Fun kf -> config.function_prefix, ( Kernel_function.get_name kf)
+ in Format.fprintf fmt "%s%s" prefix name
| "name" ->
- Format.fprintf fmt "%s%s" config.property_prefix
- (Property.Names.get_prop_name_id p)
+ Format.fprintf fmt "%s%s" config.property_prefix
+ (Property.Names.get_prop_name_id p)
| "property" ->
- Description.pp_local fmt p
+ Description.pp_local fmt p
| _ ->
- pstats config fmt stat cmd arg
+ pstats config fmt stat cmd arg
with Exit ->
if arg=""
then Wp_parameters.error ~once:true "Unknown property-format '%%%s'" cmd
@@ -803,9 +803,9 @@ let export gstat specfile =
| Rformat.ARG("ZERO",z) -> config.zero <- z
| Rformat.ARG("FILE",f) -> file := Some f
| Rformat.ARG("SUFFIX",e) ->
- let basename = Wp_parameters.ReportName.get () in
- let filename = basename ^ e in
- file := Some filename
+ let basename = Wp_parameters.ReportName.get () in
+ let filename = basename ^ e in
+ file := Some filename
| Rformat.CMD "CONSOLE" -> config.console <- true
| Rformat.CMD "END" -> section := END
@@ -822,21 +822,21 @@ let export gstat specfile =
| Rformat.CMD "PROPERTY" -> section := PROPERTY
| Rformat.CMD a | Rformat.ARG(a,_) ->
- Wp_parameters.error "Report '%s': unknown command '%s'" specfile a
+ Wp_parameters.error "Report '%s': unknown command '%s'" specfile a
| Rformat.TEXT ->
- if !section <> END then
- let text = match !section with
- | HEAD -> head
- | CHAPTER -> chap
- | SECTION -> sect
- | GLOB_SECTION -> glob
- | AXIO_SECTION -> axio
- | FUNC_SECTION -> func
- | PROPERTY -> sect_prop
- | TAIL|END -> tail
- in
- Buffer.add_string text line ;
- Buffer.add_char text '\n' ;
+ if !section <> END then
+ let text = match !section with
+ | HEAD -> head
+ | CHAPTER -> chap
+ | SECTION -> sect
+ | GLOB_SECTION -> glob
+ | AXIO_SECTION -> axio
+ | FUNC_SECTION -> func
+ | PROPERTY -> sect_prop
+ | TAIL|END -> tail
+ in
+ Buffer.add_string text line ;
+ Buffer.add_char text '\n' ;
done
with
| End_of_file -> close_in cin
@@ -844,35 +844,35 @@ let export gstat specfile =
end ;
match !file with
| None ->
- Log.print_on_output
- (print gstat ~config
- ~head:(Buffer.contents head) ~tail:(Buffer.contents tail)
- ~chap:(Buffer.contents chap)
- ~sect:(Buffer.contents sect)
- ~glob:(Buffer.contents glob)
- ~axio:(Buffer.contents axio)
- ~func:(Buffer.contents func)
- ~prop:(Buffer.contents sect_prop))
+ Log.print_on_output
+ (print gstat ~config
+ ~head:(Buffer.contents head) ~tail:(Buffer.contents tail)
+ ~chap:(Buffer.contents chap)
+ ~sect:(Buffer.contents sect)
+ ~glob:(Buffer.contents glob)
+ ~axio:(Buffer.contents axio)
+ ~func:(Buffer.contents func)
+ ~prop:(Buffer.contents sect_prop))
| Some report ->
- Wp_parameters.feedback "Report '%s'" report ;
- let cout = open_out report in
- let fout = Format.formatter_of_out_channel cout in
- try
- print gstat ~config
- ~head:(Buffer.contents head) ~tail:(Buffer.contents tail)
- ~chap:(Buffer.contents chap)
- ~sect:(Buffer.contents sect)
- ~glob:(Buffer.contents glob)
- ~axio:(Buffer.contents axio)
- ~func:(Buffer.contents func)
- ~prop:(Buffer.contents sect_prop)
- fout ;
- Format.pp_print_flush fout () ;
- close_out cout ;
- with err ->
- Format.pp_print_flush fout () ;
- close_out cout ;
- raise err
+ Wp_parameters.feedback "Report '%s'" report ;
+ let cout = open_out report in
+ let fout = Format.formatter_of_out_channel cout in
+ try
+ print gstat ~config
+ ~head:(Buffer.contents head) ~tail:(Buffer.contents tail)
+ ~chap:(Buffer.contents chap)
+ ~sect:(Buffer.contents sect)
+ ~glob:(Buffer.contents glob)
+ ~axio:(Buffer.contents axio)
+ ~func:(Buffer.contents func)
+ ~prop:(Buffer.contents sect_prop)
+ fout ;
+ Format.pp_print_flush fout () ;
+ close_out cout ;
+ with err ->
+ Format.pp_print_flush fout () ;
+ close_out cout ;
+ raise err
(* -------------------------------------------------------------------------- *)
@@ -882,12 +882,12 @@ let export_json gstat ?jinput ~joutput () =
try
let jfile = match jinput with
| None ->
- Wp_parameters.feedback "Report '%s'" joutput ;
- joutput
+ Wp_parameters.feedback "Report '%s'" joutput ;
+ joutput
| Some jinput ->
- Wp_parameters.feedback "Report in: '%s'" jinput ;
- Wp_parameters.feedback "Report out: '%s'" joutput ;
- jinput
+ Wp_parameters.feedback "Report in: '%s'" jinput ;
+ Wp_parameters.feedback "Report out: '%s'" joutput ;
+ jinput
in
if Sys.file_exists jfile then
Json.load_file jfile
diff --git a/src/plugins/wp/wpTarget.ml b/src/plugins/wp/wpTarget.ml
index 38014551a42c59e9a5ab0dc59768484d5578edde..9355465052f4163097246c20d9968c86e9e8b0e0 100644
--- a/src/plugins/wp/wpTarget.ml
+++ b/src/plugins/wp/wpTarget.ml
@@ -35,11 +35,11 @@ module TargetKfs =
let get_called_stmt stmt =
match stmt.skind with
| Instr (Call(_, fct, _, _)) ->
- begin match Kernel_function.get_called fct with
- | Some kf -> [kf]
- | None -> Option.value ~default:[]
- (Option.map snd (Dyncall.get stmt))
- end
+ begin match Kernel_function.get_called fct with
+ | Some kf -> [kf]
+ | None -> Option.value ~default:[]
+ (Option.map snd (Dyncall.get stmt))
+ end
| Instr (Local_init (_,ConsInit(vi,_,_),_)) -> [ Globals.Functions.get vi ]
| _ -> []
diff --git a/src/plugins/wp/wp_error.ml b/src/plugins/wp/wp_error.ml
index 82f25036f4803682ffee0aa49dadf8795e702cab..1c840be07e387f7a65059c4e68d1a9855a0a1d4c 100644
--- a/src/plugins/wp/wp_error.ml
+++ b/src/plugins/wp/wp_error.ml
@@ -52,12 +52,12 @@ let pp_logic_label fmt label =
| BuiltinLabel l -> Printer.pp_logic_builtin_label fmt l
| FormalLabel s -> Format.pp_print_string fmt s
| StmtLabel {contents=stmt} ->
- Format.pp_print_string fmt
- (let rec pickLabel = function
- | [] -> Printf.sprintf "__unknown_label_%d" stmt.sid
- | Label (l, _, _) :: _ -> l
- | _ :: rest -> pickLabel rest
- in pickLabel stmt.labels)
+ Format.pp_print_string fmt
+ (let rec pickLabel = function
+ | [] -> Printf.sprintf "__unknown_label_%d" stmt.sid
+ | Label (l, _, _) :: _ -> l
+ | _ :: rest -> pickLabel rest
+ in pickLabel stmt.labels)
let pp_assigns fmt asgns =
match asgns with
@@ -73,10 +73,10 @@ let name = function
| [] -> ""
| [x] -> x
| x::xs ->
- let buffer = Buffer.create 80 in
- Buffer.add_string buffer x ;
- List.iter
- (fun y -> if y <> "" then
- ( Buffer.add_char buffer '-' ;
- Buffer.add_string buffer y )) xs ;
- Buffer.contents buffer
+ let buffer = Buffer.create 80 in
+ Buffer.add_string buffer x ;
+ List.iter
+ (fun y -> if y <> "" then
+ ( Buffer.add_char buffer '-' ;
+ Buffer.add_string buffer y )) xs ;
+ Buffer.contents buffer
diff --git a/src/plugins/wp/wp_parameters.ml b/src/plugins/wp/wp_parameters.ml
index 7c01bcbb20093e2b496661dd5939a6a131fb786b..faa6aa91ce1c1a4d9ca75bbf41713c30d1d66c9d 100644
--- a/src/plugins/wp/wp_parameters.ml
+++ b/src/plugins/wp/wp_parameters.ml
@@ -164,8 +164,8 @@ let iter_fct phi = function
| Fct_none -> ()
| Fct_all -> Globals.Functions.iter phi
| Fct_skip fs ->
- Globals.Functions.iter
- (fun kf -> if not (Fct.mem kf fs) then phi kf)
+ Globals.Functions.iter
+ (fun kf -> if not (Fct.mem kf fs) then phi kf)
| Fct_list fs -> Fct.iter phi fs
let get_kfs () =
@@ -1028,14 +1028,14 @@ let unique_tmp = ref None
let make_tmp_dir () =
match !unique_tmp with
| None ->
- let tmp =
- try Extlib.temp_dir_cleanup_at_exit "wp"
- with Extlib.Temp_file_error s ->
- abort "Cannot create temporary file: %s" s
- in
- unique_tmp := Some tmp ;
- debug ~dkey "Created temporary directory '%s'" tmp ;
- tmp
+ let tmp =
+ try Extlib.temp_dir_cleanup_at_exit "wp"
+ with Extlib.Temp_file_error s ->
+ abort "Cannot create temporary file: %s" s
+ in
+ unique_tmp := Some tmp ;
+ debug ~dkey "Created temporary directory '%s'" tmp ;
+ tmp
| Some tmp -> tmp
let make_gui_dir () =
@@ -1058,14 +1058,14 @@ let base_output () =
| None -> let output =
match OutputDir.get () with
| "" ->
- if !Fc_config.is_gui
- then make_gui_dir ()
- else make_tmp_dir ()
+ if !Fc_config.is_gui
+ then make_gui_dir ()
+ else make_tmp_dir ()
| dir ->
- make_output_dir dir ; dir in
- base_output := Some output;
- Fc_Filepath.(add_symbolic_dir "WPOUT" (Normalized.of_string output)) ;
- Datatype.Filepath.of_string output
+ make_output_dir dir ; dir in
+ base_output := Some output;
+ Fc_Filepath.(add_symbolic_dir "WPOUT" (Normalized.of_string output)) ;
+ Datatype.Filepath.of_string output
| Some output -> Datatype.Filepath.of_string output
let get_output () =
diff --git a/src/plugins/wp/wpo.ml b/src/plugins/wp/wpo.ml
index a309ee7ed01ee5101ff5e455e720ff4298f7056f..480b9fd6788807e7ce699c7d47bc01b1e8ae2787 100644
--- a/src/plugins/wp/wpo.ml
+++ b/src/plugins/wp/wpo.ml
@@ -53,13 +53,13 @@ let pp_function fmt kf bhv =
flow := true ;
match bhv with
| None ->
- Format.fprintf fmt
- "%s@\n Function %s@\n%s@\n@\n"
- bar (Kernel_function.get_name kf) bar
+ Format.fprintf fmt
+ "%s@\n Function %s@\n%s@\n@\n"
+ bar (Kernel_function.get_name kf) bar
| Some bhv ->
- Format.fprintf fmt
- "%s@\n Function %s with behavior %s@\n%s@\n@\n"
- bar (Kernel_function.get_name kf) bhv bar
+ Format.fprintf fmt
+ "%s@\n Function %s with behavior %s@\n%s@\n@\n"
+ bar (Kernel_function.get_name kf) bhv bar
let pp_warnings fmt ws =
List.iter (fun w -> Format.fprintf fmt "%a@\n" Warning.pretty w) ws
@@ -270,8 +270,8 @@ struct
match vc.sequent with
| Some s -> s
| None ->
- let s = Conditions.lemma vc.lemma.l_lemma in
- vc.sequent <- Some s ; s
+ let s = Conditions.lemma vc.lemma.l_lemma in
+ vc.sequent <- Some s ; s
let pretty fmt vc results =
begin
@@ -329,14 +329,14 @@ struct
let pp_effect fmt = function
| None -> ()
| Some(s,e) ->
- let loc = fst (Stmt.loc s) in
- let line = loc.Filepath.pos_lnum in
- let desc = match e with
- | WpPropId.FromCode -> "Effect"
- | WpPropId.FromCall -> "Call Effect"
- | WpPropId.FromReturn -> "Call Result"
- in
- Format.fprintf fmt "%s at line %d@\n" desc line
+ let loc = fst (Stmt.loc s) in
+ let line = loc.Filepath.pos_lnum in
+ let desc = match e with
+ | WpPropId.FromCode -> "Effect"
+ | WpPropId.FromCall -> "Call Effect"
+ | WpPropId.FromReturn -> "Call Result"
+ in
+ Format.fprintf fmt "%s at line %d@\n" desc line
let pretty fmt pid vc results =
begin
@@ -392,9 +392,9 @@ let get_context w = w.po_model , get_scope w
let get_depend = function
| { po_formula = GoalAnnot { VC_Annot.deps = ips } } ->
- Property.Set.elements ips
+ Property.Set.elements ips
| { po_formula = GoalLemma { VC_Lemma.depends = ips } } ->
- List.map LogicUsage.ip_lemma ips
+ List.map LogicUsage.ip_lemma ips
let get_file_logout w prover =
DISK.file_logout ~pid:w.po_pid ~model:(get_model w) ~prover
@@ -417,13 +417,13 @@ struct
| Axiomatic _ , Function _ -> (-1)
| Function _ , Axiomatic _ -> 1
| Function(f,a) , Function(g,b) ->
- let c =
- if Kernel_function.equal f g then 0 else
- String.compare
- (Kernel_function.get_name f)
- (Kernel_function.get_name g)
- in
- if c=0 then cmpopt a b else c
+ let c =
+ if Kernel_function.equal f g then 0 else
+ String.compare
+ (Kernel_function.get_name f)
+ (Kernel_function.get_name g)
+ in
+ if c=0 then cmpopt a b else c
end
module S =
@@ -653,7 +653,7 @@ let add g =
begin
match g.po_idx with
| Function(kf,_) ->
- system.wpo_kf <- index_wpo Fmap.add Fmap.find kf g system.wpo_kf
+ system.wpo_kf <- index_wpo Fmap.add Fmap.find kf g system.wpo_kf
| _ -> ()
end ;
incr added ;
@@ -682,7 +682,7 @@ let remove g =
begin
match g.po_idx with
| Function(kf,_) ->
- system.wpo_kf <- unindex_wpo Fmap.add Fmap.find kf g system.wpo_kf
+ system.wpo_kf <- unindex_wpo Fmap.add Fmap.find kf g system.wpo_kf
| Axiomatic _ -> ()
end ;
system.results <- WPOmap.remove g system.results ;
@@ -790,10 +790,10 @@ let is_trivial g =
let reduce g =
match g.po_formula with
| GoalLemma vc ->
- WpContext.on_context (get_context g) VC_Lemma.is_trivial vc
+ WpContext.on_context (get_context g) VC_Lemma.is_trivial vc
| GoalAnnot vc ->
- let pid = g.po_pid in
- WpContext.on_context (get_context g) (VC_Annot.resolve ~pid) vc
+ let pid = g.po_pid in
+ WpContext.on_context (get_context g) (VC_Annot.resolve ~pid) vc
let resolve g =
let valid = reduce g in
@@ -806,12 +806,12 @@ let compute g =
let ctxt = get_context g in
match g.po_formula with
| GoalAnnot { VC_Annot.axioms ; VC_Annot.goal = goal } ->
- let pid = g.po_pid in
- axioms , WpContext.on_context ctxt (GOAL.compute_descr ~pid) goal
+ let pid = g.po_pid in
+ axioms , WpContext.on_context ctxt (GOAL.compute_descr ~pid) goal
| GoalLemma ({ VC_Lemma.depends = depends ; VC_Lemma.lemma = lemma } as w) ->
- let open Definitions in
- Some( lemma.l_cluster , depends ) ,
- WpContext.on_context ctxt VC_Lemma.sequent w
+ let open Definitions in
+ Some( lemma.l_cluster , depends ) ,
+ WpContext.on_context ctxt VC_Lemma.sequent w
let is_proved g =
is_trivial g || List.exists (fun (_,r) -> VCS.is_valid r) (get_results g)
@@ -845,9 +845,9 @@ let pp_goal_model fmt w =
begin
match w.po_formula with
| GoalAnnot vcq ->
- VC_Annot.pretty fmt w.po_pid vcq (get_results w)
+ VC_Annot.pretty fmt w.po_pid vcq (get_results w)
| GoalLemma vca ->
- VC_Lemma.pretty fmt vca (get_results w)
+ VC_Lemma.pretty fmt vca (get_results w)
end
let pp_goal fmt w = WpContext.on_context (get_context w) (pp_goal_model fmt) w
@@ -895,27 +895,27 @@ let iter ?ip ?index ?on_axiomatics ?on_behavior ?on_goal () =
in
match index,ip with
| None,None ->
- Gmap.iter (fun idx ws -> on_part idx ; on_goals ws) system.wpo_idx
+ Gmap.iter (fun idx ws -> on_part idx ; on_goals ws) system.wpo_idx
| _,Some ip ->
- begin
- match on_goal with
- | None -> ()
- | Some phi ->
- let poset =
- try Pmap.find ip system.wpo_ip
- with Not_found -> WPOset.empty in
- WPOset.iter phi poset
- end
+ begin
+ match on_goal with
+ | None -> ()
+ | Some phi ->
+ let poset =
+ try Pmap.find ip system.wpo_ip
+ with Not_found -> WPOset.empty in
+ WPOset.iter phi poset
+ end
| Some (Function(kf,None)),None ->
- begin
- try on_goals (Fmap.find kf system.wpo_kf)
- with Not_found -> ()
- end
+ begin
+ try on_goals (Fmap.find kf system.wpo_kf)
+ with Not_found -> ()
+ end
| Some idx,None ->
- begin
- try on_goals (Gmap.find idx system.wpo_idx)
- with Not_found -> ()
- end
+ begin
+ try on_goals (Gmap.find idx system.wpo_idx)
+ with Not_found -> ()
+ end
let iter_on_goals =
Dynamic.register ~plugin:"Wp" "Wpo.iter_on_goals"
@@ -972,9 +972,9 @@ let get_files w =
let results = get_results w in
let descr_files = match w.po_formula with
| GoalAnnot vcq ->
- [ "Goal" , VC_Annot.cache_descr ~pid:w.po_pid vcq results ]
+ [ "Goal" , VC_Annot.cache_descr ~pid:w.po_pid vcq results ]
| GoalLemma vca ->
- [ "Lemma" , VC_Lemma.cache_descr vca results ]
+ [ "Lemma" , VC_Lemma.cache_descr vca results ]
in
let result_files =
List.fold_right
diff --git a/src/plugins/wp/wprop.ml b/src/plugins/wp/wprop.ml
index f181c043b8e4b7d3090d7b6eb34d943b2e324471..f4e9fcc0a9fa321436264205937645c24c620bd8 100644
--- a/src/plugins/wp/wprop.ml
+++ b/src/plugins/wp/wprop.ml
@@ -77,7 +77,7 @@ struct
match Info.property key with
| Later ip -> ip
| Proxy(ip,emitter,ips) ->
- Property_status.logical_consequence emitter ip ips ; ip
+ Property_status.logical_consequence emitter ip ips ; ip
in
List.iter (fun f -> f key ip) !hooks ;
H.add key ip ; ip
diff --git a/tests/constant_propagation/array_pointers.i b/tests/constant_propagation/array_pointers.i
index 5f2d17c28f129708156e261807464f616cacdecc..41762ffb56af1f94772c5ff55c58392c451537bb 100644
--- a/tests/constant_propagation/array_pointers.i
+++ b/tests/constant_propagation/array_pointers.i
@@ -1,5 +1,5 @@
/* run.config
- STDOPT: +"-eva"
+ STDOPT: #"-eva"
*/
void *p;
diff --git a/tests/constant_propagation/const_field_return_struct.i b/tests/constant_propagation/const_field_return_struct.i
index 6b4473198a227ba1a1c6ca5835d2706c1441d847..6fdf85d653e586a12ac070adfefd583a2136d7d0 100644
--- a/tests/constant_propagation/const_field_return_struct.i
+++ b/tests/constant_propagation/const_field_return_struct.i
@@ -1,5 +1,5 @@
/* run.config
- STDOPT: +"-eva"
+ STDOPT: #"-eva"
*/
struct S {
diff --git a/tests/constant_propagation/const_globals.c b/tests/constant_propagation/const_globals.c
index c0661d55d4f2a4006517e7881ef04f181f7ea550..ccbe6326b6dbacd1967309c2c236e8791f7d54b9 100644
--- a/tests/constant_propagation/const_globals.c
+++ b/tests/constant_propagation/const_globals.c
@@ -1,7 +1,7 @@
/* run.config
+ PLUGIN:
OPT: -constfold -print -machdep x86_32
*/
-
#include <stddef.h>
typedef const size_t const_size_t;
diff --git a/tests/constant_propagation/const_propagate.c b/tests/constant_propagation/const_propagate.c
index c9a65bcc33bc3291cde3802cb13e8a9dd5d0022b..509ebe2185954346cf60c974496704d1df99b51f 100644
--- a/tests/constant_propagation/const_propagate.c
+++ b/tests/constant_propagation/const_propagate.c
@@ -1,8 +1,8 @@
/* run.config
-PLUGIN: @CONSTANT_PROPAGATION_PLUGINS@ from inout
- OPT: -eva @EVA_OPTIONS@ -deps -out -input -scf
+ OPT: -eva @EVA_OPTIONS@ -deps -out -input -then -scf
OPT: -scf @EVA_OPTIONS@ -main init -cast-from-constant -semantic-const-fold add3
*/
+
int x,y,z, TAB[10];
struct st { int a, b ; } s1, s2;
typedef struct st ST ;
diff --git a/tests/constant_propagation/declaration2.c b/tests/constant_propagation/declaration2.c
index cfde5c962b55e8486361ddbb4d15852764d0f956..aa830c74e4e7671c6ddeca0c028a0040d66426c6 100644
--- a/tests/constant_propagation/declaration2.c
+++ b/tests/constant_propagation/declaration2.c
@@ -1,5 +1,5 @@
/* run.config
- OPT: -eva @EVA_OPTIONS@ -scf
+ OPT: -eva @EVA_OPTIONS@ -then -scf
*/
void f(int *x) { (*x)++; }
diff --git a/tests/constant_propagation/introduction_of_non_explicit_cast.c b/tests/constant_propagation/introduction_of_non_explicit_cast.c
index bd95af567f0900dc0a96bf490449d0af886ffd6a..8db347548927dc2510a5e2eb8df566d51fa89d1a 100644
--- a/tests/constant_propagation/introduction_of_non_explicit_cast.c
+++ b/tests/constant_propagation/introduction_of_non_explicit_cast.c
@@ -1,8 +1,9 @@
/* run.config
- MODULE: @PTEST_NAME@
+ MODULE: @PTEST_NAME@
OPT: -eva @EVA_OPTIONS@ -deps
*/
+
int x,y,z;
int TAB[10];
struct st { int a, b ; } s1, s2;
diff --git a/tests/constant_propagation/oracle/const_propagate.0.res.oracle b/tests/constant_propagation/oracle/const_propagate.0.res.oracle
index db357d9854128a8478c40bb11cd1c3c131b85360..72a698cc3999064713e38b479d33ae68636600ae 100644
--- a/tests/constant_propagation/oracle/const_propagate.0.res.oracle
+++ b/tests/constant_propagation/oracle/const_propagate.0.res.oracle
@@ -128,6 +128,107 @@
p ∈ {{ &x }}
q ∈ {{ &x ; &y }}
yy ∈ {7}
+[from] Computing for function add3
+[from] Done for function add3
+[from] Computing for function init
+[from] Done for function init
+[from] Computing for function test_float_double
+[from] Done for function test_float_double
+[from] Computing for function test_ptr
+[from] Done for function test_ptr
+[from] Computing for function test_struct
+[from] Done for function test_struct
+[from] Computing for function test_struct_ptr
+[from] Done for function test_struct_ptr
+[from] Computing for function test_tab
+[from] Done for function test_tab
+[from] Computing for function test_ull
+[from] Done for function test_ull
+[from] Computing for function main
+[from] Done for function main
+[from] ====== DEPENDENCIES COMPUTED ======
+ These dependencies hold at termination for the executions that terminate:
+[from] Function add3:
+ \result FROM v1; v2; v3
+[from] Function init:
+ x FROM v
+ y FROM \nothing
+ z FROM v
+ \result FROM \nothing
+[from] Function test_float_double:
+ f1 FROM f0
+ f2 FROM f0
+ f3 FROM f0
+ d1 FROM d0
+ d2 FROM d0
+ d3 FROM d0
+[from] Function test_ptr:
+ x FROM v
+ \result FROM \nothing
+[from] Function test_struct:
+ s1 FROM \nothing
+ s2 FROM \nothing
+[from] Function test_struct_ptr:
+ \result FROM \nothing
+[from] Function test_tab:
+ TAB[1] FROM TAB[2]; s1.b; s2.b
+ [4..5] FROM v
+ s2.b FROM s2.b
+[from] Function test_ull:
+ ull FROM ull
+[from] Function main:
+ x FROM \nothing
+ y FROM \nothing
+ z FROM a
+ TAB[1] FROM TAB[2]
+ [4..5] FROM \nothing
+ s1 FROM \nothing
+ s2 FROM \nothing
+ ull FROM ull
+ f1 FROM f0
+ f2 FROM f0
+ f3 FROM f0
+ d1 FROM d0
+ d2 FROM d0
+ d3 FROM d0
+[from] ====== END OF DEPENDENCIES ======
+[inout] Out (internal) for function add3:
+ __retres
+[inout] Inputs for function add3:
+ \nothing
+[inout] Out (internal) for function init:
+ x; y; z; zero; sept; z1
+[inout] Inputs for function init:
+ x; y; z
+[inout] Out (internal) for function test_float_double:
+ f1; f2; f3; d1; d2; d3
+[inout] Inputs for function test_float_double:
+ f0; f1; f2; d0; d1; d2
+[inout] Out (internal) for function test_ptr:
+ x; p; s; decal; __retres
+[inout] Inputs for function test_ptr:
+ \nothing
+[inout] Out (internal) for function test_struct:
+ s1; s2; s
+[inout] Inputs for function test_struct:
+ s1.a
+[inout] Out (internal) for function test_struct_ptr:
+ q; __retres
+[inout] Inputs for function test_struct_ptr:
+ \nothing
+[inout] Out (internal) for function test_tab:
+ TAB{[1]; [4..5]}; s2.b; r; q; decal
+[inout] Inputs for function test_tab:
+ TAB[2]; s1.b; s2.b
+[inout] Out (internal) for function test_ull:
+ ull
+[inout] Inputs for function test_ull:
+ ull
+[inout] Out (internal) for function main:
+ x; y; z; TAB{[1]; [4..5]}; s1; s2; ull; f1; f2; f3; d1; d2; d3; b;
+ p; q; tmp_1; yy
+[inout] Inputs for function main:
+ x; y; z; TAB[2]; s1; s2.b; ull; f0; f1; f2; d0; d1; d2
[scf] beginning constant propagation
/* Generated by Frama-C */
struct st {
@@ -257,104 +358,3 @@ void main(int a)
[scf] constant propagation done
-[from] Computing for function add3
-[from] Done for function add3
-[from] Computing for function init
-[from] Done for function init
-[from] Computing for function test_float_double
-[from] Done for function test_float_double
-[from] Computing for function test_ptr
-[from] Done for function test_ptr
-[from] Computing for function test_struct
-[from] Done for function test_struct
-[from] Computing for function test_struct_ptr
-[from] Done for function test_struct_ptr
-[from] Computing for function test_tab
-[from] Done for function test_tab
-[from] Computing for function test_ull
-[from] Done for function test_ull
-[from] Computing for function main
-[from] Done for function main
-[from] ====== DEPENDENCIES COMPUTED ======
- These dependencies hold at termination for the executions that terminate:
-[from] Function add3:
- \result FROM v1; v2; v3
-[from] Function init:
- x FROM v
- y FROM \nothing
- z FROM v
- \result FROM \nothing
-[from] Function test_float_double:
- f1 FROM f0
- f2 FROM f0
- f3 FROM f0
- d1 FROM d0
- d2 FROM d0
- d3 FROM d0
-[from] Function test_ptr:
- x FROM v
- \result FROM \nothing
-[from] Function test_struct:
- s1 FROM \nothing
- s2 FROM \nothing
-[from] Function test_struct_ptr:
- \result FROM \nothing
-[from] Function test_tab:
- TAB[1] FROM TAB[2]; s1.b; s2.b
- [4..5] FROM v
- s2.b FROM s2.b
-[from] Function test_ull:
- ull FROM ull
-[from] Function main:
- x FROM \nothing
- y FROM \nothing
- z FROM a
- TAB[1] FROM TAB[2]
- [4..5] FROM \nothing
- s1 FROM \nothing
- s2 FROM \nothing
- ull FROM ull
- f1 FROM f0
- f2 FROM f0
- f3 FROM f0
- d1 FROM d0
- d2 FROM d0
- d3 FROM d0
-[from] ====== END OF DEPENDENCIES ======
-[inout] Out (internal) for function add3:
- __retres
-[inout] Inputs for function add3:
- \nothing
-[inout] Out (internal) for function init:
- x; y; z; zero; sept; z1
-[inout] Inputs for function init:
- x; y; z
-[inout] Out (internal) for function test_float_double:
- f1; f2; f3; d1; d2; d3
-[inout] Inputs for function test_float_double:
- f0; f1; f2; d0; d1; d2
-[inout] Out (internal) for function test_ptr:
- x; p; s; decal; __retres
-[inout] Inputs for function test_ptr:
- \nothing
-[inout] Out (internal) for function test_struct:
- s1; s2; s
-[inout] Inputs for function test_struct:
- s1.a
-[inout] Out (internal) for function test_struct_ptr:
- q; __retres
-[inout] Inputs for function test_struct_ptr:
- \nothing
-[inout] Out (internal) for function test_tab:
- TAB{[1]; [4..5]}; s2.b; r; q; decal
-[inout] Inputs for function test_tab:
- TAB[2]; s1.b; s2.b
-[inout] Out (internal) for function test_ull:
- ull
-[inout] Inputs for function test_ull:
- ull
-[inout] Out (internal) for function main:
- x; y; z; TAB{[1]; [4..5]}; s1; s2; ull; f1; f2; f3; d1; d2; d3; b;
- p; q; tmp_1; yy
-[inout] Inputs for function main:
- x; y; z; TAB[2]; s1; s2.b; ull; f0; f1; f2; d0; d1; d2
diff --git a/tests/constant_propagation/oracle/introduction_of_non_explicit_cast.res.oracle b/tests/constant_propagation/oracle/introduction_of_non_explicit_cast.res.oracle
index 6473a33045386585cd8c1f35f8466b23286323e4..6d5bb7f553d0a1fb538be91ad3bf27f160c15220 100644
--- a/tests/constant_propagation/oracle/introduction_of_non_explicit_cast.res.oracle
+++ b/tests/constant_propagation/oracle/introduction_of_non_explicit_cast.res.oracle
@@ -11,41 +11,41 @@
s2 ∈ {0}
ull ∈ {0}
[eva] computing for function test_ull <- main.
- Called from introduction_of_non_explicit_cast.c:68.
+ Called from introduction_of_non_explicit_cast.c:69.
[eva] Recording results for test_ull
[eva] Done for function test_ull
[eva] computing for function test_struct <- main.
- Called from introduction_of_non_explicit_cast.c:69.
+ Called from introduction_of_non_explicit_cast.c:70.
[eva] Recording results for test_struct
[eva] Done for function test_struct
[eva] computing for function test_struct_ptr <- main.
- Called from introduction_of_non_explicit_cast.c:70.
+ Called from introduction_of_non_explicit_cast.c:71.
[eva] Recording results for test_struct_ptr
[eva] Done for function test_struct_ptr
[eva] computing for function test_tab <- main.
- Called from introduction_of_non_explicit_cast.c:71.
+ Called from introduction_of_non_explicit_cast.c:72.
[eva] Recording results for test_tab
[eva] Done for function test_tab
[eva] computing for function init <- main.
- Called from introduction_of_non_explicit_cast.c:73.
+ Called from introduction_of_non_explicit_cast.c:74.
[eva] computing for function add3 <- init <- main.
- Called from introduction_of_non_explicit_cast.c:57.
+ Called from introduction_of_non_explicit_cast.c:58.
[eva] Recording results for add3
[eva] Done for function add3
[eva] Recording results for init
[eva] Done for function init
[eva] computing for function add3 <- main.
- Called from introduction_of_non_explicit_cast.c:74.
+ Called from introduction_of_non_explicit_cast.c:75.
[eva] Recording results for add3
[eva] Done for function add3
[eva] computing for function test_ptr <- main.
- Called from introduction_of_non_explicit_cast.c:76.
+ Called from introduction_of_non_explicit_cast.c:77.
[eva] Recording results for test_ptr
[eva] Done for function test_ptr
-[eva] introduction_of_non_explicit_cast.c:77: assertion got status valid.
-[eva:alarm] introduction_of_non_explicit_cast.c:80: Warning:
+[eva] introduction_of_non_explicit_cast.c:78: assertion got status valid.
+[eva:alarm] introduction_of_non_explicit_cast.c:81: Warning:
assertion got status unknown.
-[eva] introduction_of_non_explicit_cast.c:81: assertion got status valid.
+[eva] introduction_of_non_explicit_cast.c:82: assertion got status valid.
[eva] Recording results for main
[eva] done for function main
[eva] ====== VALUES COMPUTED ======
diff --git a/tests/constant_propagation/struct_field.i b/tests/constant_propagation/struct_field.i
index 97e18ced9849b044b3f42186a7082b89a9d1aacd..6f67d14b78e0493b5ae3e93f6a272df2d485785d 100644
--- a/tests/constant_propagation/struct_field.i
+++ b/tests/constant_propagation/struct_field.i
@@ -1,5 +1,5 @@
/* run.config
- STDOPT: +"-eva"
+ STDOPT: #"-eva"
*/
struct st {
diff --git a/tests/constant_propagation/test_config b/tests/constant_propagation/test_config
index b3a8965ab1afefa926424d9f4730c5832a90b05a..a0809882b6a8268c6431a2d0f1c71fb4d00042c3 100644
--- a/tests/constant_propagation/test_config
+++ b/tests/constant_propagation/test_config
@@ -1,3 +1,3 @@
-MACRO: CONSTANT_PROPAGATION_PLUGINS constant_propagation eva,scope
+MACRO: CONSTANT_PROPAGATION_PLUGINS constant_propagation @EVA_MAIN_PLUGINS@ from,inout
PLUGIN: @CONSTANT_PROPAGATION_PLUGINS@
-OPT: -journal-disable -scf @EVA_OPTIONS@ -machdep x86_32
+OPT: @EVA_OPTIONS@ -machdep x86_32 -then -scf
diff --git a/tests/crowbar/constfold.ml b/tests/crowbar/constfold.ml
index b98c69153c173ba6dd2cbae5cf252e3459196a44..91de9a16715a5ca908c76349ab5a0cc727b47c78 100644
--- a/tests/crowbar/constfold.ml
+++ b/tests/crowbar/constfold.ml
@@ -206,7 +206,7 @@ let run typ expr =
end;
File.prepare_cil_file cil;
Kernel.MainFunction.set "f";
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
let kf = Globals.Functions.find_by_name "f" in
let r = Globals.Vars.find_from_astinfo "result" Cil_types.VGlobal in
let ret = Kernel_function.find_return kf in
diff --git a/tests/fc_script/build-callgraph.i b/tests/fc_script/build-callgraph.i
index 7ec5a976aeb0b98d696992b666850cb7c6e497fa..be8f7b96630a6bac9c200980026fd29f01ddb347 100644
--- a/tests/fc_script/build-callgraph.i
+++ b/tests/fc_script/build-callgraph.i
@@ -1,6 +1,6 @@
/* run.config
NOFRAMAC: testing frama-c-script, not frama-c itself
- EXECNOW: LOG build-callgraph.res LOG build-callgraph.err %{bin:frama-c-script} heuristic-print-callgraph @PTEST_DIR@/@PTEST_NAME@.i > @PTEST_RESULT@/build-callgraph.res 2> @PTEST_RESULT@/build-callgraph.err
+ EXECNOW: LOG build-callgraph.res LOG build-callgraph.err PTESTS_TESTING=1 %{bin:frama-c-script} heuristic-print-callgraph @PTEST_DIR@/@PTEST_NAME@.i > @PTEST_RESULT@/build-callgraph.res 2> @PTEST_RESULT@/build-callgraph.err
*/
#include <stdio.h>
diff --git a/tests/fc_script/estimate_difficulty.i b/tests/fc_script/estimate_difficulty.i
new file mode 100644
index 0000000000000000000000000000000000000000..23b63dd6c5250076eb5eb8e74f0197b0bd9a12cc
--- /dev/null
+++ b/tests/fc_script/estimate_difficulty.i
@@ -0,0 +1,28 @@
+/* run.config
+ NOFRAMAC: testing frama-c-script, not frama-c itself
+ EXECNOW: LOG @PTEST_NAME@.res LOG @PTEST_NAME@.err PTESTS_TESTING=1 %{bin:frama-c-script} estimate-difficulty @PTEST_FILE@ > @PTEST_NAME@.res 2> @PTEST_NAME@.err
+*/
+
+// these includes are not actually used by the compiler
+// (this is a preprocessed file), but analyzed by the script
+#include <sys/socket.h>
+# include <complex.h>
+ # include <langinfo.h>
+#include <sys/socket.h>
+
+void g() {
+ int g = 42;
+}
+
+void f() {
+ if (v) f();
+ else g();
+}
+
+int main() {
+ va_arg(); // no warning: it is a macro, not a function
+ setjmp(); // warning: problematic
+ strlen(); // no warning
+ ccosl(); // warning: neither code nor spec
+ dprintf(); // no warning: neither code nor spec, but handled by Variadic
+}
diff --git a/tests/fc_script/list_functions.i b/tests/fc_script/list_functions.i
index 448f97a30909dda8da6e3d773ed34336bf46e4a6..225f70d0a90bc31504e675d9bbaa7bc70503d7f8 100644
--- a/tests/fc_script/list_functions.i
+++ b/tests/fc_script/list_functions.i
@@ -15,5 +15,5 @@
DEPS: @PTEST_DEPS@ @PTEST_DIR@/build-callgraph.i
DEPS: @PTEST_DEPS@ @PTEST_DIR@/recursions.i
- EXECNOW: LOG heuristic_list_functions.res LOG heuristic_list_functions.err %{bin:frama-c-script} heuristic-list-functions true true @PTEST_DEPS@ > @PTEST_RESULT@/heuristic_list_functions.res 2> @PTEST_RESULT@/heuristic_list_functions.err
+ EXECNOW: LOG heuristic_list_functions.res LOG heuristic_list_functions.err PTESTS_TESTING=1 %{bin:frama-c-script} heuristic-list-functions true true @PTEST_DEPS@ > @PTEST_RESULT@/heuristic_list_functions.res 2> @PTEST_RESULT@/heuristic_list_functions.err
*/
diff --git a/tests/fc_script/main.c b/tests/fc_script/main.c
index d6526f2b234c2d45c42862eaf1d7c231c85f268f..cb1a6f9adc2a5443691c4809e7721d42a368ee3e 100644
--- a/tests/fc_script/main.c
+++ b/tests/fc_script/main.c
@@ -1,16 +1,15 @@
/* run.config
NOFRAMAC: testing frama-c-script, not frama-c itself
- DEPS: for-find-fun2.c for-find-fun.c main.c main2.c main3.c
- EXECNOW: LOG GNUmakefile LOG make_template.res LOG make_template.err PTESTS_TESTING= %{bin:frama-c-script} -C @PTEST_DIR@ make-template $(basename @PTEST_RESULT@) < %{dep:@PTEST_DIR@/make_template.input} > @PTEST_RESULT@/make_template.res 2> @PTEST_RESULT@/make_template.err
+ COMMENT: the 'build' command cannot be tested because it requires 'glub'.
DEPS: main2.c main3.c main.c
- EXECNOW: LOG list_files.res LOG list_files.err %{bin:frama-c-script} list-files %{dep:@PTEST_DIR@/list_files.json} > @PTEST_RESULT@/list_files.res 2> @PTEST_RESULT@/list_files.err
+ EXECNOW: LOG list_files.res LOG list_files.err PTESTS_TESTING=1 %{bin:frama-c-script} list-files %{dep:@PTEST_DIR@/list_files.json} > @PTEST_RESULT@/list_files.res 2> @PTEST_RESULT@/list_files.err
DEPS: for-find-fun2.c for-find-fun.c for-list-functions.c main2.c main3.c main.c make-wrapper2.c make-wrapper3.c make-wrapper.c
- EXECNOW: LOG find_fun1.res LOG find_fun1.err %{bin:frama-c-script} find-fun main2 @PTEST_DIR@ > @PTEST_RESULT@/find_fun1.res 2> @PTEST_RESULT@/find_fun1.err
- EXECNOW: LOG find_fun2.res LOG find_fun2.err %{bin:frama-c-script} find-fun main3 @PTEST_DIR@ > @PTEST_RESULT@/find_fun2.res 2> @PTEST_RESULT@/find_fun2.err
- EXECNOW: LOG find_fun3.res LOG find_fun3.err %{bin:frama-c-script} find-fun false_positive @PTEST_DIR@ > @PTEST_RESULT@/find_fun3.res 2> @PTEST_RESULT@/find_fun3.err
+ EXECNOW: LOG find_fun1.res LOG find_fun1.err PTESTS_TESTING=1 %{bin:frama-c-script} find-fun main2 @PTEST_DIR@ > @PTEST_RESULT@/find_fun1.res 2> @PTEST_RESULT@/find_fun1.err
+ EXECNOW: LOG find_fun2.res LOG find_fun2.err PTESTS_TESTING=1 %{bin:frama-c-script} find-fun main3 @PTEST_DIR@ > @PTEST_RESULT@/find_fun2.res 2> @PTEST_RESULT@/find_fun2.err
+ EXECNOW: LOG find_fun3.res LOG find_fun3.err PTESTS_TESTING=1 %{bin:frama-c-script} find-fun false_positive @PTEST_DIR@ > @PTEST_RESULT@/find_fun3.res 2> @PTEST_RESULT@/find_fun3.err
DEPS:
- EXECNOW: LOG list_functions.res LOG list_functions.err %{bin:frama-c-script} list-functions %{dep:@PTEST_DIR@/for-find-fun2.c} %{dep:@PTEST_DIR@/for-list-functions.c} > @PTEST_RESULT@/list_functions.res 2> @PTEST_RESULT@/list_functions.err
- EXECNOW: LOG list_functions2.res LOG list_functions2.err LOG list_functions2.json %{bin:frama-c-script} list-functions %{dep:@PTEST_DIR@/for-find-fun2.c} %{dep:@PTEST_DIR@/for-list-functions.c -list-functions-declarations} -list-functions-output @PTEST_RESULT@/list_functions2.json -list-functions-debug 1 > @PTEST_RESULT@/list_functions2.res 2> @PTEST_RESULT@/list_functions2.err
+ EXECNOW: LOG list_functions.res LOG list_functions.err PTESTS_TESTING=1 %{bin:frama-c-script} list-functions %{dep:@PTEST_DIR@/for-find-fun2.c} %{dep:@PTEST_DIR@/for-list-functions.c} > @PTEST_RESULT@/list_functions.res 2> @PTEST_RESULT@/list_functions.err
+ EXECNOW: LOG list_functions2.res LOG list_functions2.err LOG list_functions2.json PTESTS_TESTING=1 %{bin:frama-c-script} list-functions %{dep:@PTEST_DIR@/for-find-fun2.c} %{dep:@PTEST_DIR@/for-list-functions.c -list-functions-declarations} -list-functions-output @PTEST_RESULT@/list_functions2.json -list-functions-debug 1 > @PTEST_RESULT@/list_functions2.res 2> @PTEST_RESULT@/list_functions2.err
*/
diff --git a/tests/fc_script/make-wrapper.c b/tests/fc_script/make-wrapper.c
index 89700bc4aa9ecaac4668c8010ebc73edec3d2c26..0f7d0709e6eda239b3a706424d82b2f3b5d9cf00 100644
--- a/tests/fc_script/make-wrapper.c
+++ b/tests/fc_script/make-wrapper.c
@@ -2,7 +2,7 @@
MACRO: RM_TMP_DIR rm -rf make-for-make-wrapper.parse make-for-make-wrapper.eva
NOFRAMAC: testing frama-c-script
COMMENT: in case of errors, remove the 'grep' part to get the full output
- EXECNOW: LOG make-wrapper.res LOG make-wrapper.err (cd @PTEST_DIR@ && touch make-wrapper2.c && touch make-wrapper3.c && @RM_TMP_DIR@ && FRAMAC=%{bin:frama-c} %{bin:frama-c-script} make-wrapper --make-dir . -f make-for-make-wrapper.mk | grep -A999999 "make-wrapper recommendations" && @RM_TMP_DIR@) > @PTEST_RESULT@/make-wrapper.res 2> @PTEST_RESULT@/make-wrapper.err
+ EXECNOW: LOG make-wrapper.res LOG make-wrapper.err (cd @PTEST_DIR@ && touch make-wrapper2.c && touch make-wrapper3.c && @RM_TMP_DIR@ && FRAMAC=%{bin:frama-c} PTESTS_TESTING=1 %{bin:frama-c-script} make-wrapper --make-dir . -f make-for-make-wrapper.mk | grep -A999999 "make-wrapper recommendations" && @RM_TMP_DIR@) > @PTEST_RESULT@/make-wrapper.res 2> @PTEST_RESULT@/make-wrapper.err
*/
int defined(int a);
diff --git a/tests/fc_script/make_template.input b/tests/fc_script/make_template.input
deleted file mode 100644
index 6963df94935110ccdf0218b25973e3348c9e1947..0000000000000000000000000000000000000000
--- a/tests/fc_script/make_template.input
+++ /dev/null
@@ -1,10 +0,0 @@
-y
-fc_script_main
-for-find*.c main*.c
-y
-y
-y
-invalid_machdep
-n
-x86_64
-y
diff --git a/tests/fc_script/oracle/make_template.err b/tests/fc_script/oracle/estimate_difficulty.err
similarity index 100%
rename from tests/fc_script/oracle/make_template.err
rename to tests/fc_script/oracle/estimate_difficulty.err
diff --git a/tests/fc_script/oracle/estimate_difficulty.res b/tests/fc_script/oracle/estimate_difficulty.res
new file mode 100644
index 0000000000000000000000000000000000000000..30f1b80034aa927ce043a821e1aba9c17be0a536
--- /dev/null
+++ b/tests/fc_script/oracle/estimate_difficulty.res
@@ -0,0 +1,10 @@
+Building callgraph...
+Computing data about libc/POSIX functions...
+[recursion] found recursive cycle near estimate_difficulty.i:18: f -> f
+Estimating difficulty for 7 function calls...
+- warning: ccosl (POSIX) has neither code nor spec in Frama-C's libc
+- warning: setjmp (POSIX) is known to be problematic for code analysis
+Function-related warnings: 2
+Estimating difficulty for 3 '#include <header>' directives...
+- WARNING: included header <complex.h> is explicitly unsupported by Frama-C
+Header-related warnings: 1
diff --git a/tests/fc_script/oracle/find_fun1.res b/tests/fc_script/oracle/find_fun1.res
index f16fc61d2be3d40fae3e6b45961875fc0e7f0642..58bf804e3c123e33f21c6761b63dcefa26e2e129 100644
--- a/tests/fc_script/oracle/find_fun1.res
+++ b/tests/fc_script/oracle/find_fun1.res
@@ -1,4 +1,4 @@
-Looking for 'main2' inside 14 file(s)...
+Looking for 'main2' inside 15 file(s)...
Possible declarations for function 'main2' in the following file(s):
for-find-fun.c
Possible definitions for function 'main2' in the following file(s):
diff --git a/tests/fc_script/oracle/find_fun2.res b/tests/fc_script/oracle/find_fun2.res
index fda8345bfc224212d8b8d653d325ed83b7acac7c..d868795ee4e11b8858e75185cfd91d68ea8a24e7 100644
--- a/tests/fc_script/oracle/find_fun2.res
+++ b/tests/fc_script/oracle/find_fun2.res
@@ -1,4 +1,4 @@
-Looking for 'main3' inside 14 file(s)...
+Looking for 'main3' inside 15 file(s)...
Possible declarations for function 'main3' in the following file(s):
for-find-fun2.c
Possible definitions for function 'main3' in the following file(s):
diff --git a/tests/fc_script/oracle/find_fun3.res b/tests/fc_script/oracle/find_fun3.res
index 4a42d9117089960eb086c47a8e4b07b44795e3c3..00f4bbc10eab9c20620426e670d9d0cf6b715762 100644
--- a/tests/fc_script/oracle/find_fun3.res
+++ b/tests/fc_script/oracle/find_fun3.res
@@ -1,2 +1,2 @@
-Looking for 'false_positive' inside 14 file(s)...
+Looking for 'false_positive' inside 15 file(s)...
No declaration/definition found for function 'false_positive'
diff --git a/tests/fc_script/oracle/heuristic_list_functions.res b/tests/fc_script/oracle/heuristic_list_functions.res
index c07b868d86a6faa808fac543c9825b4288dc37cd..b9cfea105053534f7a392710bc375f1b5bf61e1b 100644
--- a/tests/fc_script/oracle/heuristic_list_functions.res
+++ b/tests/fc_script/oracle/heuristic_list_functions.res
@@ -7,7 +7,7 @@ for-find-fun2.c:19:21: h (definition)
for-find-fun2.c:28:31: static_fun (definition)
for-list-functions.c:8:15: static_fun (definition)
for-list-functions.c:17:22: k (definition)
-main.c:18:20: main (definition)
+main.c:17:19: main (definition)
main2.c:6:8: fake_main (definition)
main2.c:10:12: domain (definition)
main2.c:14:16: main2 (definition)
diff --git a/tests/fc_script/oracle/make_template.res b/tests/fc_script/oracle/make_template.res
deleted file mode 100644
index 4a3ef8e2f6c94cc2d096721b2e93d5f759fc82b3..0000000000000000000000000000000000000000
--- a/tests/fc_script/oracle/make_template.res
+++ /dev/null
@@ -1,16 +0,0 @@
-Preparing template: GNUmakefile
-Running ptests: setting up mock files...
-warning: GNUmakefile already exists. Overwrite? [y/N] Main target name: Source files (default: **/*.c): The following sources were matched (relative to .):
- ./for-find-fun.c
- ./for-find-fun2.c
- ./main.c # defines 'main'
- ./main2.c
- ./main3.c # defines 'main'
-
-warning: 'main' seems to be defined multiple times.
-Is this ok? [Y/n] compile_commands.json exists, add option -json-compilation-database? [Y/n] Add stub for function main (only needed if it uses command-line arguments)? [y/N] Please define the architectural model (machdep) of the target machine.
-Known machdeps: x86_16 x86_32 x86_64 gcc_x86_16 gcc_x86_32 gcc_x86_64 ppc_32 msvc_x86_64
-Please enter the machdep [x86_64]: 'invalid_machdep' is not a standard machdep. Proceed anyway? [y/N]Please enter the machdep [x86_64]: warning: fc_stubs.c already exists. Overwrite? [y/N] Created stub for main function: fc_stubs.c
-Template created: GNUmakefile
-Path to Frama-C binaries written to: path.mk
-Running ptests: cleaning up after tests...
diff --git a/tests/fc_script/recursions.i b/tests/fc_script/recursions.i
index 7d7cbfe0daab55000e646e4f72ada4a7a4d6525a..1d1f993cf17245094b713370b8ab32bcc941f2e4 100644
--- a/tests/fc_script/recursions.i
+++ b/tests/fc_script/recursions.i
@@ -1,6 +1,6 @@
/* run.config
NOFRAMAC: testing frama-c-script, not frama-c itself
- EXECNOW: LOG recursions.res LOG recursions.err %{bin:frama-c-script} heuristic-detect-recursion @PTEST_FILE@ > @PTEST_RESULT@/recursions.res 2> @PTEST_RESULT@/recursions.err
+ EXECNOW: LOG recursions.res LOG recursions.err PTESTS_TESTING=1 %{bin:frama-c-script} heuristic-detect-recursion @PTEST_FILE@ > @PTEST_RESULT@/recursions.res 2> @PTEST_RESULT@/recursions.err
*/
volatile int v;
diff --git a/tests/libc/err_h.c b/tests/libc/err_h.c
new file mode 100644
index 0000000000000000000000000000000000000000..660e350ab1c0ecaa0f00f381e1a8fd0ee19dbceb
--- /dev/null
+++ b/tests/libc/err_h.c
@@ -0,0 +1,65 @@
+/* run.config
+ STDOPT:
+*/
+#include <err.h>
+#include <stdarg.h>
+
+volatile int nondet;
+
+void vaw(const char *fmt, ...) {
+ va_list ap;
+ va_start(ap, fmt);
+ vwarn(fmt, ap);
+ va_end(ap);
+}
+
+void vawx(const char *fmt, ...) {
+ va_list ap;
+ va_start(ap, fmt);
+ vwarnx(fmt, ap);
+ va_end(ap);
+}
+
+void vae(int eval, const char *fmt, ...) {
+ va_list ap;
+ va_start(ap, fmt);
+ verr(eval, fmt, ap);
+ va_end(ap);
+}
+
+void vaex(int eval, const char *fmt, ...) {
+ va_list ap;
+ va_start(ap, fmt);
+ verrx(eval, fmt, ap);
+ va_end(ap);
+}
+
+int main() {
+ int a = 1, *p = 2;
+ warn(0);
+ warn(0, a);
+ warnx("%d", a);
+ vaw("%s", "warn");
+ vawx(0);
+ if (nondet) {
+ err(0, 0);
+ //@ assert unreachable: \false;
+ }
+ if (nondet) {
+ err(1, 0, a);
+ //@ assert unreachable: \false;
+ }
+ if (nondet) {
+ errx(2, "%d", a);
+ //@ assert unreachable: \false;
+ }
+ if (nondet) {
+ vae(0, 0);
+ //@ assert unreachable: \false;
+ }
+ if (nondet) {
+ vaex(-1, "nogood %d", a);
+ //@ assert unreachable: \false;
+ }
+ return 0;
+}
diff --git a/tests/libc/fc_libc.c b/tests/libc/fc_libc.c
index debe6f55696331ced5bb625a11b285dbec6a506c..907602cbe0fa42bd1736453a294949625e7a6e16 100644
--- a/tests/libc/fc_libc.c
+++ b/tests/libc/fc_libc.c
@@ -16,6 +16,8 @@
CMD: %{dep:./check_full_libc.sh} @PTEST_SHARE_DIR@/libc
OPT:
**/
+
+
#define __FC_REG_TEST
// Some functions such as usleep() are only defined for older of POSIX headers,
// while others may be defined only by newer ones, so it is not possible to
@@ -27,16 +29,19 @@
#include "__fc_runtime.c"
+#include "aio.h"
#include "alloca.h"
#include "argz.h"
#include "arpa/inet.h"
#include "assert.h"
#include "byteswap.h"
#include "complex.h"
+#include "cpio.h"
#include "ctype.h"
#include "dirent.h"
#include "dlfcn.h"
#include "endian.h"
+#include "err.h"
#include "errno.h"
#include "__fc_alloc_axiomatic.h"
#include "__fc_builtin.h"
@@ -91,6 +96,7 @@
#include "features.h"
#include "fenv.h"
#include "float.h"
+#include "fmtmsg.h"
#include "fnmatch.h"
#include "ftw.h"
#include "getopt.h"
@@ -107,6 +113,9 @@
#include "malloc.h"
#include "math.h"
#include "memory.h"
+#include "monetary.h"
+#include "mqueue.h"
+#include "ndbm.h"
#include "netdb.h"
#include "net/if.h"
#include "netinet/in.h"
@@ -119,9 +128,11 @@
#include "regex.h"
#include "resolv.h"
#include "sched.h"
+#include "search.h"
#include "semaphore.h"
#include "setjmp.h"
#include "signal.h"
+#include "spawn.h"
#include "stdalign.h"
#include "stdarg.h"
#include "stdatomic.h"
@@ -139,11 +150,13 @@
#include "sys/ipc.h"
#include "syslog.h"
#include "sys/mman.h"
+#include "sys/msg.h"
#include "sys/param.h"
#include "sys/random.h"
#include "sys/resource.h"
#include "sys/select.h"
#include "sys/sendfile.h"
+#include "sys/sem.h"
#include "sys/shm.h"
#include "sys/signal.h"
#include "sys/socket.h"
@@ -158,15 +171,32 @@
#include "sys/utsname.h"
#include "sys/vfs.h"
#include "sys/wait.h"
+#include "tar.h"
#include "termios.h"
#include "tgmath.h"
#include "time.h"
+#include "trace.h"
+#include "ulimit.h"
#include "unistd.h"
#include "utime.h"
#include "utmp.h"
#include "utmpx.h"
+#include "wait.h"
#include "wchar.h"
#include "wctype.h"
+#include "wordexp.h"
+
+
+
+
+
+
+
+
+
+
+
+
void main() {
/* The variables below must be const; otherwise the preconditions
and the assigns/from of some functions will not match */
diff --git a/tests/libc/oracle/argz_c.res.oracle b/tests/libc/oracle/argz_c.res.oracle
index 2ab7a5fe98c630ecf0df81873e164a57a4e0306d..c423da43955093adff4e4b43d14b9e8a0ca50052 100644
--- a/tests/libc/oracle/argz_c.res.oracle
+++ b/tests/libc/oracle/argz_c.res.oracle
@@ -1194,7 +1194,7 @@
[eva:final-states] Values at end of function argz_replace:
__fc_errno ∈ [--..--]
__fc_heap_status ∈ [--..--]
- err ∈ {0; 12}
+ er ∈ {0; 12}
argz ∈
{{ &__realloc_argz_append_l271_1[0] ;
&__realloc_argz_append_l271_7[0] }}
diff --git a/tests/libc/oracle/err_h.res.oracle b/tests/libc/oracle/err_h.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..4c98b5d8c8a1783683870e157b74bc052e4ff502
--- /dev/null
+++ b/tests/libc/oracle/err_h.res.oracle
@@ -0,0 +1,110 @@
+[kernel] Parsing err_h.c (with preprocessing)
+[eva] Analyzing a complete application starting at main
+[eva] Computing initial state
+[eva] Initial state computed
+[eva:initial-state] Values of globals at initialization
+ nondet ∈ [--..--]
+[eva] computing for function warn <- main.
+ Called from err_h.c:39.
+[eva] using specification for function warn
+[eva] err_h.c:39:
+ function warn: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] Done for function warn
+[eva] computing for function warn <- main.
+ Called from err_h.c:40.
+[eva] err_h.c:40:
+ function warn: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] Done for function warn
+[eva] computing for function warnx <- main.
+ Called from err_h.c:41.
+[eva] using specification for function warnx
+[eva] err_h.c:41:
+ function warnx: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] Done for function warnx
+[eva] computing for function vaw <- main.
+ Called from err_h.c:42.
+[eva] computing for function vwarn <- vaw <- main.
+ Called from err_h.c:12.
+[eva] using specification for function vwarn
+[eva] err_h.c:12:
+ function vwarn: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] Done for function vwarn
+[eva] Recording results for vaw
+[eva] Done for function vaw
+[eva] computing for function vawx <- main.
+ Called from err_h.c:43.
+[eva] computing for function vwarnx <- vawx <- main.
+ Called from err_h.c:19.
+[eva] using specification for function vwarnx
+[eva] err_h.c:19:
+ function vwarnx: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] Done for function vwarnx
+[eva] Recording results for vawx
+[eva] Done for function vawx
+[eva] computing for function err <- main.
+ Called from err_h.c:45.
+[eva] using specification for function err
+[eva] err_h.c:45:
+ function err: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] err_h.c:45: Warning:
+ cannot interpret assigns clause \exit_status
+ (unsupported logic var \exit_status); effects will be ignored
+[eva] Done for function err
+[eva] computing for function err <- main.
+ Called from err_h.c:49.
+[eva] err_h.c:49:
+ function err: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] err_h.c:49: Warning:
+ cannot interpret assigns clause \exit_status
+ (unsupported logic var \exit_status); effects will be ignored
+[eva] Done for function err
+[eva] computing for function errx <- main.
+ Called from err_h.c:53.
+[eva] using specification for function errx
+[eva] err_h.c:53:
+ function errx: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] err_h.c:53: Warning:
+ cannot interpret assigns clause \exit_status
+ (unsupported logic var \exit_status); effects will be ignored
+[eva] Done for function errx
+[eva] computing for function vae <- main.
+ Called from err_h.c:57.
+[eva] computing for function verr <- vae <- main.
+ Called from err_h.c:26.
+[eva] using specification for function verr
+[eva] err_h.c:26:
+ function verr: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] err_h.c:26: Warning:
+ cannot interpret assigns clause \exit_status
+ (unsupported logic var \exit_status); effects will be ignored
+[eva] Done for function verr
+[eva] Recording results for vae
+[eva] Done for function vae
+[eva] computing for function vaex <- main.
+ Called from err_h.c:61.
+[eva] computing for function verrx <- vaex <- main.
+ Called from err_h.c:33.
+[eva] using specification for function verrx
+[eva] err_h.c:33:
+ function verrx: precondition 'fmt_valid_read_or_null' got status valid.
+[eva] err_h.c:33: Warning:
+ cannot interpret assigns clause \exit_status
+ (unsupported logic var \exit_status); effects will be ignored
+[eva] Done for function verrx
+[eva] Recording results for vaex
+[eva] Done for function vaex
+[eva] Recording results for main
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function vae:
+ NON TERMINATING FUNCTION
+[eva:final-states] Values at end of function vaex:
+ NON TERMINATING FUNCTION
+[eva:final-states] Values at end of function vaw:
+ ap ∈ {{ &__va_args_14[0] }}
+[eva:final-states] Values at end of function vawx:
+ ap ∈ {{ &__va_args_16[0] }}
+[eva:final-states] Values at end of function main:
+ a ∈ {1}
+ p ∈ {2}
+ __retres ∈ {0}
diff --git a/tests/libc/oracle/fc_libc.0.res.oracle b/tests/libc/oracle/fc_libc.0.res.oracle
index d308df9aa26a57c4d2d2371b56e7d001117a1614..1309a406e2983d2ba843ca0103d55413f512e366 100644
--- a/tests/libc/oracle/fc_libc.0.res.oracle
+++ b/tests/libc/oracle/fc_libc.0.res.oracle
@@ -5,10 +5,10 @@
[eva] Initial state computed
[eva:initial-state] Values of globals at initialization
-[eva] fc_libc.c:173: assertion got status valid.
-[eva] fc_libc.c:174: assertion got status valid.
-[eva] fc_libc.c:175: assertion got status valid.
-[eva] fc_libc.c:176: assertion got status valid.
+[eva] fc_libc.c:203: assertion got status valid.
+[eva] fc_libc.c:204: assertion got status valid.
+[eva] fc_libc.c:205: assertion got status valid.
+[eva] fc_libc.c:206: assertion got status valid.
[eva] Recording results for main
[eva] done for function main
[eva] ====== VALUES COMPUTED ======
@@ -32,6 +32,7 @@
#include "ctype.c"
#include "ctype.h"
#include "dirent.h"
+#include "err.h"
#include "errno.c"
#include "errno.h"
#include "fcntl.h"
diff --git a/tests/libc/oracle/fc_libc.1.res.oracle b/tests/libc/oracle/fc_libc.1.res.oracle
index d01d8094eec109f870f833fb1f9140852bfffcfd..703535ed601a795d89b306eadc7e5bd34a338857 100644
--- a/tests/libc/oracle/fc_libc.1.res.oracle
+++ b/tests/libc/oracle/fc_libc.1.res.oracle
@@ -2047,7 +2047,7 @@ static void str_append(char **to, size_t *to_len, char const *buf,
error_t argz_replace(char **argz, size_t *argz_len, char const *str,
char const *with, unsigned int *replace_count)
{
- error_t err = 0;
+ error_t er = 0;
if (str)
if (*str) {
char *arg = (char *)0;
@@ -2059,7 +2059,7 @@ error_t argz_replace(char **argz, size_t *argz_len, char const *str,
size_t str_len = strlen(str);
size_t with_len = strlen(with);
while (1) {
- if (! err) {
+ if (! er) {
arg = argz_next((char const *)src,src_len,(char const *)arg);
if (! arg) break;
}
@@ -2094,23 +2094,23 @@ error_t argz_replace(char **argz, size_t *argz_len, char const *str,
}
if (to) {
if (delayed_copy) {
- if (arg > src) err = argz_append(& dst,& dst_len,
- (char const *)src,
- (unsigned int)(arg - src));
+ if (arg > src) er = argz_append(& dst,& dst_len,
+ (char const *)src,
+ (unsigned int)(arg - src));
delayed_copy = 0;
}
- if (! err) err = argz_add(& dst,& dst_len,(char const *)to);
+ if (! er) er = argz_add(& dst,& dst_len,(char const *)to);
free((void *)to);
}
- else err = 12;
+ else er = 12;
if (replace_count) (*replace_count) ++;
}
else
- if (! delayed_copy) err = argz_add(& dst,& dst_len,
- (char const *)arg);
+ if (! delayed_copy) er = argz_add(& dst,& dst_len,
+ (char const *)arg);
}
}
- if (! err) {
+ if (! er) {
if (! delayed_copy) {
free((void *)src);
*argz = dst;
@@ -2120,7 +2120,7 @@ error_t argz_replace(char **argz, size_t *argz_len, char const *str,
else
if (dst_len > (size_t)0) free((void *)dst);
}
- return err;
+ return er;
}
char *argz_next(char const *argz, size_t argz_len, char const *entry)
@@ -8507,6 +8507,62 @@ extern DIR *opendir(char const *path);
*/
extern struct dirent *readdir(DIR *dirp);
+/*@ requires
+ fmt_valid_read_or_null: valid_read_string(fmt) ∨ fmt ≡ \null;
+ ensures never_terminates: \false;
+
+ assigns \exit_status \from eval;
+ */
+void err(int eval, char const *fmt, void * const *__va_params);
+
+/*@ requires
+ fmt_valid_read_or_null: valid_read_string(fmt) ∨ fmt ≡ \null;
+ ensures never_terminates: \false;
+
+ assigns \exit_status \from eval;
+ */
+void errx(int eval, char const *fmt, void * const *__va_params);
+
+/*@ requires
+ fmt_valid_read_or_null: valid_read_string(fmt) ∨ fmt ≡ \null;
+ assigns \nothing;
+ */
+void warn(char const *fmt, void * const *__va_params);
+
+/*@ requires
+ fmt_valid_read_or_null: valid_read_string(fmt) ∨ fmt ≡ \null;
+ assigns \nothing;
+ */
+void warnx(char const *fmt, void * const *__va_params);
+
+/*@ requires
+ fmt_valid_read_or_null: valid_read_string(fmt) ∨ fmt ≡ \null;
+ ensures never_terminates: \false;
+
+ assigns \exit_status \from eval;
+ */
+void verr(int eval, char const *fmt, va_list args);
+
+/*@ requires
+ fmt_valid_read_or_null: valid_read_string(fmt) ∨ fmt ≡ \null;
+ ensures never_terminates: \false;
+
+ assigns \exit_status \from eval;
+ */
+void verrx(int eval, char const *fmt, va_list args);
+
+/*@ requires
+ fmt_valid_read_or_null: valid_read_string(fmt) ∨ fmt ≡ \null;
+ assigns \nothing;
+ */
+void vwarn(char const *fmt, va_list args);
+
+/*@ requires
+ fmt_valid_read_or_null: valid_read_string(fmt) ∨ fmt ≡ \null;
+ assigns \nothing;
+ */
+void vwarnx(char const *fmt, va_list args);
+
/*@ requires valid_res: \valid(res);
ensures initialization: res: \initialized(\old(res));
ensures res_wrapped: *\old(res) ≡ (int)(\old(a) + \old(b));
diff --git a/tests/libc/oracle/fc_libc.2.res.oracle b/tests/libc/oracle/fc_libc.2.res.oracle
index 1cc0e1c9983f7c6fec519ecfd122f26bb491932a..4bd6354e3b0aafdba95b18b0a671fd8de7c8aebb 100644
--- a/tests/libc/oracle/fc_libc.2.res.oracle
+++ b/tests/libc/oracle/fc_libc.2.res.oracle
@@ -47,21 +47,25 @@
skipping FRAMAC_SHARE/libc/__fc_machdep_linux_shared.h
[kernel] Parsing FRAMAC_SHARE/libc/__fc_select.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/__fc_string_axiomatic.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/aio.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/alloca.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/argz.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/arpa/inet.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/assert.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/byteswap.h (with preprocessing)
skipping FRAMAC_SHARE/libc/complex.h
+[kernel] Parsing FRAMAC_SHARE/libc/cpio.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/ctype.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/dirent.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/dlfcn.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/endian.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/err.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/errno.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/fcntl.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/features.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/fenv.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/float.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/fmtmsg.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/fnmatch.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/ftw.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/getopt.h (with preprocessing)
@@ -78,6 +82,9 @@ skipping FRAMAC_SHARE/libc/complex.h
[kernel] Parsing FRAMAC_SHARE/libc/malloc.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/math.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/memory.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/monetary.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/mqueue.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/ndbm.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/net/if.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/netdb.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/netinet/in.h (with preprocessing)
@@ -90,9 +97,11 @@ skipping FRAMAC_SHARE/libc/complex.h
[kernel] Parsing FRAMAC_SHARE/libc/regex.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/resolv.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sched.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/search.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/semaphore.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/setjmp.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/signal.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/spawn.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/stdalign.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/stdarg.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/stdatomic.h (with preprocessing)
@@ -109,10 +118,12 @@ skipping FRAMAC_SHARE/libc/complex.h
[kernel] Parsing FRAMAC_SHARE/libc/sys/ioctl.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/ipc.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/mman.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/sys/msg.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/param.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/random.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/resource.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/select.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/sys/sem.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/sendfile.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/shm.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/signal.h (with preprocessing)
@@ -129,13 +140,18 @@ skipping FRAMAC_SHARE/libc/complex.h
[kernel] Parsing FRAMAC_SHARE/libc/sys/vfs.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/sys/wait.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/syslog.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/tar.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/termios.h (with preprocessing)
skipping FRAMAC_SHARE/libc/tgmath.h
[kernel] Parsing FRAMAC_SHARE/libc/time.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/trace.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/ulimit.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/unistd.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/utime.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/utmp.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/utmpx.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/wait.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/wchar.h (with preprocessing)
[kernel] Parsing FRAMAC_SHARE/libc/wctype.h (with preprocessing)
+[kernel] Parsing FRAMAC_SHARE/libc/wordexp.h (with preprocessing)
[kernel] Parsing fc_libc.c (with preprocessing)
diff --git a/tests/libc/oracle/search_h.res.oracle b/tests/libc/oracle/search_h.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..4c13bafba7279dc080a6ef0ddf38420223081c44
--- /dev/null
+++ b/tests/libc/oracle/search_h.res.oracle
@@ -0,0 +1,76 @@
+[kernel] Parsing search_h.c (with preprocessing)
+[eva] Analyzing a complete application starting at main
+[eva] Computing initial state
+[eva] Initial state computed
+[eva:initial-state] Values of globals at initialization
+ root ∈ {0}
+[eva] computing for function fgets <- main.
+ Called from search_h.c:25.
+[eva] using specification for function fgets
+[eva:alarm] search_h.c:25: Warning:
+ function fgets: precondition 'valid_stream' got status unknown.
+[eva] search_h.c:25: function fgets: precondition 'room_s' got status valid.
+[eva] Done for function fgets
+[eva] search_h.c:27: Call to builtin strlen
+[eva:alarm] search_h.c:27: Warning:
+ function strlen: precondition 'valid_string_s' got status unknown.
+[eva:alarm] search_h.c:28: Warning:
+ accessing out of bounds index. assert 0 ≤ (int)(length - 1);
+[eva:alarm] search_h.c:28: Warning:
+ accessing uninitialized left-value.
+ assert \initialized(&str[(int)(length - 1)]);
+[eva] search_h.c:30: Call to builtin malloc
+[eva] search_h.c:30: allocating variable __malloc_main_l30
+[eva] computing for function strcpy <- main.
+ Called from search_h.c:31.
+[eva] using specification for function strcpy
+[eva:alarm] search_h.c:31: Warning:
+ function strcpy: precondition 'valid_string_src' got status unknown.
+[eva:alarm] search_h.c:31: Warning:
+ function strcpy: precondition 'room_string' got status unknown.
+[eva] search_h.c:31:
+ function strcpy: precondition 'separation' got status valid.
+[eva] FRAMAC_SHARE/libc/string.h:373:
+ cannot evaluate ACSL term, unsupported ACSL construct: logic function strcmp
+[eva] Done for function strcpy
+[eva:alarm] search_h.c:32: Warning:
+ out of bounds write. assert \valid(&elementptr->count);
+[eva] computing for function tsearch <- main.
+ Called from search_h.c:34.
+[kernel:annot:missing-spec] search_h.c:34: Warning:
+ Neither code nor specification for function tsearch, generating default assigns from the prototype
+[eva] using specification for function tsearch
+[eva:invalid-assigns] search_h.c:34:
+ Completely invalid destination for assigns clause *compar. Ignoring.
+[eva] Done for function tsearch
+[eva] computing for function fprintf_va_1 <- main.
+ Called from search_h.c:36.
+[eva] using specification for function fprintf_va_1
+[eva] search_h.c:36: function fprintf_va_1: precondition got status valid.
+[eva] Done for function fprintf_va_1
+[eva] computing for function exit <- main.
+ Called from search_h.c:38.
+[eva] using specification for function exit
+[eva] Done for function exit
+[eva:alarm] search_h.c:40: Warning:
+ out of bounds read. assert \valid_read((struct element **)node);
+[eva] computing for function twalk <- main.
+ Called from search_h.c:46.
+[kernel:annot:missing-spec] search_h.c:46: Warning:
+ Neither code nor specification for function twalk, generating default assigns from the prototype
+[eva] using specification for function twalk
+[eva:invalid-assigns] search_h.c:46:
+ Completely invalid destination for assigns clause *action. Ignoring.
+[eva] Done for function twalk
+[eva] Recording results for main
+[eva] done for function main
+[eva] search_h.c:40: assertion 'Eva,mem_access' got final status invalid.
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ __fc_heap_status ∈ [--..--]
+ str[0..2048] ∈ [--..--] or UNINITIALIZED
+ length ∈ {0}
+ elementptr ∈ UNINITIALIZED
+ node ∈ UNINITIALIZED
+ __retres ∈ {0}
+ S___fc_stderr[0..1] ∈ [--..--]
diff --git a/tests/libc/oracle/spawn_h.res.oracle b/tests/libc/oracle/spawn_h.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..b687f61add5134e4d083b5ebae573336f0840311
--- /dev/null
+++ b/tests/libc/oracle/spawn_h.res.oracle
@@ -0,0 +1,247 @@
+[kernel] Parsing spawn_h.c (with preprocessing)
+[eva] Analyzing a complete application starting at main
+[eva] Computing initial state
+[eva] Initial state computed
+[eva:initial-state] Values of globals at initialization
+ environ ∈ {0}
+[eva] computing for function getopt <- main.
+ Called from spawn_h.c:36.
+[eva] using specification for function getopt
+[eva] Done for function getopt
+[eva] spawn_h.c:36:
+ Assigning imprecise value to opt.
+ The imprecision originates from Library function {spawn_h.c:36}
+[eva] computing for function posix_spawn_file_actions_init <- main.
+ Called from spawn_h.c:43.
+[kernel:annot:missing-spec] spawn_h.c:43: Warning:
+ Neither code nor specification for function posix_spawn_file_actions_init, generating default assigns from the prototype
+[eva] using specification for function posix_spawn_file_actions_init
+[eva] Done for function posix_spawn_file_actions_init
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:45.
+[eva] using specification for function perror
+[eva] spawn_h.c:45:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:45.
+[eva] using specification for function exit
+[eva] Done for function exit
+[eva] computing for function posix_spawn_file_actions_addclose <- main.
+ Called from spawn_h.c:47.
+[kernel:annot:missing-spec] spawn_h.c:47: Warning:
+ Neither code nor specification for function posix_spawn_file_actions_addclose, generating default assigns from the prototype
+[eva] using specification for function posix_spawn_file_actions_addclose
+[eva] Done for function posix_spawn_file_actions_addclose
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:50.
+[eva] spawn_h.c:50:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:50.
+[eva] Done for function exit
+[eva] computing for function posix_spawnattr_init <- main.
+ Called from spawn_h.c:60.
+[kernel:annot:missing-spec] spawn_h.c:60: Warning:
+ Neither code nor specification for function posix_spawnattr_init, generating default assigns from the prototype
+[eva] using specification for function posix_spawnattr_init
+[eva] Done for function posix_spawnattr_init
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:62.
+[eva] spawn_h.c:62:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:62.
+[eva] Done for function exit
+[eva] computing for function posix_spawnattr_setflags <- main.
+ Called from spawn_h.c:63.
+[kernel:annot:missing-spec] spawn_h.c:63: Warning:
+ Neither code nor specification for function posix_spawnattr_setflags, generating default assigns from the prototype
+[eva] using specification for function posix_spawnattr_setflags
+[eva] Done for function posix_spawnattr_setflags
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:65.
+[eva] spawn_h.c:65:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:65.
+[eva] Done for function exit
+[eva] computing for function sigfillset <- main.
+ Called from spawn_h.c:67.
+[eva] using specification for function sigfillset
+[eva] spawn_h.c:67:
+ function sigfillset: precondition 'valid_set' got status valid.
+[eva] Done for function sigfillset
+[eva] computing for function posix_spawnattr_setsigmask <- main.
+ Called from spawn_h.c:68.
+[kernel:annot:missing-spec] spawn_h.c:68: Warning:
+ Neither code nor specification for function posix_spawnattr_setsigmask, generating default assigns from the prototype
+[eva] using specification for function posix_spawnattr_setsigmask
+[eva] Done for function posix_spawnattr_setsigmask
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:70.
+[eva] spawn_h.c:70:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:70.
+[eva] Done for function exit
+[eva] spawn_h.c:36: starting to merge loop iterations
+[eva] computing for function getopt <- main.
+ Called from spawn_h.c:36.
+[eva] Done for function getopt
+[eva] computing for function posix_spawn_file_actions_init <- main.
+ Called from spawn_h.c:43.
+[eva] Done for function posix_spawn_file_actions_init
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:45.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:45.
+[eva] Done for function exit
+[eva] computing for function posix_spawn_file_actions_addclose <- main.
+ Called from spawn_h.c:47.
+[eva] Done for function posix_spawn_file_actions_addclose
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:50.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:50.
+[eva] Done for function exit
+[eva] computing for function posix_spawnattr_init <- main.
+ Called from spawn_h.c:60.
+[eva] Done for function posix_spawnattr_init
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:62.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:62.
+[eva] Done for function exit
+[eva] computing for function posix_spawnattr_setflags <- main.
+ Called from spawn_h.c:63.
+[eva] Done for function posix_spawnattr_setflags
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:65.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:65.
+[eva] Done for function exit
+[eva] computing for function sigfillset <- main.
+ Called from spawn_h.c:67.
+[eva] Done for function sigfillset
+[eva] computing for function posix_spawnattr_setsigmask <- main.
+ Called from spawn_h.c:68.
+[eva] Done for function posix_spawnattr_setsigmask
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:70.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:70.
+[eva] Done for function exit
+[eva:alarm] spawn_h.c:82: Warning:
+ out of bounds read. assert \valid_read(argv + optind);
+[eva] computing for function posix_spawnp <- main.
+ Called from spawn_h.c:82.
+[kernel:annot:missing-spec] spawn_h.c:82: Warning:
+ Neither code nor specification for function posix_spawnp, generating default assigns from the prototype
+[eva] using specification for function posix_spawnp
+[eva] Done for function posix_spawnp
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:85.
+[eva] spawn_h.c:85:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:85.
+[eva] Done for function exit
+[eva] computing for function posix_spawnattr_destroy <- main.
+ Called from spawn_h.c:90.
+[kernel:annot:missing-spec] spawn_h.c:90: Warning:
+ Neither code nor specification for function posix_spawnattr_destroy, generating default assigns from the prototype
+[eva] using specification for function posix_spawnattr_destroy
+[eva] Done for function posix_spawnattr_destroy
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:92.
+[eva] spawn_h.c:92:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:92.
+[eva] Done for function exit
+[eva] computing for function posix_spawn_file_actions_destroy <- main.
+ Called from spawn_h.c:96.
+[kernel:annot:missing-spec] spawn_h.c:96: Warning:
+ Neither code nor specification for function posix_spawn_file_actions_destroy, generating default assigns from the prototype
+[eva] using specification for function posix_spawn_file_actions_destroy
+[eva] Done for function posix_spawn_file_actions_destroy
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:98.
+[eva] spawn_h.c:98:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:98.
+[eva] Done for function exit
+[eva:alarm] spawn_h.c:101: Warning:
+ accessing uninitialized left-value. assert \initialized(&child_pid);
+[eva] computing for function printf_va_1 <- main.
+ Called from spawn_h.c:101.
+[eva] using specification for function printf_va_1
+[eva] spawn_h.c:101: function printf_va_1: precondition got status valid.
+[eva] Done for function printf_va_1
+[eva] computing for function waitpid <- main.
+ Called from spawn_h.c:106.
+[eva] using specification for function waitpid
+[eva] spawn_h.c:106:
+ function waitpid, behavior stat_loc_non_null: precondition 'valid_stat_loc' got status valid.
+[eva] Done for function waitpid
+[eva] computing for function perror <- main.
+ Called from spawn_h.c:108.
+[eva] spawn_h.c:108:
+ function perror: precondition 'valid_string_s' got status valid.
+[eva] Done for function perror
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:108.
+[eva] Done for function exit
+[eva] computing for function printf_va_2 <- main.
+ Called from spawn_h.c:110.
+[eva] using specification for function printf_va_2
+[eva] spawn_h.c:110: function printf_va_2: precondition got status valid.
+[eva] Done for function printf_va_2
+[eva:alarm] spawn_h.c:111: Warning:
+ accessing uninitialized left-value. assert \initialized(&status);
+[eva] computing for function printf_va_3 <- main.
+ Called from spawn_h.c:112.
+[eva] using specification for function printf_va_3
+[eva] spawn_h.c:112: function printf_va_3: precondition got status valid.
+[eva] Done for function printf_va_3
+[eva] computing for function printf_va_4 <- main.
+ Called from spawn_h.c:114.
+[eva] using specification for function printf_va_4
+[eva] spawn_h.c:114: function printf_va_4: precondition got status valid.
+[eva] Done for function printf_va_4
+[eva] computing for function printf_va_5 <- main.
+ Called from spawn_h.c:116.
+[eva] using specification for function printf_va_5
+[eva] spawn_h.c:116: function printf_va_5: precondition got status valid.
+[eva] Done for function printf_va_5
+[eva] computing for function printf_va_6 <- main.
+ Called from spawn_h.c:118.
+[eva] using specification for function printf_va_6
+[eva] spawn_h.c:118: function printf_va_6: precondition got status valid.
+[eva] Done for function printf_va_6
+[eva] spawn_h.c:105: starting to merge loop iterations
+[eva] computing for function waitpid <- main.
+ Called from spawn_h.c:106.
+[eva] Done for function waitpid
+[eva] computing for function exit <- main.
+ Called from spawn_h.c:122.
+[eva] Done for function exit
+[eva] Recording results for main
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ NON TERMINATING FUNCTION
diff --git a/tests/libc/search_h.c b/tests/libc/search_h.c
new file mode 100644
index 0000000000000000000000000000000000000000..ab39750e7ff5391a4c1b6cb97fb70350f3757435
--- /dev/null
+++ b/tests/libc/search_h.c
@@ -0,0 +1,77 @@
+// This code is the example from POSIX Programmer's Manual's TDELETE(3P) page.
+
+#include <limits.h>
+#include <search.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+
+struct element { /* Pointers to these are stored in the tree. */
+ int count;
+ char string[];
+};
+
+void *root = NULL; /* This points to the root. */
+
+int main(void) {
+ char str[_POSIX2_LINE_MAX+1];
+ int length = 0;
+ struct element *elementptr;
+ void *node;
+ void print_node(const void *, VISIT, int);
+ int node_compare(const void *, const void *),
+ delete_root(const void *, const void *);
+
+ while (fgets(str, sizeof(str), stdin)) {
+ /* Set element. */
+ length = strlen(str);
+ if (str[length-1] == '\n')
+ str[--length] = '\0';
+ elementptr = malloc(sizeof(struct element) + length + 1);
+ strcpy(elementptr->string, str);
+ elementptr->count = 1;
+ /* Put element into the tree. */
+ node = tsearch((void *)elementptr, &root, node_compare);
+ if (node == NULL) {
+ fprintf(stderr,
+ "tsearch: Not enough space available\n");
+ exit(EXIT_FAILURE);
+ }
+ else if (*(struct element **)node != elementptr) {
+ /* A node containing the element already exists */
+ (*(struct element **)node)->count++;
+ free(elementptr);
+ }
+ }
+ twalk(root, print_node);
+
+ /* Delete all nodes in the tree */
+ while (root != NULL) {
+ elementptr = *(struct element **)root;
+ printf("deleting node: string = %s, count = %d\n",
+ elementptr->string,
+ elementptr->count);
+ tdelete((void *)elementptr, &root, delete_root);
+ free(elementptr);
+ }
+
+ return 0;
+}
+
+int node_compare(const void *node1, const void *node2) {
+ return strcmp(((const struct element *) node1)->string,
+ ((const struct element *) node2)->string);
+}
+
+int delete_root(const void *node1, const void *node2) {
+ return 0;
+}
+
+void print_node(const void *ptr, VISIT order, int level) {
+ const struct element *p = *(const struct element **) ptr;
+
+ if (order == postorder || order == leaf) {
+ (void) printf("string = %s, count = %d\n",
+ p->string, p->count);
+ }
+}
diff --git a/tests/libc/spawn_h.c b/tests/libc/spawn_h.c
new file mode 100644
index 0000000000000000000000000000000000000000..bcfe0df3c6aea2968135159a7cd41b801ebfa5b6
--- /dev/null
+++ b/tests/libc/spawn_h.c
@@ -0,0 +1,123 @@
+#include <spawn.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <unistd.h>
+#include <stdlib.h>
+#include <string.h>
+#include <wait.h>
+#include <errno.h>
+
+#define errExit(msg) do { perror(msg); \
+ exit(EXIT_FAILURE); } while (0)
+
+#define errExitEN(en, msg) \
+ do { errno = en; perror(msg); \
+ exit(EXIT_FAILURE); } while (0)
+
+char **environ;
+
+int
+main(int argc, char *argv[])
+{
+ pid_t child_pid;
+ int s, opt, status;
+ sigset_t mask;
+ posix_spawnattr_t attr;
+ posix_spawnattr_t *attrp;
+ posix_spawn_file_actions_t file_actions;
+ posix_spawn_file_actions_t *file_actionsp;
+
+ /* Parse command-line options, which can be used to specify an
+ attributes object and file actions object for the child. */
+
+ attrp = NULL;
+ file_actionsp = NULL;
+
+ while ((opt = getopt(argc, argv, "sc")) != -1) {
+ switch (opt) {
+ case 'c': /* -c: close standard output in child */
+
+ /* Create a file actions object and add a "close"
+ action to it. */
+
+ s = posix_spawn_file_actions_init(&file_actions);
+ if (s != 0)
+ errExitEN(s, "posix_spawn_file_actions_init");
+
+ s = posix_spawn_file_actions_addclose(&file_actions,
+ STDOUT_FILENO);
+ if (s != 0)
+ errExitEN(s, "posix_spawn_file_actions_addclose");
+
+ file_actionsp = &file_actions;
+ break;
+
+ case 's': /* -s: block all signals in child */
+
+ /* Create an attributes object and add a "set signal mask"
+ action to it. */
+
+ s = posix_spawnattr_init(&attr);
+ if (s != 0)
+ errExitEN(s, "posix_spawnattr_init");
+ s = posix_spawnattr_setflags(&attr, POSIX_SPAWN_SETSIGMASK);
+ if (s != 0)
+ errExitEN(s, "posix_spawnattr_setflags");
+
+ sigfillset(&mask);
+ s = posix_spawnattr_setsigmask(&attr, &mask);
+ if (s != 0)
+ errExitEN(s, "posix_spawnattr_setsigmask");
+
+ attrp = &attr;
+ break;
+ }
+ }
+
+ /* Spawn the child. The name of the program to execute and the
+ command-line arguments are taken from the command-line arguments
+ of this program. The environment of the program execed in the
+ child is made the same as the parent's environment. */
+
+ s = posix_spawnp(&child_pid, argv[optind], file_actionsp, attrp,
+ &argv[optind], environ);
+ if (s != 0)
+ errExitEN(s, "posix_spawn");
+
+ /* Destroy any objects that we created earlier. */
+
+ if (attrp != NULL) {
+ s = posix_spawnattr_destroy(attrp);
+ if (s != 0)
+ errExitEN(s, "posix_spawnattr_destroy");
+ }
+
+ if (file_actionsp != NULL) {
+ s = posix_spawn_file_actions_destroy(file_actionsp);
+ if (s != 0)
+ errExitEN(s, "posix_spawn_file_actions_destroy");
+ }
+
+ printf("PID of child: %jd\n", (intmax_t) child_pid);
+
+ /* Monitor status of the child until it terminates. */
+
+ do {
+ s = waitpid(child_pid, &status, WUNTRACED | WCONTINUED);
+ if (s == -1)
+ errExit("waitpid");
+
+ printf("Child status: ");
+ if (WIFEXITED(status)) {
+ printf("exited, status=%d\n", WEXITSTATUS(status));
+ } else if (WIFSIGNALED(status)) {
+ printf("killed by signal %d\n", WTERMSIG(status));
+ } else if (WIFSTOPPED(status)) {
+ printf("stopped by signal %d\n", WSTOPSIG(status));
+ } else if (WIFCONTINUED(status)) {
+ printf("continued\n");
+ }
+ } while (!WIFEXITED(status) && !WIFSIGNALED(status));
+
+ exit(EXIT_SUCCESS);
+}
diff --git a/tests/misc/bts1201.ml b/tests/misc/bts1201.ml
index 9e3c1b2a3ff07a05ed42787d1bf59decc41dee91..8cb421763f5dc9c46a3c61679a6413b458875578 100644
--- a/tests/misc/bts1201.ml
+++ b/tests/misc/bts1201.ml
@@ -1,7 +1,7 @@
let main () =
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
Globals.set_entry_point "main2" false;
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
;;
let () = Db.Main.extend main
diff --git a/tests/misc/bts1347.ml b/tests/misc/bts1347.ml
index d2319d0f4b81a02e3a66d55474e63ea4e882c3d7..e1336805421fcbd1b834358ed9209b9e67520e53 100644
--- a/tests/misc/bts1347.ml
+++ b/tests/misc/bts1347.ml
@@ -7,7 +7,7 @@ let run () =
(fun kf ->
if not (Cil_builtins.is_builtin (Kernel_function.get_vi kf)) then begin
Globals.set_entry_point (Kernel_function.get_name kf) true;
- !Db.Value.compute();
+ Eva.Analysis.compute();
let hyps =
Alarms.fold
(fun _ kf' s ~rank:_ _ a l ->
diff --git a/tests/misc/ensures.ml b/tests/misc/ensures.ml
index cfe3fc7894196c48711c6dc6031f79ad9ef95d65..a08e28e31b1135d67ab1334b1c307a85b23a855f 100644
--- a/tests/misc/ensures.ml
+++ b/tests/misc/ensures.ml
@@ -2,7 +2,7 @@ open Cil_types
let run () =
Dynamic.Parameter.Bool.set "-eva-context-valid-pointers" true;
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
Globals.Functions.iter
(fun kf ->
let kf_name = Kernel_function.get_name kf in
diff --git a/tests/misc/issue109.ml b/tests/misc/issue109.ml
index 98cc840b15e7d55bbe01e7c1b6083c3bc28c9fbe..fee1af6952d980a7c9c5c14334a6218a2662198b 100644
--- a/tests/misc/issue109.ml
+++ b/tests/misc/issue109.ml
@@ -6,10 +6,10 @@ let ptest_file =
with Not_found -> fun dir file -> dir ^ file
let main () =
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
Dynamic.Parameter.String.set "" "";
Dynamic.Parameter.String.set "" (ptest_file "tests/misc/" "issue109.i");
File.init_from_cmdline ();
- !Db.Value.compute ()
+ Eva.Analysis.compute ()
let main = Db.Main.extend main
diff --git a/tests/misc/log_twice.ml b/tests/misc/log_twice.ml
index df47c2fe750b3d855d4ec067b48b2cf73f36d42c..15145a121857b9156787d96f5cf526a94f4e308d 100644
--- a/tests/misc/log_twice.ml
+++ b/tests/misc/log_twice.ml
@@ -8,9 +8,9 @@ let run () =
~last:false
"default"
in
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
Project.set_current p_default;
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
()
let () = Db.Main.extend run
diff --git a/tests/misc/well_typed_alarm.ml b/tests/misc/well_typed_alarm.ml
index d0e210e9c00fd3896b37b29a623e123ffa54ead4..6c792a3d3ee8155beb6f9ba3c44e698f5d196a33 100644
--- a/tests/misc/well_typed_alarm.ml
+++ b/tests/misc/well_typed_alarm.ml
@@ -1,5 +1,5 @@
let main () =
- !Db.Value.compute();
+ Eva.Analysis.compute();
Filecheck.check_ast "Check alarm";
File.pretty_ast ()
diff --git a/tests/saveload/load_one.ml b/tests/saveload/load_one.ml
index cef2bc0f80bd94c3a90a943c49997a932664cade..9440328dc2d9b58d99c4f9d5b5f338714f08d6fa 100644
--- a/tests/saveload/load_one.ml
+++ b/tests/saveload/load_one.ml
@@ -18,13 +18,13 @@ let main () =
Project.save fp;
Project.remove ~project:p ();
let p = Project.load fp in
- Project.on p (fun () -> !Db.Value.compute (); ignore (sparecode ())) ()
+ Project.on p (fun () -> Eva.Analysis.compute (); ignore (sparecode ())) ()
let () = Db.Main.extend main
(* testing Project.create_by_copy *)
let main2 () =
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
let prj = Project.create_by_copy ~last:false "copy" in
Format.printf "INIT AST@.";
File.pretty_ast ();
diff --git a/tests/slicing/combine.ml b/tests/slicing/combine.ml
index 853545c0c4836b84bb3fddd7c429377db2d93c8b..bbe23a110edfb1fe818977e138123364b920b55c 100644
--- a/tests/slicing/combine.ml
+++ b/tests/slicing/combine.ml
@@ -63,7 +63,7 @@ let main _ =
Cil.visitCilFile infos new_cil_file (* the cil file after slicing *);;
*)
Dynamic.Parameter.Bool.set "-eva-show-progress" true;
- !Db.Value.compute ();
+ Eva.Analysis.compute ();
let all = Cil_datatype.Fundec.Set.empty in
let proj3 = Constant_Propagation.Api.get all ~cast_intro:true in
Project.set_current proj3;
diff --git a/tests/slicing/libSelect.ml b/tests/slicing/libSelect.ml
index 41e55de6abc57f04b210f23b7547f49fa38d0821..309d09278480d329cc4ae0307e2169914d9d6231 100644
--- a/tests/slicing/libSelect.ml
+++ b/tests/slicing/libSelect.ml
@@ -64,7 +64,7 @@ let load_source_file ?entry_point filename =
in
ignore (Db.get_cil_file ());
let kf = Db.find_function_def_by_name entry_point in
- ignore (!Db.Value.compute_entry_point kf ~library);
+ ignore (Eva.Analysis.compute_entry_point kf ~library);
Db.iter_on_functions
(fun kf -> if Db.is_definition kf && Db.Value.is_called kf
then !Db.From.compute kf)
diff --git a/tests/syntax/Refresh_visitor.ml b/tests/syntax/Refresh_visitor.ml
index 9a82d0fd6b4635681d12e70869a6769a7fa6283e..d4075698d6899674174c5738c32b5e3eb3a02685 100644
--- a/tests/syntax/Refresh_visitor.ml
+++ b/tests/syntax/Refresh_visitor.ml
@@ -72,7 +72,7 @@ let main () =
);
Project.on p (fun () ->
Dynamic.Parameter.Bool.set "-eva-show-progress" true;
- !Db.Value.compute ()
+ Eva.Analysis.compute ()
) ();
File.pretty_ast ~prj:p ()
diff --git a/tests/syntax/attributes-declarations-definitions.c b/tests/syntax/attributes-declarations-definitions.c
index 9c7daac462a74b6a5bef1b04b25a5b304a9ed330..69344179b067e9e19eac3c1f2eb3c07f8550a880 100644
--- a/tests/syntax/attributes-declarations-definitions.c
+++ b/tests/syntax/attributes-declarations-definitions.c
@@ -1,3 +1,8 @@
+/* run.config
+ STDOPT:
+ EXIT: 1
+ STDOPT: #"-cpp-extra-args=-DUNSUPPORTED"
+*/
//@ requires p1 >= 1;
int __attribute__((tret1)) f(int __attribute__((arg1)) p1) __attribute__((f1));
@@ -51,3 +56,8 @@ int __attribute__((o)) one_letter_attribute;
int __attribute__((_n)) one_letter_attribute_with_underscore;
int __attribute__((e_)) one_letter_attribute_with_underscore_after;
+
+#ifdef UNSUPPORTED
+// explicitly unsupported attributes must cause errors
+typedef char V __attribute__((vector_size (64))); // vector_size is unsupported
+#endif
diff --git a/tests/syntax/func_locs.i b/tests/syntax/func_locs.i
new file mode 100644
index 0000000000000000000000000000000000000000..9bde496168fe2aa66a3b12a9963fbfa61147fbb0
--- /dev/null
+++ b/tests/syntax/func_locs.i
@@ -0,0 +1,36 @@
+/* run.config
+ MODULE: @PTEST_NAME@
+ STDOPT: +"-no-print"
+*/
+
+
+//@ assigns \nothing;
+void with_spec() {
+}
+
+int gx;
+
+/*@
+ requires req: a >= 0 || gx == 0;
+ assigns \result \from a;
+ ensures ens: \result == a;
+ */
+int id(int a);
+
+/*@
+ requires req: a >= 0;
+*/
+int id(int a);
+
+int decl_no_spec(); int id(int a);
+
+int def_no_spec() {
+ return 2;
+}
+
+/*@
+ requires \true;
+*/
+int main() {
+ return 0;
+}
diff --git a/tests/syntax/func_locs.ml b/tests/syntax/func_locs.ml
new file mode 100644
index 0000000000000000000000000000000000000000..e28f0429b68ca220b12e37f15c4417edc32179c6
--- /dev/null
+++ b/tests/syntax/func_locs.ml
@@ -0,0 +1,9 @@
+let run () =
+ List.iter (fun (pos1, pos2, fname) ->
+ Format.printf "%a - %a -> %s@."
+ Cil_datatype.Position.pp_with_col pos1
+ Cil_datatype.Position.pp_with_col pos2
+ fname
+ ) (Cabs2cil.func_locs ())
+
+let () = Db.Main.extend run
diff --git a/tests/syntax/oracle/attributes-declarations-definitions.res.oracle b/tests/syntax/oracle/attributes-declarations-definitions.0.res.oracle
similarity index 90%
rename from tests/syntax/oracle/attributes-declarations-definitions.res.oracle
rename to tests/syntax/oracle/attributes-declarations-definitions.0.res.oracle
index fb1151fa5ae516f773522f01cf933962bef648c7..8b1788aed0bd7e192a379383c2218fae475bf784 100644
--- a/tests/syntax/oracle/attributes-declarations-definitions.res.oracle
+++ b/tests/syntax/oracle/attributes-declarations-definitions.0.res.oracle
@@ -1,8 +1,8 @@
[kernel] Parsing attributes-declarations-definitions.c (with preprocessing)
-[kernel] attributes-declarations-definitions.c:7: Warning:
- found two contracts (old location: attributes-declarations-definitions.c:1). Merging them
-[kernel] attributes-declarations-definitions.c:16: Warning:
- found two contracts (old location: attributes-declarations-definitions.c:8). Merging them
+[kernel] attributes-declarations-definitions.c:12: Warning:
+ found two contracts (old location: attributes-declarations-definitions.c:6). Merging them
+[kernel] attributes-declarations-definitions.c:21: Warning:
+ found two contracts (old location: attributes-declarations-definitions.c:13). Merging them
/* Generated by Frama-C */
typedef int __attribute__((__a1__)) aint;
typedef int __attribute__((__p1__)) * __attribute__((__p2__)) iptr;
diff --git a/tests/syntax/oracle/attributes-declarations-definitions.1.res.oracle b/tests/syntax/oracle/attributes-declarations-definitions.1.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..0b83c35f45ab5fb43425845f8807646ed441895c
--- /dev/null
+++ b/tests/syntax/oracle/attributes-declarations-definitions.1.res.oracle
@@ -0,0 +1,10 @@
+[kernel] Parsing attributes-declarations-definitions.c (with preprocessing)
+[kernel] attributes-declarations-definitions.c:12: Warning:
+ found two contracts (old location: attributes-declarations-definitions.c:6). Merging them
+[kernel] attributes-declarations-definitions.c:21: Warning:
+ found two contracts (old location: attributes-declarations-definitions.c:13). Merging them
+[kernel] attributes-declarations-definitions.c:62: User Error:
+ unsupported attribute: vector_size
+[kernel] User Error: stopping on file "attributes-declarations-definitions.c" that has errors. Add
+ '-kernel-msg-key pp' for preprocessing command.
+[kernel] Frama-C aborted: invalid user input.
diff --git a/tests/syntax/oracle/func_locs.res.oracle b/tests/syntax/oracle/func_locs.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..8fd4ca099e2fa45737df2beec4c827b0473d0f65
--- /dev/null
+++ b/tests/syntax/oracle/func_locs.res.oracle
@@ -0,0 +1,10 @@
+[kernel] Parsing func_locs.i (no preprocessing)
+[kernel] func_locs.i:20: Warning:
+ found two contracts (old location: func_locs.i:13). Merging them
+func_locs.i:31 char 3 - func_locs.i:36 char 1 -> main
+func_locs.i:27 char 4 - func_locs.i:29 char 1 -> def_no_spec
+func_locs.i:25 char 20 - func_locs.i:25 char 26 -> id
+func_locs.i:25 char 0 - func_locs.i:25 char 16 -> decl_no_spec
+func_locs.i:20 char 3 - func_locs.i:23 char 6 -> id
+func_locs.i:13 char 3 - func_locs.i:18 char 6 -> id
+func_locs.i:7 char 3 - func_locs.i:9 char 1 -> with_spec
diff --git a/tests/value/oracle_equality/struct2.res.oracle b/tests/value/oracle_equality/struct2.res.oracle
index 848a02fcf02af843f93025e3241dc58bfe59ef05..31007513f85ece3f32c1295e5fbaad5985d2f497 100644
--- a/tests/value/oracle_equality/struct2.res.oracle
+++ b/tests/value/oracle_equality/struct2.res.oracle
@@ -11,20 +11,25 @@
< [scope:rm_asserts] removing 2 assertion(s)
---
> [scope:rm_asserts] removing 1 assertion(s)
-135,137c133,135
+135,137c133,134
< tab3[0..1] ∈ [--..--]
< tab4[0] ∈ {0; 2}
< [1] ∈ {0}
---
> tab3[0] ∈ {0; 1}
> [1] ∈ [--..--]
-> tab4[0..1] ∈ {0}
-140c138,139
+140c137,138
< tab6[0..1] ∈ {0; 2}
---
> tab6[0] ∈ {0}
> [1] ∈ {2}
-211c210
+206,207c204,205
+< s4.e[0].a; s8.b; s7; tab1[0..1]; tab2[0..1]; tab3[0..1]; tab4[0]; tab5[0];
+< tab6[0..1]; p; p2; p3; p4; p5; p6; p7; q; r; s; t; a; b
+---
+> s4.e[0].a; s8.b; s7; tab1[0..1]; tab2[0..1]; tab3[0..1]; tab5[0]; tab6[1];
+> p; p2; p3; p4; p5; p6; p7; q; r; s; t; a; b
+211c209
< [9].a}; s1; s2; s5.e[0].b; s6.b; s8; tabl[0..1]; tab1[0..1];
---
> [9].a}; s1; s2; s5.e[0].b; s6.b; s8; tabl[0..1]; tab1[0];
diff --git a/tests/value/oracle_symblocs/struct2.res.oracle b/tests/value/oracle_symblocs/struct2.res.oracle
index d5341cd37fc34837196ca8c293e4f153c13ae2a0..31bd4583d89f311ca047261d631ffb3fdaed779c 100644
--- a/tests/value/oracle_symblocs/struct2.res.oracle
+++ b/tests/value/oracle_symblocs/struct2.res.oracle
@@ -11,17 +11,21 @@
< [eva:alarm] struct2.i:185: Warning:
98d93
< [scope:rm_asserts] removing 2 assertion(s)
-136,137c131
+136,137d130
< tab4[0] ∈ {0; 2}
< [1] ∈ {0}
----
-> tab4[0..1] ∈ {0}
-140c134,135
+140c133,134
< tab6[0..1] ∈ {0; 2}
---
> tab6[0] ∈ {0}
> [1] ∈ {2}
-211c206
+206,207c200,201
+< s4.e[0].a; s8.b; s7; tab1[0..1]; tab2[0..1]; tab3[0..1]; tab4[0]; tab5[0];
+< tab6[0..1]; p; p2; p3; p4; p5; p6; p7; q; r; s; t; a; b
+---
+> s4.e[0].a; s8.b; s7; tab1[0..1]; tab2[0..1]; tab3[0..1]; tab5[0]; tab6[1];
+> p; p2; p3; p4; p5; p6; p7; q; r; s; t; a; b
+211c205
< [9].a}; s1; s2; s5.e[0].b; s6.b; s8; tabl[0..1]; tab1[0..1];
---
> [9].a}; s1; s2; s5.e[0].b; s6.b; s8; tabl[0..1]; tab1[0];