diff --git a/.Makefile.lint b/.Makefile.lint
index be7cf8332cd7b62bf8f1223ca3091ed24277adb2..b1cacfe729919dae0c13e0d0f2b82bad3938a0b4 100644
--- a/.Makefile.lint
+++ b/.Makefile.lint
@@ -213,7 +213,6 @@ ML_LINT_KO+=src/plugins/aorai/utils_parser.ml
ML_LINT_KO+=src/plugins/callgraph/callgraph_api.mli
ML_LINT_KO+=src/plugins/callgraph/cg.ml
ML_LINT_KO+=src/plugins/callgraph/cg.mli
-ML_LINT_KO+=src/plugins/callgraph/cg_viewer.ml
ML_LINT_KO+=src/plugins/callgraph/journalize.ml
ML_LINT_KO+=src/plugins/callgraph/journalize.mli
ML_LINT_KO+=src/plugins/callgraph/register.ml
@@ -268,9 +267,7 @@ ML_LINT_KO+=src/plugins/impact/options.ml
ML_LINT_KO+=src/plugins/impact/options.mli
ML_LINT_KO+=src/plugins/impact/pdg_aux.ml
ML_LINT_KO+=src/plugins/impact/pdg_aux.mli
-ML_LINT_KO+=src/plugins/impact/reason_graph.ml
ML_LINT_KO+=src/plugins/impact/register.ml
-ML_LINT_KO+=src/plugins/impact/register_gui.ml
ML_LINT_KO+=src/plugins/inout/cumulative_analysis.ml
ML_LINT_KO+=src/plugins/inout/cumulative_analysis.mli
ML_LINT_KO+=src/plugins/inout/derefs.ml
diff --git a/.gitignore b/.gitignore
index 0e333030f4d2f99767fd4ca245b5c91ccbfd7f55..6e056235f64c7cd8cd500327d9f0d8ef537e3866 100644
--- a/.gitignore
+++ b/.gitignore
@@ -42,9 +42,8 @@ autom4te.cache
#tests
/tests/ptests_config
-/tests/*/result/
-/tests/*/*/result/
-/tests/*/result_*/
+/tests/**/result/
+/tests/**/result_*/
/tests/journal/intra.byte
/tests/misc/my_visitor_plugin/my_visitor.opt
/tests/misc/my_visitor.sav
@@ -208,3 +207,5 @@ hello-*.tar.gz
/src/plugins/gui/GSourceView.ml
/src/plugins/gui/GSourceView.mli
/tests/crowbar/integer_bb_pretty
+/src/plugins/gui/dgraph_helper.ml
+/doc/doxygen
diff --git a/ALL_VERSIONS b/ALL_VERSIONS
index 41c8714b5e8cec36bdab5450c57eb8db4568e653..0d98b133fbd3666344798215bdcc8aa5f9077db4 100644
--- a/ALL_VERSIONS
+++ b/ALL_VERSIONS
@@ -1,5 +1,6 @@
Version number Date of release Notes
============== =============== =====
+19.1 (Potassium) 2019, September 18 OCaml 4.08 compatibility
19.0 (Potassium) 2019, June 21
18.0 (Argon) 2018, November 29
Chlorine-20180502 2018, July 06 Bug fixed
diff --git a/Changelog b/Changelog
index 61f02b36d6a38b1d36f374ab4b5cce3c36c2e721..cbaba73e633d47793905f529b68d0f82beceb28e 100644
--- a/Changelog
+++ b/Changelog
@@ -17,6 +17,7 @@
Open Source Release <next-release>
##################################
+o Config [2019/09/27] ocp-indent 1.7.0 is now used for indentation
-* Makefile [2019/09/12] Fixes #2378 - bytecode only compilation (patch
contributed by madroach) and use -thread where needed.
-* Kernel [2019/08/20] Fixes a rare but critical bug which occured when
diff --git a/INSTALL.md b/INSTALL.md
index fd85b7bfcb472ec6f8fa61e62605e95cf60bc646..4552589954cfa5be743bab57be23aa9071a225ce 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -7,21 +7,21 @@
- [Installing Frama-C from opam repository](#installing-frama-c-from-opam-repository)
- [Installing Custom Versions of Frama-C](#installing-custom-versions-of-frama-c)
- [Installing Frama-C on Windows via WSL](#installing-frama-c-on-windows-via-wsl)
- - [Installing Frama-C on macOS](#installing-frama-c-on-macos)
+ - [Installing Frama-C on macOS](#installing-frama-c-on-mac-os)
- [Installing Frama-C via your Linux distribution (Debian/Ubuntu/Fedora)](#installing-frama-c-via-your-linux-distribution-debianubuntufedora)
- [Compiling from source](#compiling-from-source)
- [Quick Start](#quick-start)
- [Full Compilation Guide](#full-compilation-guide)
- [Testing the Installation](#testing-the-installation)
-- [Available resources](#available-resources)
- - [Executables: (in `/INSTALL_DIR/bin`)](#executables-in-install_dirbin)
- - [Shared files: (in `/INSTALL_DIR/share/frama-c` and subdirectories)](#shared-files-in-install_dirshareframa-c-and-subdirectories)
- - [Documentation files: (in `/INSTALL_DIR/share/frama-c/doc`)](#documentation-files-in-install_dirshareframa-cdoc)
- - [Object files: (in `/INSTALL_DIR/lib/frama-c`)](#object-files-in-install_dirlibframa-c)
- - [Plugin files: (in `/INSTALL_DIR/lib/frama-c/plugins`)](#plugin-files-in-install_dirlibframa-cplugins)
- - [Man files: (in `/INSTALL_DIR/man/man1`)](#man-files-in-install_dirmanman1)
+ - [Available resources](#available-resources)
+ - [Executables: (in `/INSTALL_DIR/bin`)](#executables-in-install_dirbin)
+ - [Shared files: (in `/INSTALL_DIR/share/frama-c` and subdirectories)](#shared-files-in-install_dirshareframa-c-and-subdirectories)
+ - [Documentation files: (in `/INSTALL_DIR/share/frama-c/doc`)](#documentation-files-in-install_dirshareframa-cdoc)
+ - [Object files: (in `/INSTALL_DIR/lib/frama-c`)](#object-files-in-install_dirlibframa-c)
+ - [Plugin files: (in `/INSTALL_DIR/lib/frama-c/plugins`)](#plugin-files-in-install_dirlibframa-cplugins)
+ - [Man files: (in `/INSTALL_DIR/man/man1`)](#man-files-in-install_dirmanman1)
- [Installing Additional Frama-C Plugins](#installing-additional-frama-c-plugins)
-- [HAVE FUN WITH FRAMA-C!](#have-fun-with-frama-c)
+ - [HAVE FUN WITH FRAMA-C!](#have-fun-with-frama-c)
## Installing Frama-C via opam
@@ -70,22 +70,38 @@ so that we can add it to the Frama-C `depext` package.
# install Frama-C
opam install frama-c
+### Configuring provers for Frama-C/WP
+
+Frama-C/WP uses the [Why3](http://why3.lri.fr/) platform to run external provers for proving ACSL annotations.
+The Why3 platform and the Alt-Ergo prover are automatically installed _via_ opam
+when installing Frama-C.
+
+Other recommended, efficient provers are CVC4 and Z3.
+They can be used as replacement or combined with Alt-Ergo.
+Actually, you can use any prover supported by Why3 in combination with Frama-C/WP.
+
+Most provers are available on all platforms. After their installation,
+Why3 must be configured to make them available for Frama-C/WP:
+
+ ```shell
+ why3 config --detect
+ ```
+
### Known working configuration
The following set of packages is known to be a working configuration for
Frama-C 19 (Potassium):
- OCaml 4.05.0
-- alt-ergo-free.2.0.0 (optional)
+- ocamlfind.1.8.0
- apron.20160125 (optional)
-- coq.8.9.0 (optional)
-- lablgtk.2.18.5 | lablgtk3.3.0.beta5 + lablgtk3-sourceview3.3.0.beta5
-- mlgmpidl.1.2.9 (optional)
+- lablgtk.2.18.8 | lablgtk3.3.0.beta6 + lablgtk3-sourceview3.3.0.beta6
+- mlgmpidl.1.2.11 (optional)
- ocamlgraph.1.8.8
- why3.1.2.0
-- why3-coq.1.2.0 (optional)
-- yojson.1.4.1
-- zarith.1.7
+- alt-ergo.2.0.0 (for wp, optional)
+- yojson.1.7.0
+- zarith.1.9.1
### Installing Custom Versions of Frama-C
@@ -197,7 +213,7 @@ frama-c-gui
[opam](https://opam.ocaml.org) works perfectly on macOS via
[Homebrew](https://brew.sh).
-We recommend to rely on it for the installation of Frama-C.
+We highly recommend to rely on it for the installation of Frama-C.
1. Install *required* general macOS tools for OCaml:
@@ -206,7 +222,7 @@ We recommend to rely on it for the installation of Frama-C.
```
Do not forget to `opam init` and ``eval `opam config env` `` for a proper
- opam installation (if not already done before on your machine).
+ opam installation (if not already done before).
2. Set up a compatible OCaml version (replace `<version>` with the version
indicated in the 'recommended working configuration' section):
@@ -221,31 +237,25 @@ We recommend to rely on it for the installation of Frama-C.
brew install gmp gtk+ gtksourceview libgnomecanvas
```
-4. Install *recommended* dependencies for Frama-C:
+ The graphical libraries require additional manual configuration of your
+ bash profile. Consult this [issue](https://github.com/ocaml/opam-repository/issues/13709) on opam
+ for details. A known working configuration is:
```shell
- brew install graphviz
+ export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig:/usr/local/opt/libxml2/lib/pkgconfig:/usr/local/lib/pkgconfig
```
-5. Install *optional* dependencies for Frama-C/WP:
+4. Install *recommended* dependencies for Frama-C:
```shell
- opam install coq coqide why3-coq
+ brew install graphviz
```
-6. Install Frama-C:
+5. Install Frama-C:
```shell
opam install frama-c
```
- **Note:** for some packages, Homebrew may emit *caveats* about the
- necessity of manually setting environment variables,
- e.g. for `libffi`.
- If installation of some opam package fails, the error message
- should hopefully indicate which packages are causing it.
- Reinstalling these Homebrew packages can provide details and
- help solve the issue.
-
## Installing Frama-C via your Linux distribution (Debian/Ubuntu/Fedora)
diff --git a/Makefile b/Makefile
index 7fbec98f0709cfbdd85250df58d1c3390ff373c1..476d1807b2c22731957fd4d801361f45cbd6671b 100644
--- a/Makefile
+++ b/Makefile
@@ -30,7 +30,8 @@ include share/Makefile.dynamic_config.internal
#Check share/Makefile.config available
ifndef FRAMAC_ROOT_SRCDIR
-$(error "You should run ./configure first (or autoconf if there is no configure)")
+$(error \
+ "You should run ./configure first (or autoconf if there is no configure)")
endif
###################
@@ -100,7 +101,8 @@ DEFAULT_HEADER_DIRS := headers
DEFAULT_HEADER_EXCEPTIONS := configure
# default value used for CEA_PROPRIETARY_FILES and PLUGIN_CEA_PROPRIETARY_FILES
DEFAULT_CEA_PROPRIETARY_FILES := tests/non-free/%
-# default value used for CEA_PROPRIETARY_HEADERS and PLUGIN_CEA_PROPRIETARY_HEADERS
+# default value used for CEA_PROPRIETARY_HEADERS
+# and PLUGIN_CEA_PROPRIETARY_HEADERS
DEFAULT_CEA_PROPRIETARY_HEADERS := CEA_PROPRIETARY
MERLIN_PACKAGES:=
@@ -138,7 +140,7 @@ OFLAGS = $(PACKAGES) $(FLAGS) $(DEBUG) $(INCLUDES) -compact \
BLINKFLAGS += -linkpkg $(BFLAGS) -linkall -custom
OLINKFLAGS += -linkpkg $(OFLAGS) -linkall
-DOC_FLAGS= -colorize-code -stars -m A $(PACKAGES) $(INCLUDES) $(GUI_INCLUDES)
+DOC_FLAGS= -charset utf8 -colorize-code -stars -m A $(PACKAGES) $(INCLUDES) $(GUI_INCLUDES)
ifneq ($(VERBOSEMAKE),yes)
DOC_FLAGS+= -hide-warnings
@@ -232,7 +234,7 @@ clean-check-libc:
# itself, rather than copied: otherwise, it could include references to
# non-distributed plug-ins.
DISTRIB_FILES:=\
- $(wildcard bin/migration_scripts/*2*.sh) bin/local_export.sh \
+ $(wildcard bin/migration_scripts/*2*.sh) bin/local_export.sh \
bin/frama-c bin/frama-c.byte bin/frama-c-gui bin/frama-c-gui.byte \
bin/frama-c-config bin/frama-c-script \
share/frama-c.WIN32.rc share/frama-c.Unix.rc \
@@ -312,7 +314,11 @@ DISTRIB_FILES:=\
# Test files to be included in the distribution (without header checking).
# Plug-ins should use PLUGIN_DISTRIB_TESTS to export their test files.
-DISTRIB_TESTS=$(shell git ls-files tests src/plugins/aorai/tests src/plugins/report/tests src/plugins/wp/tests)
+DISTRIB_TESTS=$(shell git ls-files \
+ tests \
+ src/plugins/aorai/tests \
+ src/plugins/report/tests \
+ src/plugins/wp/tests)
# files that are needed to compile API documentation of external plugins
@@ -355,7 +361,8 @@ rebuild: config.status
$(MAKE) depend $(FRAMAC_PARALLEL) && \
$(MAKE) all $(FRAMAC_PARALLEL))
-sinclude .Makefile.user # Should defines FRAMAC_PARALLEL, FRAMAC_USER_FLAGS, FRAMAC_USER_MERLIN_FLAGS
+sinclude .Makefile.user
+# Should define FRAMAC_PARALLEL, FRAMAC_USER_FLAGS, FRAMAC_USER_MERLIN_FLAGS
#Create link in share for local execution if
.PHONY:create_share_link
@@ -709,40 +716,41 @@ src/plugins/gui/GSourceView.mli: src/plugins/gui/GSourceView2.mli.in
endif
SOURCEVIEWCOMPAT:=GSourceView
-GENERATED+=src/plugins/gui/GSourceView.ml src/plugins/gui/GSourceView.mli
+GENERATED+=src/plugins/gui/GSourceView.ml src/plugins/gui/GSourceView.mli \
+ src/plugins/gui/dgraph_helper.ml src/plugins/gui/gtk_compat.ml
-DGRAPHCOMPAT:=
-ifeq ($(HAS_GNOMECANVAS),no)
-DGRAPHCOMPAT:=dgraph
-src/plugins/gui/dgraph.ml: src/plugins/gui/dgraph.ml.in
+ifeq ($(LABLGTK),lablgtk3)
+src/plugins/gui/gtk_compat.ml: src/plugins/gui/gtk_compat.3.ml
$(CP) $< $@
$(CHMOD_RO) $@
-src/plugins/gui/dgraph.mli: src/plugins/gui/dgraph.mli.in
+else
+src/plugins/gui/gtk_compat.ml: src/plugins/gui/gtk_compat.2.ml
$(CP) $< $@
$(CHMOD_RO) $@
-
-GENERATED+=src/plugins/gui/dgraph.ml src/plugins/gui/dgraph.mli
endif
+GENERATED+=src/plugins/gui/gtk_compat.ml
-ifeq ($(LABLGTK),lablgtk3)
-src/plugins/gui/gtk_compat.ml: src/plugins/gui/gtk_compat.3.ml
+ifeq ($(HAS_DGRAPH),yes)
+ DGRAPHFILES:=debug_manager
+ src/plugins/gui/dgraph_helper.ml: src/plugins/gui/dgraph_helper.yes.ml
$(CP) $< $@
$(CHMOD_RO) $@
else
-src/plugins/gui/gtk_compat.ml: src/plugins/gui/gtk_compat.2.ml
+ DGRAPHFILES:=
+ src/plugins/gui/dgraph_helper.ml: src/plugins/gui/dgraph_helper.no.ml
$(CP) $< $@
$(CHMOD_RO) $@
endif
-GENERATED+=src/plugins/gui/gtk_compat.ml
SINGLE_GUI_CMO:= \
wutil_once \
gtk_compat \
$(WTOOLKIT) \
$(SOURCEVIEWCOMPAT) \
- $(DGRAPHCOMPAT) \
gui_parameters \
- gtk_helper gtk_form \
+ gtk_helper \
+ dgraph_helper \
+ gtk_form \
source_viewer pretty_source source_manager book_manager \
warning_manager \
filetree \
@@ -751,9 +759,10 @@ SINGLE_GUI_CMO:= \
history \
gui_printers \
design \
- analyses_manager file_manager project_manager debug_manager \
+ analyses_manager file_manager project_manager \
help_manager \
- property_navigator
+ $(DGRAPHFILES) \
+ property_navigator \
SINGLE_GUI_CMO:= $(patsubst %,src/plugins/gui/%.cmo,$(SINGLE_GUI_CMO))
@@ -793,11 +802,11 @@ PLUGIN_NAME:=Callgraph
PLUGIN_DISTRIBUTED:=yes
PLUGIN_DIR:=src/plugins/callgraph
PLUGIN_CMO:= options journalize subgraph cg services uses register
-#GTK3: no DGraph available.
-ifeq ($(HAS_GNOMECANVAS),yes)
+ifeq ($(HAS_DGRAPH),yes)
PLUGIN_GUI_CMO:=cg_viewer
else
PLUGIN_GUI_CMO:=
+PLUGIN_DISTRIB_EXTERNAL:=cg_viewer.ml
endif
PLUGIN_CMI:= callgraph_api
PLUGIN_INTERNAL_TEST:=yes
@@ -816,56 +825,34 @@ PLUGIN_DIR:=src/plugins/value
PLUGIN_EXTRA_DIRS:=engine values domains domains/cvalue domains/apron \
domains/gauges domains/equality legacy slevel utils gui_files \
values/numerors domains/numerors
+PLUGIN_TESTS_DIRS+=value/traces
# Files for the binding to Apron domains. Only available if Apron is available.
ifeq ($(HAS_APRON),yes)
PLUGIN_REQUIRES+= apron.octMPQ apron.boxMPQ apron.polkaMPQ apron.apron gmp
-src/plugins/value/domains/apron/apron_domain.ml: \
- src/plugins/value/domains/apron/apron_domain.ok.ml \
- share/Makefile.config
- $(CP_IF_DIFF) $< $@
- $(CHMOD_RO) $@
+APRON_CMO:= domains/apron/apron_domain
else
-src/plugins/value/domains/apron/apron_domain.ml: \
- src/plugins/value/domains/apron/apron_domain.ko.ml \
- share/Makefile.config
- $(CP_IF_DIFF) $< $@
- $(CHMOD_RO) $@
-endif
-PLUGIN_GENERATED+= src/plugins/value/domains/apron/apron_domain.ml
+APRON_CMO:=
PLUGIN_DISTRIB_EXTERNAL+= \
- domains/apron/apron_domain.ok.ml domains/apron/apron_domain.ko.ml
+ domains/apron/apron_domain.ml domains/apron/apron_domain.mli
+endif
# Files for the numerors domain. Only available is MPFR is available.
NUMERORS_FILES:= \
values/numerors/numerors_utils values/numerors/numerors_float \
values/numerors/numerors_interval values/numerors/numerors_arithmetics \
- values/numerors/numerors_value
+ values/numerors/numerors_value domains/numerors/numerors_domain
ifeq ($(HAS_MPFR),yes)
PLUGIN_REQUIRES+= gmp
PLUGIN_TESTS_DIRS+=value/numerors
NUMERORS_CMO:= $(NUMERORS_FILES)
-src/plugins/value/domains/numerors/numerors_domain.ml: \
- src/plugins/value/domains/numerors/numerors_domain.ok.ml \
- share/Makefile.config
- $(CP_IF_DIFF) $< $@
- $(CHMOD_RO) $@
else
# Do not compile numerors files, but include them in the distributed files.
NUMERORS_CMO:=
PLUGIN_DISTRIB_EXTERNAL+= $(addsuffix .ml,$(NUMERORS_FILES))
PLUGIN_DISTRIB_EXTERNAL+= $(addsuffix .mli,$(NUMERORS_FILES))
-src/plugins/value/domains/numerors/numerors_domain.ml: \
- src/plugins/value/domains/numerors/numerors_domain.ko.ml \
- share/Makefile.config
- $(CP_IF_DIFF) $< $@
- $(CHMOD_RO) $@
endif
-PLUGIN_GENERATED+= src/plugins/value/domains/numerors/numerors_domain.ml
-PLUGIN_DISTRIB_EXTERNAL+= \
- domains/numerors/numerors_domain.ok.ml \
- domains/numerors/numerors_domain.ko.ml
# General rules for ordering files within PLUGIN_CMO:
# - try to keep the legacy Value before Eva
@@ -877,7 +864,7 @@ PLUGIN_CMO:= slevel/split_strategy value_parameters \
slevel/per_stmt_slevel \
utils/library_functions \
utils/eval_typ utils/backward_formals \
- alarmset eval utils/structure \
+ alarmset eval utils/structure utils/abstract \
values/value_product values/location_lift \
values/cvalue_forward values/cvalue_backward \
values/main_values values/main_locations \
@@ -886,15 +873,14 @@ PLUGIN_CMO:= slevel/split_strategy value_parameters \
domains/domain_store domains/domain_builder \
domains/domain_product domains/domain_lift domains/unit_domain \
domains/printer_domain \
+ domains/traces_domain \
domains/simple_memory \
domains/gauges/gauges_domain \
- domains/apron/apron_domain \
domains/hcexprs \
domains/equality/equality domains/equality/equality_domain \
domains/offsm_domain \
domains/symbolic_locs \
domains/sign_domain \
- $(NUMERORS_CMO) domains/numerors/numerors_domain \
domains/cvalue/warn domains/cvalue/locals_scoping \
domains/cvalue/cvalue_offsetmap \
utils/value_results \
@@ -916,7 +902,8 @@ PLUGIN_CMO:= slevel/split_strategy value_parameters \
engine/partition engine/partitioning_parameters engine/trace_partitioning \
engine/iterator \
engine/initialization \
- engine/compute_functions engine/analysis register
+ engine/compute_functions engine/analysis register \
+ $(APRON_CMO) $(NUMERORS_CMO)
PLUGIN_CMI:= values/abstract_value values/abstract_location \
domains/abstract_domain domains/simpler_domains
PLUGIN_DEPENDENCIES:=Callgraph LoopAnalysis RteGen
@@ -1063,7 +1050,6 @@ PLUGIN_DIR:=src/plugins/impact
PLUGIN_CMO:= options pdg_aux reason_graph compute_impact register
PLUGIN_GUI_CMO:= register_gui
PLUGIN_DISTRIBUTED:=yes
-# PLUGIN_UNDOC:=impact_gui.ml
PLUGIN_INTERNAL_TEST:=yes
PLUGIN_DEPENDENCIES:=Inout Eva Pdg Slicing
@@ -1783,8 +1769,8 @@ check-ocp-indent-version:
if command -v ocp-indent >/dev/null; then \
$(eval ocp_version_major := $(shell ocp-indent --version | $(SED) -E "s/^([0-9]+)\.[0-9]+\..*/\1/")) \
$(eval ocp_version_minor := $(shell ocp-indent --version | $(SED) -E "s/^[0-9]+\.([0-9]+)\..*/\1/")) \
- if [ "$(ocp_version_major)" -gt 1 -o "$(ocp_version_minor)" -gt 7 ]; then \
- echo "error: ocp-indent <1.7.0 required for linting (got $(ocp_version_major).$(ocp_version_minor))"; \
+ if [ "$(ocp_version_major)" -lt 1 -o "$(ocp_version_minor)" -lt 7 ]; then \
+ echo "error: ocp-indent >=1.7.0 required for linting (got $(ocp_version_major).$(ocp_version_minor))"; \
exit 1; \
fi; \
else \
diff --git a/VERSION b/VERSION
index 9c39b26a3d52923c6b877787ed7519029af24278..e53e080845fc1555f9140e59d4d18db57ce742f6 100644
--- a/VERSION
+++ b/VERSION
@@ -1 +1 @@
-19.0+dev
\ No newline at end of file
+19.1+dev
diff --git a/bin/rebuild.sh b/bin/rebuild.sh
index e6f5900bd94fb75da5bcbffc16f78fa03d92e103..f8d3346fab80481cfd8a6eaa73f3f1d92765a6eb 100755
--- a/bin/rebuild.sh
+++ b/bin/rebuild.sh
@@ -5,4 +5,4 @@ autoconf -f
./configure
make clean
make depend
-make -j
+make -kj
diff --git a/doc/release/website.tex b/doc/release/website.tex
index 325a8c4b6c0578a558204feb64b94b6422de5fd8..4f3700462cb4e0f949af5368858780ecb3e5e02a 100644
--- a/doc/release/website.tex
+++ b/doc/release/website.tex
@@ -153,12 +153,33 @@ You'll need a GitHub account to create a pull request on the official opam repos
\item Make sure you are on \texttt{master} and your branch is up-to-date
\item Create a new directory: \\
\texttt{packages/frama-c/frama-c.<version>} \\
-\item Copy the following files, from the release to the opam repository clone: \\
- \texttt{opam/opam} $\rightarrow$ \texttt{packages/frama-c/frama-c.<version>/opam} \\
- \texttt{opam/descr} $\rightarrow$ \texttt{packages/frama-c/frama-c.<version>/descr} \\
- \texttt{opam/files} $\rightarrow$ \texttt{packages/frama-c/frama-c.<version>/files}\\
-\item Compute the MD5sum of the .tar.gz file and update this file: \\
- \texttt{packages/frama-c/frama-c.<version>/url} (and also update the filename inside it)
+\item Copy the file \texttt{opam/opam} from the release
+ to the opam repository clone in: \\
+ \texttt{packages/frama-c/frama-c.<version>/opam}
+\item Compute the MD5sum of the .tar.gz file and update the \texttt{opam} file
+with the following entry:
+\begin{verbatim}
+url {
+ src: "https://frama-c.com/download/frama-c-<version>-<version-name>.tar.gz"
+ checksum: "md5=<xxxxxx>"
+}
+\end{verbatim}
+You can provide \verb|sha256| and/or \verb|sha512| checksums as well if
+you wish.
+\item (optional) Check locally that everything is fine:
+\begin{verbatim}
+opam switch create local <some-ocaml-compiler-version>
+opam repository add local <path-to-repository-clone>
+opam repository set-repos local
+opam install frama-c
+\end{verbatim}
+(of course, if you already create a local switch before and it uses your
+local version of the repository, you just have to switch to it).
+
+\textbf{Note:} uncommitted changes are ignored by \texttt{opam repository};
+you have to locally commit them before \texttt{opam update} will take them into
+account.
+
\item Create a branch with any name you want (e.g. frama-c.<version>) and push it to your remote Github
\item Create a pull request to opam-repository. If all tests pass,
someone from opam should merge it for you.
diff --git a/headers/header_spec.txt b/headers/header_spec.txt
index 49b3adf9b90b65dbe542d7b4b9e58ca91bb59925..338db1fb14a0050bfabd25fd5ae64b9801c34c6c 100644
--- a/headers/header_spec.txt
+++ b/headers/header_spec.txt
@@ -781,8 +781,9 @@ src/plugins/gui/debug_manager.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/gui/debug_manager.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/gui/design.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/gui/design.mli: CEA_LGPL_OR_PROPRIETARY
-src/plugins/gui/dgraph.ml.in: CEA_LGPL_OR_PROPRIETARY
-src/plugins/gui/dgraph.mli.in: CEA_LGPL_OR_PROPRIETARY
+src/plugins/gui/dgraph_helper.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/gui/dgraph_helper.no.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/gui/dgraph_helper.yes.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/gui/file_manager.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/gui/file_manager.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/gui/filetree.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1185,6 +1186,8 @@ src/plugins/value/domains/equality/equality_domain.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/domains/equality/equality_domain.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/domains/gauges/gauges_domain.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/domains/gauges/gauges_domain.mli: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/domains/traces_domain.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/value/domains/traces_domain.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/domains/hcexprs.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/domains/hcexprs.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/domains/inout_domain.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1270,6 +1273,8 @@ src/plugins/value/slevel/split_strategy.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/value/slevel/split_strategy.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/eval_typ.ml: CEA_LGPL_OR_PROPRIETARY
@@ -1418,6 +1423,8 @@ src/plugins/wp/GuiSource.ml: CEA_WP
src/plugins/wp/GuiSource.mli: CEA_WP
src/plugins/wp/GuiTactic.ml: CEA_WP
src/plugins/wp/GuiTactic.mli: CEA_WP
+src/plugins/wp/Layout.ml: CEA_WP
+src/plugins/wp/Layout.mli: CEA_WP
src/plugins/wp/Lang.ml: CEA_WP
src/plugins/wp/Lang.mli: CEA_WP
src/plugins/wp/Letify.ml: CEA_WP
@@ -1440,6 +1447,12 @@ src/plugins/wp/MemoryContext.ml: CEA_WP
src/plugins/wp/MemoryContext.mli: CEA_WP
src/plugins/wp/MemEmpty.ml: CEA_WP
src/plugins/wp/MemEmpty.mli: CEA_WP
+src/plugins/wp/MemLoader.ml: CEA_WP
+src/plugins/wp/MemLoader.mli: CEA_WP
+src/plugins/wp/MemMemory.ml: CEA_WP
+src/plugins/wp/MemMemory.mli: CEA_WP
+src/plugins/wp/MemRegion.ml: CEA_WP
+src/plugins/wp/MemRegion.mli: CEA_WP
src/plugins/wp/MemTyped.ml: CEA_WP
src/plugins/wp/MemTyped.mli: CEA_WP
src/plugins/wp/MemVar.ml: CEA_WP
@@ -1483,6 +1496,14 @@ src/plugins/wp/RefUsage.ml: CEA_WP
src/plugins/wp/RefUsage.mli: CEA_WP
src/plugins/wp/Region.ml: CEA_WP
src/plugins/wp/Region.mli: CEA_WP
+src/plugins/wp/RegionAccess.ml: CEA_WP
+src/plugins/wp/RegionAccess.mli: CEA_WP
+src/plugins/wp/RegionAnalysis.ml: CEA_WP
+src/plugins/wp/RegionAnalysis.mli: CEA_WP
+src/plugins/wp/RegionAnnot.ml: CEA_WP
+src/plugins/wp/RegionAnnot.mli: CEA_WP
+src/plugins/wp/RegionDump.ml: CEA_WP
+src/plugins/wp/RegionDump.mli: CEA_WP
src/plugins/wp/Repr.ml: CEA_WP
src/plugins/wp/Repr.mli: CEA_WP
src/plugins/wp/Sigma.ml: CEA_WP
diff --git a/nix/default.nix b/nix/default.nix
index 5df2afa13af42530acc47210e69f69fd07aa480d..c8b5bf1155b7e0362fd0652d235b74350d902951 100644
--- a/nix/default.nix
+++ b/nix/default.nix
@@ -67,7 +67,7 @@ rec {
lint = stdenv.mkDerivation {
name = "frama-c-lint";
inherit src;
- buildInputs = (mk_buildInputs { opamPackages = [ { name = "ocp-indent"; constraint = "=1.6.1"; } ];} )
+ buildInputs = (mk_buildInputs { opamPackages = [ { name = "ocp-indent"; constraint = "=1.7.0"; } ];} )
++ [ pkgs.bc plugins.headache.installed ];
outputs = [ "out" ];
postPatch = ''
diff --git a/opam/opam b/opam/opam
index b430aac839e8b4c64f439c3731ac05312133ae68..05aa26d252a1ab3682196fe1963c2c2e6b9878a7 100644
--- a/opam/opam
+++ b/opam/opam
@@ -1,7 +1,7 @@
opam-version: "2.0"
name: "frama-c"
synopsis: "Platform dedicated to the analysis of source code written in C"
-version: "19.0"
+version: "19.1"
maintainer: "francois.bobot@cea.fr"
authors: [
"Michele Alberti"
@@ -86,7 +86,7 @@ run-test: [
]
depends: [
- "ocaml" { >= "4.05.0" }
+ "ocaml" { >= "4.05.0" & ( < "4.08.0~" | >= "4.08.1" ) }
"ocamlgraph" { >= "1.8.8" & < "1.9~" }
"ocamlfind" # needed beyond build stage, used by -load-module
"zarith"
@@ -97,7 +97,7 @@ depends: [
( "alt-ergo-free" | "alt-ergo" )
"conf-graphviz" { post }
"yojson"
- "why3"
+ "why3" { >= "1.2.0" }
]
depopts: [
@@ -105,14 +105,11 @@ depopts: [
# Coq: because .vo would would not be loadable by another version of Coq
# libraries: because we use dynamic linking
"coq"
- "why3-coq"
"mlgmpidl"
"apron"
]
conflicts: [
- "why3-base" #for WP plug-in
- "why3" { < "1.2.0" } #for WP plug-in
"lablgtk" { < "2.18.2" } #for ocaml >= 4.02.1
"frama-c-e-acsl" #avoid mixing old releases of E-ACSL, it is already
#distributed with this version of Frama-C
@@ -121,12 +118,8 @@ conflicts: [
]
messages: [
- "Coq can be used with the WP plug-in for proving interactively proof obligations"
- {!coq:installed}
- "Alt-Ergo Graphical Interface can be used by the WP plug-in"
- {!altgr-ergo:installed & alt-ergo <= "1.30"}
- "Note: the package altgr-ergo could prevent the installation of newer versions of Alt-Ergo"
- {!altgr-ergo:installed & alt-ergo <= "1.30" & ocaml >= "4.04.0"}
- "Note: the installed package altgr-ergo could prevent the installation of newer versions of Alt-Ergo"
- {altgr-ergo:installed & ocaml >= "4.04.0"}
+ "The Frama-C/Wp now uses Why-3 for all provers (Cf. deprecated -wp-prover native:alt-ergo)"
+ {alt-ergo:installed}
+ "The Frama-C/Wp native support for Coq is now deprecated (use TIP or Why-3 instead)."
+ {coq:installed}
]
diff --git a/ptests/ptests.ml b/ptests/ptests.ml
index 08b3f5fe1772bbb7edc07a156f6311ec136619e6..226880e6fa4d3e127c358cf6c08a5657b6c43be2 100644
--- a/ptests/ptests.ml
+++ b/ptests/ptests.ml
@@ -291,8 +291,8 @@ let rec argspec =
" Start the tests in Frama-C's gui.";
"-update", Arg.Unit (fun () -> behavior := Update) ,
" Take the current logs as oracles.";
- "-show", Arg.Unit (fun () -> behavior := Show; use_byte := true) ,
- " Show the results of the tests. Sets -byte.";
+ "-show", Arg.Unit (fun () -> behavior := Show) ,
+ " Show the results of the tests.";
"-run", Arg.Unit (fun () -> behavior := Run) ,
" (default) Delete logs, run tests, then examine logs different from \
oracles.";
diff --git a/share/libc/stdlib.h b/share/libc/stdlib.h
index 5d903a44e9dbe994c36705a2f06681347ee5175c..a41a685c5321cca6c0ff95c1b67f97c9d8492494 100644
--- a/share/libc/stdlib.h
+++ b/share/libc/stdlib.h
@@ -454,8 +454,11 @@ extern void *realloc(void *ptr, size_t size);
/* ISO C: 7.20.4 */
-/*@ assigns \nothing;
- @ ensures never_terminates: \false; */
+/*@
+ assigns \exit_status \from \nothing;
+ exits status: \exit_status != EXIT_SUCCESS;
+ ensures never_terminates: \false;
+ */
extern void abort(void) __attribute__ ((__noreturn__));
/*@ assigns \result \from \nothing ;*/
@@ -465,7 +468,8 @@ extern int atexit(void (*func)(void));
extern int at_quick_exit(void (*func)(void));
/*@
- assigns \nothing;
+ assigns \exit_status \from status;
+ exits status: \exit_status == status;
ensures never_terminates: \false;
*/
extern void exit(int status) __attribute__ ((__noreturn__));
diff --git a/src/kernel_internals/typing/cabs2cil.ml b/src/kernel_internals/typing/cabs2cil.ml
index b6660cac117df911653abe7845e0ba8ae15a8897..7ba8fa5f2a6c9d5a93c9bfb429456bfaac0b816b 100644
--- a/src/kernel_internals/typing/cabs2cil.ml
+++ b/src/kernel_internals/typing/cabs2cil.ml
@@ -480,8 +480,8 @@ let force_packed_attribute a =
let is_power_of_two i = i > 0 && i land (i-1) = 0
(* Computes the numeric value corresponding to an 'aligned' attribute:
- - if 'aligned' (without integer), then use the maximum machine alignment;
- - else, try to const-fold the expression to an integer value.
+ – if 'aligned' (without integer), then use the maximum machine alignment;
+ – else, try to const-fold the expression to an integer value.
Returns [Some n] in case of success, [None] otherwise.
Note that numeric values that are not powers of two are invalid and
also return [None]. *)
@@ -558,9 +558,9 @@ let process_pragmas_pack_align_comp_attributes ci cattrs =
match combine_aligned_attributes cattrs with
| None ->
(* No valid aligned attributes in this field.
- - if the composite type has a packed attribute, then add the
+ – if the composite type has a packed attribute, then add the
alignment given by the pack pragma;
- - otherwise, no alignment attribute is necessary.
+ – otherwise, no alignment attribute is necessary.
Drop existing "aligned" attributes, if there are invalid ones. *)
if Cil.hasAttribute "packed" cattrs then (dropAttribute "aligned" cattrs)
else begin
@@ -607,9 +607,9 @@ let process_pragmas_pack_align_field_attributes fi fattrs cattr =
match combine_aligned_attributes fattrs with
| None ->
(* No valid aligned attributes in this field.
- - if the composite type has a packed attribute, nothing needs to be
- done (the composite will have the "packed" attribute anyway);
- - otherwise, align on min(n,sizeof(fi.ftyp)).
+ – if the composite type has a packed attribute, nothing needs to be
+ done (the composite will have the "packed" attribute anyway);
+ – otherwise, align on min(n,sizeof(fi.ftyp)).
Drop existing "aligned" attributes, if there are invalid ones. *)
if Cil.hasAttribute "packed" cattr then (dropAttribute "aligned" fattrs)
else begin
@@ -2089,9 +2089,9 @@ struct
method private push: 'a.bool->'a->'a visitAction =
fun flag x ->
- Stack.push flag unspecified_stack;
- ChangeDoChildrenPost
- (x,fun x -> ignore(Stack.pop unspecified_stack); x)
+ Stack.push flag unspecified_stack;
+ ChangeDoChildrenPost
+ (x,fun x -> ignore(Stack.pop unspecified_stack); x)
method! vblock b =
@@ -4541,10 +4541,10 @@ let rec doSpecList ghost (suggestedAnonName: string)
constant's type is the smallest type (but at least int) that
will hold the value, with a preference for unsigned types.
The underlying type EI of the enum is picked as follows:
- - let T be the smallest integer type that holds all the enum's
- values; T is signed if any enum value is negative, unsigned otherwise
- - if the enum is packed or sizeof(T) >= sizeof(int), then EI = T
- - otherwise EI = int if T is signed and unsigned int otherwise
+ – let T be the smallest integer type that holds all the enum's
+ values; T is signed if any enum value is negative, unsigned otherwise
+ – if the enum is packed or sizeof(T) >= sizeof(int), then EI = T
+ – otherwise EI = int if T is signed and unsigned int otherwise
Note that these rules make the enum unsigned if possible *)
let updateEnum i : ikind =
if Integer.lt i !smallest then
@@ -5163,8 +5163,8 @@ and isVariableSizedArray ghost (dt: A.decl_type)
ARRAY (JUSTBASE, al, lo) when lo.expr_node != A.NOTHING ->
(* Checks whether the expression is an integer constant expression,
that is:
- - it contains no side-effect
- - it can be evaluated at compile-time
+ – it contains no side-effect
+ – it can be evaluated at compile-time
Note that we should not pass true as asconst argument for doExp,
since we are precisely trying to determine whether the expression
is a constant or not.
@@ -7787,22 +7787,22 @@ and doInitializer local_env (vi: varinfo) (inite: A.init_expression)
(* Consume some initializers. This is used by both global and local variables
initialization.
- - local_env is the current environment
- - asconst is used to indicate that expressions must be compile-time constant
+ – local_env is the current environment
+ – asconst is used to indicate that expressions must be compile-time constant
(i.e. we are in a global initializer)
- - add_implicit_ensures is a callback to add an ensures clause to contracts
+ – add_implicit_ensures is a callback to add an ensures clause to contracts
above current initialized part when it is partially initialized.
Does nothing initially. Useful only for initialization of locals
- - preinit corresponds to the initializers seen previously (for globals)
- - so contains the information about the current subobject currently being
+ – preinit corresponds to the initializers seen previously (for globals)
+ – so contains the information about the current subobject currently being
initialized
- - acc is the chunk corresponding to initializations seen previously
+ – acc is the chunk corresponding to initializations seen previously
(for locals)
- - initl is the current list of initializers to be processed
+ – initl is the current list of initializers to be processed
doInit returns a triple:
- - chunk performing initialization
- - preinit corresponding to the complete initialization
- - the list of unused initializers if any (should be empty most of the time)
+ – chunk performing initialization
+ – preinit corresponding to the complete initialization
+ – the list of unused initializers if any (should be empty most of the time)
*)
and doInit local_env asconst add_implicit_ensures preinit so acc initl =
let ghost = local_env.is_ghost in
diff --git a/src/kernel_services/abstract_interp/bottom.ml b/src/kernel_services/abstract_interp/bottom.ml
index c6ae61d80ae4388dd589aefb37f602232ed75845..12c57bbe21327b1c4f0965c4d8ff69136d088e88 100644
--- a/src/kernel_services/abstract_interp/bottom.ml
+++ b/src/kernel_services/abstract_interp/bottom.ml
@@ -52,6 +52,12 @@ let equal equal x y = match x, y with
| `Value vx, `Value vy -> equal vx vy
| _ -> false
+let compare compare a b = match a, b with
+ | `Bottom, `Bottom -> 0
+ | `Bottom, _ -> -1
+ | _, `Bottom -> 1
+ | `Value v, `Value w -> compare v w
+
let is_included is_included x y = match x, y with
| `Bottom, _ -> true
| _, `Bottom -> false
@@ -75,6 +81,10 @@ let pretty pretty fmt = function
| `Bottom -> Format.fprintf fmt "Bottom"
| `Value v -> pretty fmt v
+let iter f = function
+ | `Bottom -> ()
+ | `Value v -> f v
+
let counter = ref 0
diff --git a/src/kernel_services/abstract_interp/bottom.mli b/src/kernel_services/abstract_interp/bottom.mli
index 7fca1504bf344fe2b83b1036d3026be61a54a1ec..051fed464a90759ea1f9c67b09a2d786e25f1407 100644
--- a/src/kernel_services/abstract_interp/bottom.mli
+++ b/src/kernel_services/abstract_interp/bottom.mli
@@ -41,6 +41,7 @@ val is_bottom: 'a or_bottom -> bool
val non_bottom: 'a or_bottom -> 'a
val equal: ('a -> 'a -> bool) -> 'a or_bottom -> 'a or_bottom -> bool
+val compare: ('a -> 'a -> int) -> 'a or_bottom -> 'a or_bottom -> int
val is_included: ('a -> 'a -> bool) -> 'a or_bottom -> 'a or_bottom -> bool
val join: ('a -> 'a -> 'a) -> 'a or_bottom -> 'a or_bottom -> 'a or_bottom
val join_list: ('a -> 'a -> 'a) -> 'a or_bottom list -> 'a or_bottom
@@ -50,6 +51,7 @@ val pretty :
(Format.formatter -> 'a -> unit) ->
Format.formatter -> 'a or_bottom -> unit
+val iter: ('a -> unit) -> 'a or_bottom -> unit
(** Datatype constructor. *)
module Make_Datatype
diff --git a/src/kernel_services/abstract_interp/fc_float.ml b/src/kernel_services/abstract_interp/fc_float.ml
index 5f0b009bab1c3cdb1c011874d63fa65be598d4e5..c2f40659e5ae95f00fde9ace64b2c4a71fcd7325 100644
--- a/src/kernel_services/abstract_interp/fc_float.ml
+++ b/src/kernel_services/abstract_interp/fc_float.ml
@@ -212,7 +212,7 @@ let fmod round = binary mod_float round
let generate single double =
fun round prec ->
- round >>% fun () -> if is_single prec then single else double
+ round >>% fun () -> if is_single prec then single else double
let exp round = generate Floating_point.expf exp round
let log round = generate Floating_point.logf log round
diff --git a/src/kernel_services/ast_data/globals.ml b/src/kernel_services/ast_data/globals.ml
index ea4fd7b4489a40eeaf7afa641264772846a1f439..19de3c8145f979ff755a05e5762064d9fdb0cb3e 100644
--- a/src/kernel_services/ast_data/globals.ml
+++ b/src/kernel_services/ast_data/globals.ml
@@ -410,11 +410,11 @@ module Functions = struct
let o = object
method fold: 'a. (kernel_function -> 'a -> 'a) -> 'a -> 'a =
fun f acc ->
- fold
- (fun kf acc -> match kf.fundec with
- | Definition _ -> if is_definition then f kf acc else acc
- | Declaration _ -> if is_definition then acc else f kf acc)
- acc
+ fold
+ (fun kf acc -> match kf.fundec with
+ | Definition _ -> if is_definition then f kf acc else acc
+ | Declaration _ -> if is_definition then acc else f kf acc)
+ acc
method mem kf =
State.mem (get_vi kf) &&
(is_definition = Ast_info.Function.is_definition kf.fundec)
@@ -431,11 +431,11 @@ module Functions = struct
let o = object
method fold: 'a. (fundec -> 'a -> 'a) -> 'a -> 'a =
fun f acc ->
- fold
- (fun kf acc -> match kf.fundec with
- | Definition(fundec, _) -> f fundec acc
- | Declaration _ -> acc)
- acc
+ fold
+ (fun kf acc -> match kf.fundec with
+ | Definition(fundec, _) -> f fundec acc
+ | Declaration _ -> acc)
+ acc
method mem f = State.mem f.svar
end in
Parameter_category.create "functions" Cil_datatype.Fundec.ty
diff --git a/src/kernel_services/ast_printing/cil_printer.ml b/src/kernel_services/ast_printing/cil_printer.ml
index 64bcad8cbaec0a7b35377f266cbcb557edc158fb..adc133983a5b15ff4fa3ea4afa4266fd2d5e5b23 100644
--- a/src/kernel_services/ast_printing/cil_printer.ml
+++ b/src/kernel_services/ast_printing/cil_printer.ml
@@ -454,6 +454,12 @@ let rec has_unprotected_local_init s =
| Block { bscoping = false; bstmts = s :: _ } -> has_unprotected_local_init s
| _ -> false
+(** Annotation context in which the Printer is *)
+type annot_ctxt =
+ | Not_in_annot (** not in annotation *)
+ | In_simple_annot (** in /*@ ... */ annotation *)
+ | In_nested_annot (** in /@ ... @/ annotation *)
+
class cil_printer () = object (self)
val mutable logic_printer_enabled = true
@@ -462,36 +468,68 @@ class cil_printer () = object (self)
method pp_keyword fmt s = pp_print_string fmt s
method pp_acsl_keyword = self#pp_keyword
+
+ val mutable annot_ctxt = Not_in_annot
+
method pp_open_annotation ?(block=true) ?(pre=format_of_string "/*@@") fmt =
+ let pre = match annot_ctxt with
+ | Not_in_annot -> annot_ctxt <- In_simple_annot ; pre
+ | In_simple_annot -> annot_ctxt <- In_nested_annot ; format_of_string "/@@"
+ | _ -> assert false (* cannot enter an annotation in a internal annotation *)
+ in
(if block then Pretty_utils.pp_open_block else Format.fprintf)
fmt "%(%)" pre
method pp_close_annotation ?(block=true) ?(suf=format_of_string "*/") fmt =
+ let suf = match annot_ctxt with
+ | In_nested_annot -> annot_ctxt <- In_simple_annot ; format_of_string "@@/"
+ | In_simple_annot -> annot_ctxt <- Not_in_annot ; suf
+ | _ -> assert false (* we should not have to close an annotation that is not open *)
+ in
(if block then Pretty_utils.pp_close_block else Format.fprintf)
fmt "%(%)" suf
+ val mutable verbose = false
+ (* Do not add a value that depends on a
+ non-constant variable of the kernel here (e.g. [Kernel.Debug.get ()]). Due
+ to the way the pretty-printing class is instantiated, this value would be
+ evaluated too soon. Override the [reset] method instead. *)
+
+ (* indicates whether we are printing ghost elements *)
+ val mutable is_ghost = false
+ method private display_comment () = not is_ghost || verbose
+
+ method private in_ghost_if_needed fmt ghost_flag ~post_fmt ?block do_it =
+ let display_ghost = ghost_flag && not is_ghost in
+ if display_ghost then begin
+ is_ghost <- true ;
+ Format.fprintf fmt "%t %a@ "
+ (fun fmt -> self#pp_open_annotation ?block fmt)
+ self#pp_acsl_keyword "ghost"
+ end ;
+ do_it () ;
+ if display_ghost then begin
+ is_ghost <- false;
+ Format.fprintf fmt post_fmt
+ (fun fmt -> self#pp_close_annotation ?block fmt)
+ end
+
method without_annot:
'a. (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit =
fun f fmt x ->
- let tmp = logic_printer_enabled in
- logic_printer_enabled <- false;
- let finally () = logic_printer_enabled <- tmp in
- Extlib.try_finally ~finally (f fmt) x;
+ let tmp = logic_printer_enabled in
+ logic_printer_enabled <- false;
+ let finally () = logic_printer_enabled <- tmp in
+ Extlib.try_finally ~finally (f fmt) x;
val mutable force_brace = false
method force_brace:
'a. (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit =
fun f fmt x ->
- let tmp = force_brace in
- force_brace <- true;
- let finally () = force_brace <- tmp in
- Extlib.try_finally ~finally f fmt x;
-
- val mutable verbose = false
- (* Do not add a value that depends on a
- non-constant variable of the kernel here (e.g. [Kernel.Debug.get ()]). Due
- to the way the pretty-printing class is instantiated, this value would be
- evaluated too soon. Override the [reset] method instead. *)
+ let tmp = force_brace in
+ force_brace <- true;
+ let finally () = force_brace <- tmp in
+ Extlib.try_finally ~finally f fmt x;
val current_stmt = Stack.create ()
@@ -1094,10 +1132,6 @@ class cil_printer () = object (self)
method fundec fmt fd = fprintf fmt "%a" self#varinfo fd.svar
- (* number of opened ghost code *)
- val mutable is_ghost = false
- method private display_comment () = not is_ghost || verbose
-
method annotated_stmt (next: stmt) fmt (s: stmt) =
pp_open_hvbox fmt 0;
self#stmt_labels fmt s;
@@ -1105,18 +1139,8 @@ class cil_printer () = object (self)
if Cil.is_skip s.skind && not s.ghost && s.sattr = [] then begin
if verbose || s.labels <> [] then fprintf fmt ";"
end else begin
- let was_ghost = is_ghost in
- let display_ghost = s.ghost && not was_ghost in
- if display_ghost then begin
- is_ghost <- true;
- Format.fprintf fmt "%t %a "
- (fun fmt -> self#pp_open_annotation fmt) self#pp_acsl_keyword "ghost"
- end;
- self#stmtkind s.sattr next fmt s.skind ;
- if display_ghost then begin
- is_ghost <- false;
- self#pp_close_annotation fmt
- end
+ self#in_ghost_if_needed fmt s.ghost ~post_fmt:"%t"
+ (fun () -> self#stmtkind s.sattr next fmt s.skind)
end;
pp_close_box fmt ()
@@ -1190,18 +1214,10 @@ class cil_printer () = object (self)
| _ -> false
method private vdecl_complete fmt v =
- let display_ghost = v.vghost && not is_ghost in
- Format.fprintf fmt "@[<hov 0>%t%a;%t@]"
- (if display_ghost then (fun fmt ->
- Format.fprintf fmt "%t %a@ "
- (fun fmt -> self#pp_open_annotation ~block:false fmt)
- self#pp_acsl_keyword "ghost")
- else ignore)
- self#vdecl v
- (if display_ghost
- then (fun fmt -> Format.fprintf fmt "@ %t"
- (fun fmt -> self#pp_close_annotation ~block:false fmt))
- else ignore)
+ Format.fprintf fmt "@[<hov 0>" ;
+ self#in_ghost_if_needed fmt v.vghost ~post_fmt:"@ %t" ~block:false
+ (fun () -> Format.fprintf fmt "%a;" self#vdecl v) ;
+ Format.fprintf fmt "@]"
(* no box around the block *)
method private unboxed_block
@@ -1541,22 +1557,24 @@ class cil_printer () = object (self)
match g with
| GFun (fundec, l) ->
self#in_current_function fundec.svar;
- (* If the function has attributes then print a prototype because
- * GCC cannot accept function attributes in a definition *)
- let oldattr = fundec.svar.vattr in
- let oldattr = List.filter keep_attr oldattr in
- (* Always print the file name before function declarations *)
- (* Prototype first *)
- if oldattr <> [] then
- (self#line_directive fmt l;
- fprintf fmt "%a@\n"
- self#vdecl_complete fundec.svar);
- (* Temporarily remove the function attributes *)
- fundec.svar.vattr <- [];
- (* Body now *)
- self#line_directive ~forcefile:true fmt l;
- self#fundecl fmt fundec;
- fundec.svar.vattr <- oldattr;
+ self#in_ghost_if_needed fmt fundec.svar.vghost ~post_fmt:"%t@\n"
+ (fun () ->
+ (* If the function has attributes then print a prototype because
+ * GCC cannot accept function attributes in a definition *)
+ let oldattr = fundec.svar.vattr in
+ let oldattr = List.filter keep_attr oldattr in
+ (* Always print the file name before function declarations *)
+ (* Prototype first *)
+ if oldattr <> [] then
+ (self#line_directive fmt l;
+ fprintf fmt "%a@\n"
+ self#vdecl_complete fundec.svar);
+ (* Temporarily remove the function attributes *)
+ fundec.svar.vattr <- [];
+ (* Body now *)
+ self#line_directive ~forcefile:true fmt l;
+ self#fundecl fmt fundec;
+ fundec.svar.vattr <- oldattr) ;
fprintf fmt "@\n";
self#out_current_function
@@ -1610,21 +1628,16 @@ class cil_printer () = object (self)
| GVar (vi, io, l) ->
self#line_directive ~forcefile:true fmt l;
Format.fprintf fmt "@[<hov 2>";
- if vi.vghost then
- Format.fprintf fmt "%t %a@ "
- (fun fmt -> self#pp_open_annotation ~block:false fmt)
- self#pp_acsl_keyword "ghost";
- self#vdecl fmt vi;
- (match io.init with
- | None -> ()
- | Some i ->
- fprintf fmt " =@ ";
- self#init fmt i;
- );
- fprintf fmt ";";
- if vi.vghost then
- Format.fprintf fmt "@ %t"
- (fun fmt -> self#pp_close_annotation ~block:false fmt);
+ self#in_ghost_if_needed fmt vi.vghost ~post_fmt:"@ %t" ~block:false
+ (fun () ->
+ self#vdecl fmt vi;
+ (match io.init with
+ | None -> ()
+ | Some i ->
+ fprintf fmt " =@ ";
+ self#init fmt i;
+ );
+ fprintf fmt ";") ;
fprintf fmt "@]@\n";
(* print global variable 'extern' declarations *)
@@ -1724,26 +1737,13 @@ class cil_printer () = object (self)
method private fundecl fmt f =
(* declaration. *)
- let was_ghost = is_ghost in
- let entering_ghost = f.svar.vghost && not was_ghost in
- fprintf fmt "@[%t%a@\n@[<v 2>"
- (if entering_ghost then (fun fmt ->
- Format.fprintf fmt "%t %a@ "
- (fun fmt -> self#pp_open_annotation ~block:false fmt)
- self#pp_acsl_keyword "ghost")
- else ignore)
- self#vdecl f.svar;
- (* We take care of locals in blocks. *)
- (*List.iter (fprintf fmt "@\n%a;" self#vdecl) f.slocals ;*)
- (* body. *)
- if entering_ghost then is_ghost <- true;
- self#unboxed_block Body fmt f.sbody;
- if entering_ghost then is_ghost <- false;
- fprintf fmt "@]%t@]@."
- (if entering_ghost
- then (fun fmt -> Format.fprintf fmt "@ %t"
- (fun fmt -> self#pp_close_annotation ~block:false fmt))
- else ignore)
+ fprintf fmt "@[";
+ self#in_ghost_if_needed fmt f.svar.vghost ~post_fmt:"@ %t" ~block:false
+ (fun () ->
+ fprintf fmt "%a@\n@[<v 2>" self#vdecl f.svar;
+ self#unboxed_block Body fmt f.sbody;
+ fprintf fmt "@]") ;
+ fprintf fmt "@]@."
(***** PRINTING DECLARATIONS and TYPES ****)
diff --git a/src/kernel_services/ast_printing/printer.ml b/src/kernel_services/ast_printing/printer.ml
index 294c40cd7425dcd9e8965befa437e02683c97a2e..5d89b10f83d796dcc7b8409fbad5bbe8fd1008c2 100644
--- a/src/kernel_services/ast_printing/printer.ml
+++ b/src/kernel_services/ast_printing/printer.ml
@@ -167,12 +167,10 @@ class printer_with_annot () = object (self)
super#global fmt glob
method private begin_annotation fmt =
- let pre = if is_ghost then Some ("@@/": Pretty_utils.sformat) else None in
- self#pp_open_annotation ~block:false ?pre fmt
+ self#pp_open_annotation ~block:false fmt
method private end_annotation fmt =
- let suf = if is_ghost then Some ("@@/": Pretty_utils.sformat) else None in
- self#pp_close_annotation ~block:false ?suf fmt
+ self#pp_close_annotation ~block:false fmt
method private loop_annotations fmt annots =
if annots <> [] then
@@ -215,35 +213,22 @@ class printer_with_annot () = object (self)
Cil_datatype.Code_annotation.compare
(Annotations.code_annot s)
in
- let pGhost fmt s =
- let was_ghost = is_ghost in
- if not was_ghost && s.ghost then begin
- Format.fprintf fmt "%t %a "
- (fun fmt -> self#pp_open_annotation ~pre:"@[/*@@" fmt)
- self#pp_acsl_keyword "ghost";
- is_ghost <- true
- end;
- self#stmtkind s.sattr next fmt s.skind;
- if not was_ghost && s.ghost then begin
- self#pp_close_annotation ~suf:"@,*/@]" fmt;
- is_ghost <- false;
- end
- in
- (match all_annot with
- | [] -> pGhost fmt s
- | [ a ] when Cil.is_skip s.skind && not s.ghost ->
- Format.fprintf fmt "@[<hv>@[%t@ %a@;<1 1>%t@]@ %a@]"
- (fun fmt -> self#pp_open_annotation ~block:false fmt)
- self#code_annotation a
- (fun fmt -> self#pp_close_annotation ~block:false fmt)
- (self#stmtkind s.sattr next) s.skind;
- | _ ->
- let loop_annot, stmt_annot =
- List.partition Logic_utils.is_loop_annot all_annot
- in
- self#annotations fmt stmt_annot;
- self#loop_annotations fmt loop_annot;
- pGhost fmt s)
+ self#in_ghost_if_needed fmt s.ghost ~post_fmt:"%t"
+ (fun () -> match all_annot with
+ | [] -> self#stmtkind s.sattr next fmt s.skind;
+ | [ a ] when Cil.is_skip s.skind && not s.ghost ->
+ Format.fprintf fmt "@[<hv>@[%t@ %a@;<1 1>%t@]@ %a@]"
+ self#begin_annotation
+ self#code_annotation a
+ self#end_annotation
+ (self#stmtkind s.sattr next) s.skind;
+ | _ ->
+ let loop_annot, stmt_annot =
+ List.partition Logic_utils.is_loop_annot all_annot
+ in
+ self#annotations fmt stmt_annot;
+ self#loop_annotations fmt loop_annot;
+ self#stmtkind s.sattr next fmt s.skind) ;
end else
self#stmtkind s.sattr next fmt s.skind;
Format.pp_close_box fmt ()
diff --git a/src/kernel_services/ast_printing/printer_api.mli b/src/kernel_services/ast_printing/printer_api.mli
index 78de7bf360627e7a59de0c7a2c9d6143ee61b95c..a09665c4365ec4cbafc36db2060b72f955acb93d 100644
--- a/src/kernel_services/ast_printing/printer_api.mli
+++ b/src/kernel_services/ast_printing/printer_api.mli
@@ -78,6 +78,22 @@ class type extensible_printer_type = object
method private has_annot: bool
(** [true] if [current_stmt] has some annotations attached to it. *)
+ method private in_ghost_if_needed:
+ Format.formatter ->
+ bool ->
+ post_fmt:(((Format.formatter -> unit) -> unit, Format.formatter, unit) format) ->
+ ?block:bool ->
+ (unit -> unit)
+ -> unit
+ (** Open a ghost context if the the first [bool] is true and we are not
+ already in a ghost context. [post_fmt] is a format like ["%t"] and is used
+ to define the format at the end of the ghost context. [block] indicates
+ whether we should open a C block or not (defaults to [true]). The last
+ parameter is the function to be applied in the ghost context (generally
+ some AST element).
+
+ @since 19.0-Potassium+dev *)
+
method private current_stmt: stmt option
(** @return the [stmt] being printed *)
diff --git a/src/kernel_services/ast_queries/cil.ml b/src/kernel_services/ast_queries/cil.ml
index 6b8f9d91e8e15bd13ef38dd1457acf7619bc17eb..ef22afcb87bfa37c7133f9e6fdfc8bc8e5ccc7bf 100644
--- a/src/kernel_services/ast_queries/cil.ml
+++ b/src/kernel_services/ast_queries/cil.ml
@@ -3244,7 +3244,7 @@ let mkLoop ?(sattr = [Attr("while", [])]) ~(guard:exp) ~(body: stmt list) : stmt
(mkStmt ~valid_sid:true
(If(guard,
mkBlock [],
- mkBlock [ mkStmt (Break guard.eloc)], guard.eloc)) ::
+ mkBlock [ mkStmt ~valid_sid:true (Break guard.eloc)], guard.eloc)) ::
body), guard.eloc, None, None)) ]
let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list)
diff --git a/src/kernel_services/ast_queries/file.ml b/src/kernel_services/ast_queries/file.ml
index eacf1fbb240e999cc00e420f86d124949860c1f8..14db347afbc46b11af0042036227eb41fbd7fa6b 100644
--- a/src/kernel_services/ast_queries/file.ml
+++ b/src/kernel_services/ast_queries/file.ml
@@ -1162,6 +1162,7 @@ let init_project_from_cil_file prj file =
Project.copy ~selection prj;
Project.on prj (fun file -> fill_built_ins (); prepare_cil_file file) file
+let files_pre_register_state = Files.pre_register_state
module Global_annotation_graph = struct
module Base =
diff --git a/src/kernel_services/ast_queries/file.mli b/src/kernel_services/ast_queries/file.mli
index d529d99e0f47a07a1dec138c7d4dd2197b6f48af..c4fcb4458d133d0356457ae0d5201a82edf873a7 100644
--- a/src/kernel_services/ast_queries/file.mli
+++ b/src/kernel_services/ast_queries/file.mli
@@ -219,6 +219,9 @@ val create_rebuilt_project_from_visitor:
@modify Fluorine-20130401 added reorder optional argument
*)
+val prepare_cil_file: Cil_types.file -> unit
+val files_pre_register_state: State.t
+
val init_from_cmdline: unit -> unit
(** Initialize the cil file representation with the file given on the
command line.
diff --git a/src/kernel_services/ast_queries/filecheck.ml b/src/kernel_services/ast_queries/filecheck.ml
index 7567114270ced0f34a899a6fd4cfeaf3417651fb..7f9fb6810d409045fa5db13cd6df8e8acc8ff5ae 100644
--- a/src/kernel_services/ast_queries/filecheck.ml
+++ b/src/kernel_services/ast_queries/filecheck.ml
@@ -732,15 +732,15 @@ module Base_checker = struct
method private check_ei: 'a. enumitem -> 'a Cil.visitAction =
fun ei ->
- try
- let ei' = Enumitem.Hashtbl.find known_enumitems ei in
- if ei != ei' then
- check_abort "enumitem %s is not shared between declaration and use"
- ei.einame;
- Cil.DoChildren
- with Not_found ->
- check_abort "enumitem %s is used but not declared"
- ei.einame
+ try
+ let ei' = Enumitem.Hashtbl.find known_enumitems ei in
+ if ei != ei' then
+ check_abort "enumitem %s is not shared between declaration and use"
+ ei.einame;
+ Cil.DoChildren
+ with Not_found ->
+ check_abort "enumitem %s is used but not declared"
+ ei.einame
(* can't use vlogic_label, as it also visits the declared labels in
Tapp and Papp. *)
diff --git a/src/kernel_services/ast_queries/logic_typing.ml b/src/kernel_services/ast_queries/logic_typing.ml
index a0e404dd1c1e4b9dbb93575eed84077c85fd176d..c255a3c6a8709e28d1f43d2d8fe42947ebae5fcc 100644
--- a/src/kernel_services/ast_queries/logic_typing.ml
+++ b/src/kernel_services/ast_queries/logic_typing.ml
@@ -2992,80 +2992,80 @@ struct
and type_relation:
'a. _ -> _ -> (_ -> _ -> _ -> _ -> 'a) -> _ -> _ -> _ -> 'a =
fun ctxt env f t1 op t2 ->
- let loc1 = t1.lexpr_loc in
- let loc2 = t2.lexpr_loc in
- let loc = loc_join t1.lexpr_loc t2.lexpr_loc in
- let t1 = ctxt.type_term ctxt env t1 in
- let ty1 = t1.term_type in
- let t2 = ctxt.type_term ctxt env t2 in
- let ty2 = t2.term_type in
- let rel = match op with
- | Eq -> "eq"
- | Neq -> "ne"
- | Le -> "le"
- | Lt -> "lt"
- | Ge -> "ge"
- | Gt -> "gt"
+ let loc1 = t1.lexpr_loc in
+ let loc2 = t2.lexpr_loc in
+ let loc = loc_join t1.lexpr_loc t2.lexpr_loc in
+ let t1 = ctxt.type_term ctxt env t1 in
+ let ty1 = t1.term_type in
+ let t2 = ctxt.type_term ctxt env t2 in
+ let ty2 = t2.term_type in
+ let rel = match op with
+ | Eq -> "eq"
+ | Neq -> "ne"
+ | Le -> "le"
+ | Lt -> "lt"
+ | Ge -> "ge"
+ | Gt -> "gt"
+ in
+ let conditional_conversion t1 t2 =
+ let env,t,ty1,ty2 =
+ conditional_conversion loc env (Some rel) t1 t2
in
- let conditional_conversion t1 t2 =
- let env,t,ty1,ty2 =
- conditional_conversion loc env (Some rel) t1 t2
- in
- let t1 = { t1 with term_type = instantiate env t1.term_type } in
- let _,t1 =
- implicit_conversion ~overloaded:false loc1 t1 t1.term_type ty1
+ let t1 = { t1 with term_type = instantiate env t1.term_type } in
+ let _,t1 =
+ implicit_conversion ~overloaded:false loc1 t1 t1.term_type ty1
+ in
+ let t2 = { t2 with term_type = instantiate env t2.term_type } in
+ let _,t2 =
+ implicit_conversion ~overloaded:false loc2 t2 t2.term_type ty2
+ in
+ f loc op (mk_cast t1 t) (mk_cast t2 t)
+ in
+ begin match op with
+ | _ when plain_arithmetic_type ty1 && plain_arithmetic_type ty2 ->
+ conditional_conversion t1 t2
+ | Eq | Neq when isLogicPointer t1 && isLogicNull t2 ->
+ let t1 = mk_logic_pointer_or_StartOf t1 in
+ let t2 =
+ (* in case of a set, we perform two conversions: first from
+ integer to pointer, then from pointer to set of pointer. *)
+ if is_set_type t1.term_type then
+ mk_cast t2 (type_of_set_elem t1.term_type)
+ else t2
in
- let t2 = { t2 with term_type = instantiate env t2.term_type } in
- let _,t2 =
- implicit_conversion ~overloaded:false loc2 t2 t2.term_type ty2
+ f loc op t1 (mk_cast t2 t1.term_type)
+ | Eq | Neq when isLogicPointer t2 && isLogicNull t1 ->
+ let t2 = mk_logic_pointer_or_StartOf t2 in
+ let t1 =
+ if is_set_type t2.term_type then
+ mk_cast t1 (type_of_set_elem t2.term_type)
+ else t1
in
- f loc op (mk_cast t1 t) (mk_cast t2 t)
- in
- begin match op with
- | _ when plain_arithmetic_type ty1 && plain_arithmetic_type ty2 ->
- conditional_conversion t1 t2
- | Eq | Neq when isLogicPointer t1 && isLogicNull t2 ->
- let t1 = mk_logic_pointer_or_StartOf t1 in
- let t2 =
- (* in case of a set, we perform two conversions: first from
- integer to pointer, then from pointer to set of pointer. *)
- if is_set_type t1.term_type then
- mk_cast t2 (type_of_set_elem t1.term_type)
- else t2
- in
- f loc op t1 (mk_cast t2 t1.term_type)
- | Eq | Neq when isLogicPointer t2 && isLogicNull t1 ->
- let t2 = mk_logic_pointer_or_StartOf t2 in
- let t1 =
- if is_set_type t2.term_type then
- mk_cast t1 (type_of_set_elem t2.term_type)
- else t1
- in
- f loc op (mk_cast t1 t2.term_type) t2
- | Eq | Neq when isLogicArrayType ty1 && isLogicArrayType ty2 ->
- if is_same_logic_array_type ty1 ty2 then f loc op t1 t2
- else
- ctxt.error loc "comparison of incompatible types %a and %a"
- Cil_printer.pp_logic_type ty1 Cil_printer.pp_logic_type ty2
- | _ when isLogicPointer t1 && isLogicPointer t2 ->
- let t1 = mk_logic_pointer_or_StartOf t1 in
- let t2 = mk_logic_pointer_or_StartOf t2 in
- if is_same_logic_ptr_type ty1 ty2 ||
- ((op = Eq || op = Neq) &&
- (isLogicVoidPointerType t1.term_type ||
- isLogicVoidPointerType t2.term_type))
- then f loc op t1 t2
- else if (op=Eq || op = Neq) then conditional_conversion t1 t2
- else
- ctxt.error loc "comparison of incompatible types: %a and %a"
- Cil_printer.pp_logic_type t1.term_type
- Cil_printer.pp_logic_type t2.term_type
- | Eq | Neq -> conditional_conversion t1 t2
- | _ ->
+ f loc op (mk_cast t1 t2.term_type) t2
+ | Eq | Neq when isLogicArrayType ty1 && isLogicArrayType ty2 ->
+ if is_same_logic_array_type ty1 ty2 then f loc op t1 t2
+ else
+ ctxt.error loc "comparison of incompatible types %a and %a"
+ Cil_printer.pp_logic_type ty1 Cil_printer.pp_logic_type ty2
+ | _ when isLogicPointer t1 && isLogicPointer t2 ->
+ let t1 = mk_logic_pointer_or_StartOf t1 in
+ let t2 = mk_logic_pointer_or_StartOf t2 in
+ if is_same_logic_ptr_type ty1 ty2 ||
+ ((op = Eq || op = Neq) &&
+ (isLogicVoidPointerType t1.term_type ||
+ isLogicVoidPointerType t2.term_type))
+ then f loc op t1 t2
+ else if (op=Eq || op = Neq) then conditional_conversion t1 t2
+ else
ctxt.error loc "comparison of incompatible types: %a and %a"
Cil_printer.pp_logic_type t1.term_type
Cil_printer.pp_logic_type t2.term_type
- end
+ | Eq | Neq -> conditional_conversion t1 t2
+ | _ ->
+ ctxt.error loc "comparison of incompatible types: %a and %a"
+ Cil_printer.pp_logic_type t1.term_type
+ Cil_printer.pp_logic_type t2.term_type
+ end
and term_lval f t =
let check_lval t =
diff --git a/src/kernel_services/ast_transformations/inline.ml b/src/kernel_services/ast_transformations/inline.ml
index 600438e672790705bcb21a8956246d3539ef92a7..ba10dc8a509fc72d0374b2fde358059e8f63ae8a 100644
--- a/src/kernel_services/ast_transformations/inline.ml
+++ b/src/kernel_services/ast_transformations/inline.ml
@@ -51,13 +51,13 @@ module RemoveInlined =
let inline_parameter_category = object
method fold: 'a. (kernel_function -> 'a -> 'a) -> 'a -> 'a =
fun f acc ->
- Globals.Functions.fold
- (fun kf acc ->
- let vi = Kernel_function.get_vi kf in
- match kf.fundec with
- | Definition _ -> if vi.vinline then f kf acc else acc
- | Declaration _ -> acc)
- acc
+ Globals.Functions.fold
+ (fun kf acc ->
+ let vi = Kernel_function.get_vi kf in
+ match kf.fundec with
+ | Definition _ -> if vi.vinline then f kf acc else acc
+ | Declaration _ -> acc)
+ acc
method mem kf =
Kernel_function.is_definition kf && (Kernel_function.get_vi kf).vinline
end
diff --git a/src/kernel_services/plugin_entry_points/db.ml b/src/kernel_services/plugin_entry_points/db.ml
index baad021381a46b3905e7a24582131c9f33fa833c..e88014be4f9ba107cf6e08cecf77bbd531802be6 100644
--- a/src/kernel_services/plugin_entry_points/db.ml
+++ b/src/kernel_services/plugin_entry_points/db.ml
@@ -316,6 +316,13 @@ module Value = struct
let size = size
let dependencies = [ Table_By_Callstack.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 ]
+ end)
let self = Table_By_Callstack.self
@@ -519,13 +526,18 @@ module Value = struct
let add_formals_to_state = mk_fun "add_formals_to_state"
- let noassert_get_stmt_state s =
+ let noassert_get_stmt_state ~after s =
if !no_results (Kernel_function.(get_definition (find_englobing_kf s)))
then Cvalue.Model.top
else
- try Table.find s
+ let (find, add), find_by_callstack =
+ if after
+ then AfterTable.(find, add), AfterTable_By_Callstack.find
+ else Table.(find, add), Table_By_Callstack.find
+ in
+ try find s
with Not_found ->
- let ho = try Some (Table_By_Callstack.find s) with Not_found -> None in
+ let ho = try Some (find_by_callstack s) with Not_found -> None in
let state =
match ho with
| None -> Cvalue.Model.bottom
@@ -534,21 +546,22 @@ module Value = struct
Cvalue.Model.join acc state
) h Cvalue.Model.bottom
in
- Table.add s state;
+ add s state;
state
- let noassert_get_state k =
+ let noassert_get_state ?(after=false) k =
match k with
| Kglobal -> globals_state ()
- | Kstmt s -> noassert_get_stmt_state s
+ | Kstmt s ->
+ noassert_get_stmt_state ~after s
- let get_stmt_state s =
+ let get_stmt_state ?(after=false) s =
assert (is_computed ()); (* this assertion fails during value analysis *)
- noassert_get_stmt_state s
+ noassert_get_stmt_state ~after s
- let get_state k =
+ let get_state ?(after=false) k =
assert (is_computed ()); (* this assertion fails during value analysis *)
- noassert_get_state k
+ noassert_get_state ~after k
let get_stmt_state_callstack ~after stmt =
assert (is_computed ()); (* this assertion fails during value analysis *)
diff --git a/src/kernel_services/plugin_entry_points/db.mli b/src/kernel_services/plugin_entry_points/db.mli
index cd627fbe6855a4390136b3cd1228a135511f32a5..fe390a2c327da09e22208efe9dafb753b104b519 100644
--- a/src/kernel_services/plugin_entry_points/db.mli
+++ b/src/kernel_services/plugin_entry_points/db.mli
@@ -265,14 +265,15 @@ module Value : sig
val get_initial_state : kernel_function -> state
val get_initial_state_callstack :
kernel_function -> state Value_types.Callstack.Hashtbl.t option
- val get_state : kinstr -> state
-
+ val get_state : ?after:bool -> kinstr -> state
+ (** [after] is false by default. *)
val get_stmt_state_callstack:
after:bool -> stmt -> state Value_types.Callstack.Hashtbl.t option
- val get_stmt_state : stmt -> state
- (** @plugin development guide *)
+ val get_stmt_state : ?after:bool -> stmt -> state
+ (** [after] is false by default.
+ @plugin development guide *)
val fold_stmt_state_callstack :
(state -> 'a -> 'a) -> 'a -> after:bool -> stmt -> 'a
@@ -519,9 +520,9 @@ module Value : sig
(**/**)
(** {3 Internal use only} *)
- val noassert_get_state : kinstr -> state
+ val noassert_get_state : ?after:bool -> kinstr -> state
(** To be used during the value analysis itself (instead of
- {!get_state}). *)
+ {!get_state}). [after] is false by default. *)
val recursive_call_occurred: kernel_function -> unit
diff --git a/src/libraries/project/state_builder.mli b/src/libraries/project/state_builder.mli
index 4dcb71335ce31c28052a37469838d9c0aa0a593c..7cc91b8fa94d8f79541610e5982b7e188de1a36a 100644
--- a/src/libraries/project/state_builder.mli
+++ b/src/libraries/project/state_builder.mli
@@ -458,7 +458,7 @@ end
@since Carbon-20101201 *)
module SharedCounter(Info : sig val name : string end) : Counter
-(** Creates a projectified counter.
+(** Creates a projectified counter. That starts at 0
@since Nitrogen-20111001 *)
module Counter(Info : sig val name : string end) : Counter
diff --git a/src/libraries/stdlib/extlib.ml b/src/libraries/stdlib/extlib.ml
index e14bbd2582c262fe2697232b580f53b8b0bb0465..d2ce5179115b877f64e6f91650b6ebddd03a4893 100644
--- a/src/libraries/stdlib/extlib.ml
+++ b/src/libraries/stdlib/extlib.ml
@@ -108,6 +108,28 @@ let filter_map' f filter l=
| [] -> []
| x::tl -> let x' = f x in if filter x' then x' :: aux tl else aux tl
in aux l
+let rec filter_map_opt f = function
+ | [] -> []
+ | x::tl ->
+ match f x with
+ | None -> filter_map_opt f tl
+ | Some x' -> x' :: filter_map_opt f tl
+
+let rec fold_map f acc = function
+ | [] -> acc, []
+ | x::tl ->
+ let (acc,x) = f acc x in
+ let (acc,tl) = fold_map f acc tl in
+ (acc,x::tl)
+
+let rec fold_map_opt f acc = function
+ | [] -> acc, []
+ | x::tl ->
+ match f acc x with
+ | acc, None -> fold_map_opt f acc tl
+ | acc, Some x ->
+ let (acc,tl) = fold_map_opt f acc tl in
+ (acc,x::tl)
let product_fold f acc e1 e2 =
List.fold_left
diff --git a/src/libraries/stdlib/extlib.mli b/src/libraries/stdlib/extlib.mli
index a6ea92ff928e51c4dcec2525b7cba942173fd5bb..a51e4fe778189f3d4b072f4c92cf0bfe740c5ec0 100644
--- a/src/libraries/stdlib/extlib.mli
+++ b/src/libraries/stdlib/extlib.mli
@@ -102,8 +102,14 @@ val replace: ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
val filter_map: ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list
val filter_map': ('a -> 'b) -> ('b -> bool) -> 'a list -> 'b list
+val filter_map_opt: ('a -> 'b option) -> 'a list -> 'b list
(** Combines [filter] and [map]. *)
+val fold_map: ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+(** Combines [fold_left] and [map] *)
+val fold_map_opt: ('a -> 'b -> 'a * 'c option) -> 'a -> 'b list -> 'a * 'c list
+(** Combines [filter] [fold_left] and [map] *)
+
val product_fold: ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
(** [product f acc l1 l2] is similar to [fold_left f acc l12] with l12 the
list of all pairs of an elt of [l1] and an elt of [l2]
diff --git a/src/libraries/utils/filepath.mli b/src/libraries/utils/filepath.mli
index 74eef31bbdbb8d6f2ff340258beffeef3539cd65..6d278f4407c85314f82d60ada84c31b7adb4b83b 100644
--- a/src/libraries/utils/filepath.mli
+++ b/src/libraries/utils/filepath.mli
@@ -36,6 +36,7 @@
unlike [realpath];
- non-existing directories in [realpath] may lead to ENOTDIR errors,
but [normalize] may accept them.
+
@modify Aluminium-20160501 optional base_name. *)
val normalize: ?base_name:string -> string -> string
@@ -59,8 +60,8 @@ val is_relative: ?base_name:string -> string -> bool
current working directory; also, symbolic names are resolved,
i.e. the result may be prefixed by known aliases (e.g. FRAMAC_SHARE).
See {!add_symbolic_dir} for more details.
- Therefore, the result of this function may not designate a valid name
- in the filesystem.
+ Therefore, the result of this function may not designate a valid name
+ in the filesystem.
@since Neon-20140301
@deprecated since 18.0-Argon
@@ -109,9 +110,9 @@ module Normalized: sig
current working directory; also, symbolic names are resolved,
i.e. the result may be prefixed by known aliases (e.g. FRAMAC_SHARE).
See {!add_symbolic_dir} for more details.
- Therefore, the result of this function may not designate a valid name
- in the filesystem and must ONLY be used to pretty-print information;
- it must NEVER to be converted back to a filepath later.
+ Therefore, the result of this function may not designate a valid name
+ in the filesystem and must ONLY be used to pretty-print information;
+ it must NEVER to be converted back to a filepath later.
*)
val pretty: Format.formatter -> t -> unit
diff --git a/src/libraries/utils/hptmap.ml b/src/libraries/utils/hptmap.ml
index 543f80ddafc0e32a295088a7fb0bfbb68821c80f..d7725d945383f676f453e37184198766270b7d05 100644
--- a/src/libraries/utils/hptmap.ml
+++ b/src/libraries/utils/hptmap.ml
@@ -38,6 +38,23 @@ module Big_Endian = struct
let shorter (m:int) (n:int) = m > n
+ (* Returns a mask for the highest bit differing between [p0] and [p1]. *)
+ let branching_bit p0 p1 =
+ (* We want to compute the leftmost bit set in [v]; let's call it [i]. *)
+ let v = p0 lxor p1 in
+ (* Set all bits to the right of [i] in [v]; note that [i] is already set. *)
+ let v = v lor (v lsr 1) in
+ (* Now the 2 bits starting from [i] are set: [v] is 0-011?-?. *)
+ let v = v lor (v lsr 2) in
+ (* Now the 4 bits starting from [i] are set: [v] is 0-01111?-?. Etc. *)
+ let v = v lor (v lsr 4) in
+ let v = v lor (v lsr 8) in
+ let v = v lor (v lsr 16) in
+ let v = if Sys.int_size > 32 then v lor (v lsr 32) else v in
+ (* All bits at the right of [i] are set: [v] is 0-011-1.
+ Gets the highest bit set in [v]. *)
+ (succ v) lsr 1
+
end
(*i ------------------------------------------------------------------------ i*)
@@ -96,6 +113,60 @@ end
module Shape(Key: Id_Datatype) = struct
type 'b t = (Key.t, 'b) tree
+
+ let compare_v cmp t1 t2 =
+ match t1, t2 with
+ | Empty, Empty -> 0
+ | Empty, _ -> -1
+ | _, Empty -> 1
+ | Leaf (k1,x1,_), Leaf (k2,x2,_) ->
+ let c = Key.compare k1 k2 in
+ if c <> 0 then c else cmp x1 x2
+ | Leaf _, Branch _ -> -1
+ | Branch _, Leaf _ -> 1
+ | Branch (_p1,_m1,_l1,_r1,t1), Branch (_p2,_m2,_l2,_r2,t2) ->
+ let t1 = Tag_comp.get_tag t1 in
+ let t2 = Tag_comp.get_tag t2 in
+ Datatype.Int.compare t1 t2
+ (* Taken and adapted from JCF code for the implementation
+ without tag *)
+ (*let c = Datatype.Int.compare p1 p2 in
+ if c <> 0 then c else
+ let c = Big_endian.compare m1 m2 in
+ if c <> 0 then c else
+ let c = compare l1 l2 in
+ if c <> 0 then c else
+ compare r1 r2
+ *)
+
+ let compare =
+ if Key.compare == Datatype.undefined
+ then begin
+ Cmdline.Kernel_log.debug
+ "%s shape, missing comparison function" (Type.name Key.ty);
+ Datatype.undefined
+ end
+ else compare_v
+
+ let rec iter f htr =
+ match htr with
+ | Empty -> ()
+ | Leaf (key, data, _) ->
+ f key data
+ | Branch (_, _, tree0, tree1, _tl) ->
+ iter f tree0;
+ iter f tree1
+
+ let pretty pretty_value fmt tree =
+ Pretty_utils.pp_iter2
+ ~pre:"@[<v 3>{[ " ~suf:" ]}@]" ~sep:"@ " ~between:" -> "
+ iter Key.pretty (fun fmt v -> Format.fprintf fmt "@[%a@]" pretty_value v)
+ fmt tree
+
+ let hash = hash_generic
+
+ let equal = ( == )
+
end
module Make
@@ -113,7 +184,8 @@ struct
type key = Key.t
type v = V.t
- type 'a shape = 'a Shape(Key).t
+ module Shape = Shape(Key)
+ type 'a shape = 'a Shape.t
type prefix = int * int
(* A tree is either empty, or a leaf node, containing both
@@ -142,42 +214,14 @@ struct
prefix mask pretty_debug t1 pretty_debug t2
let compare =
- if Key.compare == Datatype.undefined ||
- V.compare == Datatype.undefined
- then (
+ if V.compare == Datatype.undefined
+ then begin
Cmdline.Kernel_log.debug
- "(%s, %s) ptmap, missing comparison function: %b %b"
- (Type.name Key.ty) (Type.name V.ty)
- (Key.compare == Datatype.undefined)
- (V.compare == Datatype.undefined);
- Datatype.undefined
- )
- else
- let compare t1 t2 =
- match t1, t2 with
- | Empty, Empty -> 0
- | Empty, _ -> -1
- | _, Empty -> 1
- | Leaf (k1,x1,_), Leaf (k2,x2,_) ->
- let c = Key.compare k1 k2 in
- if c <> 0 then c else V.compare x1 x2
- | Leaf _, Branch _ -> -1
- | Branch _, Leaf _ -> 1
- | Branch (_p1,_m1,_l1,_r1,t1), Branch (_p2,_m2,_l2,_r2,t2) ->
- let t1 = Tag_comp.get_tag t1 in
- let t2 = Tag_comp.get_tag t2 in
- Datatype.Int.compare t1 t2
- (* Taken and adapted from JCF code for the implementation
- without tag *)
- (*let c = Datatype.Int.compare p1 p2 in
- if c <> 0 then c else
- let c = Big_endian.compare m1 m2 in
- if c <> 0 then c else
- let c = compare l1 l2 in
- if c <> 0 then c else
- compare r1 r2
- *)
- in compare
+ "(%s, %s) ptmap, missing comparison function"
+ (Type.name Key.ty) (Type.name V.ty);
+ Datatype.undefined
+ end
+ else Shape.compare V.compare
let compositional_bool t =
match t with
@@ -197,20 +241,9 @@ struct
| Branch (_,_,_,right,_) -> max_binding right
| Leaf (key, data, _) -> key, data
- let rec iter f htr =
- match htr with
- | Empty -> ()
- | Leaf (key, data, _) ->
- f key data
- | Branch (_, _, tree0, tree1, _tl) ->
- iter f tree0;
- iter f tree1
+ let iter = Shape.iter
- let pretty fmt tree =
- Pretty_utils.pp_iter2
- ~pre:"@[<v 3>{[ " ~suf:" ]}@]" ~sep:"@ " ~between:" -> "
- iter Key.pretty (fun fmt v -> Format.fprintf fmt "@[%a@]" V.pretty v)
- fmt tree
+ let pretty = Shape.pretty V.pretty
let empty = Empty
@@ -441,26 +474,8 @@ struct
matter how large $t_0$ and $t_1$ are, we can merge them simply by
creating a new [Branch] node that has $t_0$ and $t_1$ as children! *)
let join p0 t0 p1 t1 =
- let m = (* Big_Endian.branching_bit p0 p1 in (inlined) *)
- let v = p0 lxor p1 in
- (* compute highest bit.
- First, set all bits with weight less than
- the highest set bit *)
- let v1 = v lsr 1 in
- let v2 = v lsr 2 in
- let v = v lor v1 in
- let v = v lor v2 in
- let v1 = v lsr 3 in
- let v2 = v lsr 6 in
- let v = v lor v1 in
- let v = v lor v2 in
- let v1 = v lsr 9 in
- let v2 = v lsr 18 in
- let v = v lor v1 in
- let v = v lor v2 in
- (* then get highest bit *)
- (succ v) lsr 1
- in
+ (* Computes a mask for the highest bit differing between [p0] and [p1]. *)
+ let m = Big_Endian.branching_bit p0 p1 in
let p = Big_Endian.mask p0 (* for instance *) m in
if (p0 land m) = 0 then
wrap_Branch p m t0 t1
@@ -806,11 +821,9 @@ struct
else if tree1' == Empty then tree0'
else wrap_Branch p m tree0' tree1'
- (* The comment below is outdated: [map] and [endo_map] do not have the
- same signature for [f] *)
(** [endo_map] is similar to [map], but attempts to physically share its
- result with its input. This saves memory when [f] is the identity
- function. *)
+ result with its input. This saves memory when [f] is the identity
+ function. *)
let rec endo_map f tree =
match tree with
| Empty ->
@@ -835,6 +848,16 @@ struct
| Branch (p, m, t1, t2, _) ->
wrap_Branch p m (from_shape f t1) (from_shape f t2)
+ let rec from_shape_id = function
+ | Empty -> Empty
+ | Leaf (key, value, _) -> wrap_Leaf key value
+ | Branch (p, m, t1, t2, _) as t ->
+ let t1' = from_shape_id t1 in
+ let t2' = from_shape_id t2 in
+ if (t1' == t1) && (t2' == t2)
+ then t
+ else wrap_Branch p m t1' t2'
+
module Cacheable = struct
type t = hptmap
diff --git a/src/libraries/utils/hptmap.mli b/src/libraries/utils/hptmap.mli
index 34b2a3e36e1950895f86b7e44b84d1eb48fa9490..c6b2cd2d39512ff501b825f7df053195ce710b2c 100644
--- a/src/libraries/utils/hptmap.mli
+++ b/src/libraries/utils/hptmap.mli
@@ -49,6 +49,11 @@ end
new maps whose shape are already known. *)
module Shape (Key : Id_Datatype): sig
type 'value t
+ val compare: ('value -> 'value -> int) -> 'value t -> 'value t -> int
+ val equal : 'value t -> 'value t -> bool
+ val pretty: 'value Pretty_utils.formatter -> 'value t Pretty_utils.formatter
+ val hash: 'value t -> int
+ val iter: (Key.t -> 'value -> unit) -> 'value t -> unit
end
module Make
diff --git a/src/libraries/utils/hptmap_sig.mli b/src/libraries/utils/hptmap_sig.mli
index c6ae85bcf1e0b6a3e06ae3d826dc33d54c843244..3fdc7a3eb082e3d848e9b2ef81e695e286b3cc22 100644
--- a/src/libraries/utils/hptmap_sig.mli
+++ b/src/libraries/utils/hptmap_sig.mli
@@ -61,8 +61,8 @@ module type S = sig
except for the key [k] which is:
- removed from the map if [f o] = None
- bound to v' if [f o] = Some v'
- where [o] is (Some v) if [k] is bound to [v] in [m], or None if [k]
- is not bound in [m]. *)
+ where [o] is (Some v) if [k] is bound to [v] in [m], or None if [k]
+ is not bound in [m]. *)
val find : key -> t -> v
val find_check_missing: key -> t -> v
@@ -141,9 +141,9 @@ module type S = sig
- Absorbing returns the empty tree;
- (Traversing f) applies the function [f] to each binding of the remaining
subtree [t] (see [map']).
- The results of the function may be cached, depending on [cache]. If a cache
- is used, then the merge functions must be pure.
- *)
+
+ The results of the function may be cached, depending on [cache]. If a
+ cache is used, then the merge functions must be pure. *)
val generic_join :
cache:cache_type ->
@@ -317,6 +317,9 @@ module type S = sig
More efficient than just performing successive {!add} the elements
of the other map *)
+ val from_shape_id: v shape -> t
+ (** Same as [from_shape (fun _ v -> v)]. *)
+
val shape: t -> v shape
(** Export the map as a value suitable for functions {!inter_with_shape}
and {!from_shape} *)
diff --git a/src/plugins/callgraph/cg_viewer.ml b/src/plugins/callgraph/cg_viewer.ml
index 26f47325cfcf36a1f50705424bfee48b100a9f4c..bf2158b9fab14e633ff4ca3c32dece254eba31b8 100644
--- a/src/plugins/callgraph/cg_viewer.ml
+++ b/src/plugins/callgraph/cg_viewer.ml
@@ -33,7 +33,7 @@ class ['v, 'e, 'c] services_view view = object (self)
val services:
(service_id,
bool ref * Services.G.V.t DGraphViewItem.view_item list ref)
- Hashtbl.t
+ Hashtbl.t
= Hashtbl.create 10
method is_root (n:'v DGraphViewItem.view_item) = n#item.Service_graph.is_root
@@ -57,10 +57,10 @@ class ['v, 'e, 'c] services_view view = object (self)
if not (self#is_root n) then n#show ();
view#iter_succ_e
(fun e -> match self#edge_kind e with
- | Service_graph.Inter_functions | Service_graph.Both ->
+ | Service_graph.Inter_functions | Service_graph.Both ->
e#compute ();
e#show ()
- | Service_graph.Inter_services ->
+ | Service_graph.Inter_services ->
e#hide ())
n)
!nodes
@@ -77,8 +77,8 @@ class ['v, 'e, 'c] services_view view = object (self)
if not (self#is_root n) then n#hide ();
view#iter_succ_e
(fun e -> match self#edge_kind e with
- | Service_graph.Inter_services | Service_graph.Both -> e#show ()
- | Service_graph.Inter_functions -> e#hide ())
+ | Service_graph.Inter_services | Service_graph.Both -> e#show ()
+ | Service_graph.Inter_functions -> e#hide ())
n)
!nodes
@@ -86,32 +86,32 @@ class ['v, 'e, 'c] services_view view = object (self)
Kernel_function.get_id n#item.Service_graph.root.Service_graph.node
initializer
- let add_in_service n s =
- try
- let _, nodes = Hashtbl.find services s in
- nodes := n :: !nodes
- with Not_found ->
- Hashtbl.add services s (ref false, ref [ n ])
- in
- let connect_trigger_to_node n =
- let callback = function
- | `BUTTON_PRESS _ ->
+ let add_in_service n s =
+ try
+ let _, nodes = Hashtbl.find services s in
+ nodes := n :: !nodes
+ with Not_found ->
+ Hashtbl.add services s (ref false, ref [ n ])
+ in
+ let connect_trigger_to_node n =
+ let callback = function
+ | `BUTTON_PRESS _ ->
if self#is_deployed (self#service n) then self#undeploy n
else self#deploy n;
false
- | _ ->
+ | _ ->
false
+ in
+ n#connect_event ~callback
in
- n#connect_event ~callback
- in
- view#iter_nodes
- (fun n ->
- add_in_service n (self#service n);
- if self#is_root n then connect_trigger_to_node n else n#hide ());
- view#iter_edges_e
- (fun e -> match self#edge_kind e with
- | Service_graph.Inter_services | Service_graph.Both -> e#show ()
- | Service_graph.Inter_functions -> e#hide ())
+ view#iter_nodes
+ (fun n ->
+ add_in_service n (self#service n);
+ if self#is_root n then connect_trigger_to_node n else n#hide ());
+ view#iter_edges_e
+ (fun e -> match self#edge_kind e with
+ | Service_graph.Inter_services | Service_graph.Both -> e#show ()
+ | Service_graph.Inter_functions -> e#hide ())
end
@@ -160,7 +160,7 @@ let has_entry_point () =
with Globals.No_such_entry_point _ -> false
let can_show_service_graph () =
- has_entry_point () && Options.Service_roots.is_empty ()
+ has_entry_point () && Options.Service_roots.is_empty ()
let get_current_function () =
match History.get_current () with
@@ -200,7 +200,7 @@ let main (window: Design.main_window_extension_points) =
try
(* display the callgraph through its dot output *)
Service_graph.frama_c_display true;
- Gtk_helper.graph_window
+ Dgraph_helper.graph_window
~parent:window#main_window ~title:"Callgraph"
(make_graph_view services);
if warn then
@@ -232,7 +232,7 @@ let main (window: Design.main_window_extension_points) =
else false, false
in
Service_graph.frama_c_display true;
- Gtk_helper.graph_window
+ Dgraph_helper.graph_window
~parent:window#main_window ~title:"Callgraph"
(make_graph_view ~root:kf services);
(* restore old value *)
diff --git a/src/plugins/from/functionwise.ml b/src/plugins/from/functionwise.ml
index 66d83674fe4205892624c5fdf2c01c365a269c53..3233b733bfc3f559d3062b8e4af0aa3769affb49 100644
--- a/src/plugins/from/functionwise.ml
+++ b/src/plugins/from/functionwise.ml
@@ -37,7 +37,7 @@ let () = From_parameters.ForceDeps.set_output_dependencies [Tbl.self]
let force_compute = ref (fun _ -> assert false)
module To_Use = struct
- let get_value_state = Db.Value.get_stmt_state
+ let get_value_state s = Db.Value.get_stmt_state s
let memo kf =
Tbl.memo
diff --git a/src/plugins/gui/design.ml b/src/plugins/gui/design.ml
index 287a5d8e0b01a50e36a5dd37f0f4ea3ba4d3209f..4cf526308c22f254727310396baed427c6e28708 100644
--- a/src/plugins/gui/design.ml
+++ b/src/plugins/gui/design.ml
@@ -1298,18 +1298,18 @@ class main_window () : main_window_extension_points =
method private push_info_buffer :
'a. ?buffer:Buffer.t -> ('a, Format.formatter, unit) format -> 'a =
fun ?buffer fmt ->
- let b = match buffer with
- | None -> Buffer.create 80
- | Some b -> b
- in
- let bfmt = Format.formatter_of_buffer b in
- Format.kfprintf
- (function fmt ->
- Format.pp_print_flush fmt ();
- let content = Buffer.contents b in
- ignore (status_context#push content))
- bfmt
- fmt
+ let b = match buffer with
+ | None -> Buffer.create 80
+ | Some b -> b
+ in
+ let bfmt = Format.formatter_of_buffer b in
+ Format.kfprintf
+ (function fmt ->
+ Format.pp_print_flush fmt ();
+ let content = Buffer.contents b in
+ ignore (status_context#push content))
+ bfmt
+ fmt
method push_info fmt = self#push_info_buffer fmt
diff --git a/src/plugins/gui/dgraph.ml.in b/src/plugins/gui/dgraph_helper.mli
similarity index 79%
rename from src/plugins/gui/dgraph.ml.in
rename to src/plugins/gui/dgraph_helper.mli
index f672460d995880f279523fed4cc47a9e9b3625a3..632035356b8644aace00e2b837cf568565b0285c 100644
--- a/src/plugins/gui/dgraph.ml.in
+++ b/src/plugins/gui/dgraph_helper.mli
@@ -20,19 +20,18 @@
(* *)
(**************************************************************************)
-(* dgraph module that always generates an error: Dgraph is not available
- with gtk3
-*)
+(** Create a new window displaying a graph.
+ @plugin development guide *)
+val graph_window:
+ parent: GWindow.window ->
+ title:string ->
+ (packing:(GObj.widget -> unit) -> unit ->
+ <adapt_zoom: unit -> unit; ..>) ->
+ unit
-module DGraphModel = struct
- exception DotError of string
-end
-
-module DGraphContainer = struct
- type status = Global | Tree | Both
-
- module Dot = struct
- let from_dot_with_commands ?packing:_ ?status:_ _ =
- raise (DGraphModel.DotError "DGraph is unsupported in GTK3")
- end
-end
+(** Create a new window displaying a graph, by printing dot commands. *)
+val graph_window_through_dot:
+ parent: GWindow.window ->
+ title:string ->
+ (Format.formatter -> unit) ->
+ unit
diff --git a/src/plugins/gui/dgraph.mli.in b/src/plugins/gui/dgraph_helper.no.ml
similarity index 73%
rename from src/plugins/gui/dgraph.mli.in
rename to src/plugins/gui/dgraph_helper.no.ml
index 5cf0b53f22586ca29745199c4b73efdbd7401939..9770014dbce818815badcdb8913b9f9fc03c4110 100644
--- a/src/plugins/gui/dgraph.mli.in
+++ b/src/plugins/gui/dgraph_helper.no.ml
@@ -20,23 +20,21 @@
(* *)
(**************************************************************************)
-(* dgraph module that always generates an error: Dgraph is not available
- with gtk3
-*)
+let window_msg_unavailable () =
+ let buttons = GWindow.Buttons.ok in
+ let message_type = `WARNING in
+ let message =
+ "Frama-C has not been compiled against a library with \
+ working graph visualization. Property dependencies graph can't be shown."
+ in
+ let dialog =
+ GWindow.message_dialog ~buttons ~show:true ~message_type ~message ()
+ in
+ let callback _ = dialog#destroy () in
+ ignore (dialog#connect#response ~callback)
-module DGraphModel: sig
- exception DotError of string
-end
+let graph_window ~parent:_ ~title:_ _ =
+ window_msg_unavailable ()
-module DGraphContainer: sig
-
- type status = Global | Tree | Both
-
- module Dot: sig
- val from_dot_with_commands:
- ?packing:(GObj.widget ->unit) ->
- ?status:status ->
- string ->
- GPack.table * <adapt_zoom: unit -> unit>
- end
-end
+let graph_window_through_dot ~parent:_ ~title:_ _ =
+ window_msg_unavailable ()
diff --git a/src/plugins/gui/dgraph_helper.yes.ml b/src/plugins/gui/dgraph_helper.yes.ml
new file mode 100644
index 0000000000000000000000000000000000000000..4ad9e14978b4957569ef8e5594e73f4ef850225a
--- /dev/null
+++ b/src/plugins/gui/dgraph_helper.yes.ml
@@ -0,0 +1,58 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+let graph_window ~parent ~title make_view =
+ let height = int_of_float (float parent#default_height *. 3. /. 4.) in
+ let width = int_of_float (float parent#default_width *. 3. /. 4.) in
+ let graph_window =
+ GWindow.window
+ ~width ~height ~title ~resizable:true ~position:`CENTER ()
+ in
+ let view = make_view ~packing:graph_window#add () in
+ graph_window#show();
+ view#adapt_zoom();
+ ()
+;;
+
+let graph_window_through_dot ~parent ~title dot_formatter =
+ let make_view ~packing () =
+ let temp_file =
+ try
+ Extlib.temp_file_cleanup_at_exit
+ "framac_property_status_navigator_graph" "dot"
+ with Extlib.Temp_file_error s ->
+ Gui_parameters.abort "cannot create temporary file: %s" s in
+ let fmt = Format.formatter_of_out_channel (open_out temp_file) in
+ dot_formatter fmt;
+ Format.pp_print_flush fmt ();
+ let view =
+ snd
+ (Dgraph.DGraphContainer.Dot.from_dot_with_commands ~packing temp_file)
+ in
+ view
+ in
+ try
+ graph_window ~parent ~title make_view
+ with Dgraph.DGraphModel.DotError _ as exn ->
+ Gui_parameters.error
+ "@[cannot display dot graph:@ %s@]"
+ (Printexc.to_string exn)
diff --git a/src/plugins/gui/gtk_helper.ml b/src/plugins/gui/gtk_helper.ml
index 0c3551ccbb0663fc2a0859f8a2c8561377f999f7..24f8b32bd9b57253fcc8bffd85fe726c751c6ad8 100644
--- a/src/plugins/gui/gtk_helper.ml
+++ b/src/plugins/gui/gtk_helper.ml
@@ -1014,44 +1014,6 @@ let spawn_command ?(timeout=0) ?stdout ?stderr s args f =
let prio = Glib.int_of_priority `LOW in
ignore (Glib.Idle.add ~prio for_idle)
-let graph_window ~parent ~title make_view =
- let height = int_of_float (float parent#default_height *. 3. /. 4.) in
- let width = int_of_float (float parent#default_width *. 3. /. 4.) in
- let graph_window =
- GWindow.window
- ~width ~height ~title ~resizable:true ~position:`CENTER ()
- in
- let view = make_view ~packing:graph_window#add () in
- graph_window#show();
- view#adapt_zoom();
- ()
-;;
-
-let graph_window_through_dot ~parent ~title dot_formatter =
- let make_view ~packing () =
- let temp_file =
- try
- Extlib.temp_file_cleanup_at_exit
- "framac_property_status_navigator_graph" "dot"
- with Extlib.Temp_file_error s ->
- Gui_parameters.abort "cannot create temporary file: %s" s in
- let fmt = Format.formatter_of_out_channel (open_out temp_file) in
- dot_formatter fmt;
- Format.pp_print_flush fmt ();
- let view =
- snd
- (Dgraph.DGraphContainer.Dot.from_dot_with_commands ~packing temp_file)
- in
- view
- in
- try
- graph_window ~parent ~title make_view
- with Dgraph.DGraphModel.DotError _ as exn ->
- Gui_parameters.error
- "@[cannot display dot graph:@ %s@]"
- (Printexc.to_string exn)
-;;
-
let image_menu_item ~(image:GObj.widget) ~text ~packing =
let mi = GMenu.menu_item () in
let box =
diff --git a/src/plugins/gui/gtk_helper.mli b/src/plugins/gui/gtk_helper.mli
index 6d9d605b34bf5dd4da7058b20f071f786cbb47f5..c07246254458ee9ab58d18160fa79967b68dd951 100644
--- a/src/plugins/gui/gtk_helper.mli
+++ b/src/plugins/gui/gtk_helper.mli
@@ -426,22 +426,6 @@ val input_string :
parent: GWindow.window -> title:string ->
?ok:string -> ?cancel:string -> ?text:string -> string -> string option
-(** Create a new window displaying a graph.
- @plugin development guide *)
-val graph_window:
- parent: GWindow.window ->
- title:string ->
- (packing:(GObj.widget -> unit) -> unit ->
- <adapt_zoom: unit -> unit; ..>) ->
- unit
-
-(** Create a new window displaying a graph, by printing dot commands. *)
-val graph_window_through_dot:
- parent: GWindow.window ->
- title:string ->
- (Format.formatter -> unit) ->
- unit
-
(** calls the packing function to append a new menu item
with an icon and a label.
replaces GMenu.image_menu_item that has been deprecated in GTK3
diff --git a/src/plugins/gui/property_navigator.ml b/src/plugins/gui/property_navigator.ml
index cd92474f9398805bfe30989a75317a201cb03ec6..ae9042cbff1044acf4c3ca21cdc8b99efcab4dfd 100644
--- a/src/plugins/gui/property_navigator.ml
+++ b/src/plugins/gui/property_navigator.ml
@@ -554,7 +554,8 @@ let make_panel (main_ui:main_window_extension_points) =
| Some { MODEL.finfo = { ip = ip } } ->
let format_graph ppf =
Consolidation_graph.dump (Consolidation_graph.get ip) ppf in
- Gtk_helper.graph_window_through_dot main_ui#main_window "Dependencies" format_graph
+ Dgraph_helper.graph_window_through_dot
+ main_ui#main_window "Dependencies" format_graph
| None -> ()));
view#selection#set_select_function
(fun path currently_selected ->
diff --git a/src/plugins/gui/wutil.ml b/src/plugins/gui/wutil.ml
index 7836b767e86b0f7c75531b592d0589318e1915bd..3804040a2b60035e42ab64795802f0486e055b30 100644
--- a/src/plugins/gui/wutil.ml
+++ b/src/plugins/gui/wutil.ml
@@ -169,9 +169,9 @@ class ['a] signal =
method set_enabled e = enabled <- e
method lock : (unit -> unit) -> unit =
fun f ->
- if not lock then
- try lock <- true ; f () ; lock <- false
- with err -> lock <- false ; raise err
+ if not lock then
+ try lock <- true ; f () ; lock <- false
+ with err -> lock <- false ; raise err
end
class ['a] selector default =
diff --git a/src/plugins/impact/reason_graph.ml b/src/plugins/impact/reason_graph.ml
index 105e52e8137497b06ca8870dbaa70666c37160d6..7b0ec744c4a346bb3ac4bf55dd11b2064dbb2f24 100644
--- a/src/plugins/impact/reason_graph.ml
+++ b/src/plugins/impact/reason_graph.ml
@@ -27,13 +27,13 @@ module NodeSet = PdgTypes.NodeSet
by the effect of [n'], and the impact is of type reason]. *)
type reason_type =
| Intraprocedural of PdgTypes.Dpd.t
- (** The effect of [n'] in [f] impact [n], which is also in [f]. *)
+ (** The effect of [n'] in [f] impact [n], which is also in [f]. *)
| InterproceduralDownward (** the effect of [n'] in [f] has an effect on a
- callee [f'] of [f], in which [n] is located. *)
+ callee [f'] of [f], in which [n] is located. *)
| InterproceduralUpward (** the effect of [n'] in [f] has an effect on a
- caller [f'] of [f] (once the call to [f] has ended), [n] being in [f']. *)
+ caller [f'] of [f] (once the call to [f] has ended), [n] being in [f']. *)
module ReasonType = Datatype.Make(
struct
@@ -75,11 +75,11 @@ let empty = {
}
module DatatypeReason = Datatype.Make(struct
- include Datatype.Serializable_undefined
- type t = reason
- let name = "Impact.Reason_graph.reason"
- let reprs = [empty]
-end)
+ include Datatype.Serializable_undefined
+ type t = reason
+ let name = "Impact.Reason_graph.reason"
+ let reprs = [empty]
+ end)
module type AdditionalInfo = sig
@@ -111,13 +111,13 @@ module Printer (X: AdditionalInfo) = struct
of the nodes belong to X.in_kf *)
let keep_edge (n1, n2, _) =
match X.in_kf with
- | None -> true
- | Some kf ->
- let in_kf n =
- try Kernel_function.equal kf (node_kf n)
- with Not_found -> false
- in
- in_kf n1 || in_kf n2
+ | None -> true
+ | Some kf ->
+ let in_kf n =
+ try Kernel_function.equal kf (node_kf n)
+ with Not_found -> false
+ in
+ in_kf n1 || in_kf n2
let iter_vertex f graph =
(* Construct a set, then iter on it. Otherwise, nodes will be seen more
@@ -125,9 +125,9 @@ module Printer (X: AdditionalInfo) = struct
let all =
Reason.Set.fold
(fun (src, dst, _ as e) acc ->
- if keep_edge e then
- NodeSet.add src (NodeSet.add dst acc)
- else acc
+ if keep_edge e then
+ NodeSet.add src (NodeSet.add dst acc)
+ else acc
) graph NodeSet.empty
in
NodeSet.iter f all
@@ -151,7 +151,7 @@ module Printer (X: AdditionalInfo) = struct
if Pdg_aux.NS.mem v X.initial_nodes then
[`Shape `Diamond; `Color 0x9090FF]
else []
- in
+ in
shape @ [`Label txt]
let edge_attributes (_, _, reason) =
@@ -162,9 +162,9 @@ module Printer (X: AdditionalInfo) = struct
in
let attribs = [`Color color] in
match reason with
- | Intraprocedural dpd ->
- `Label (Pretty_utils.to_string PdgTypes.Dpd.pretty dpd) :: attribs
- | _ -> attribs
+ | Intraprocedural dpd ->
+ `Label (Pretty_utils.to_string PdgTypes.Dpd.pretty dpd) :: attribs
+ | _ -> attribs
let get_subgraph n =
@@ -177,11 +177,18 @@ module Printer (X: AdditionalInfo) = struct
} in
Some attrs
with Not_found -> None
-
end
module Dot (X: AdditionalInfo)= Graph.Graphviz.Dot(Printer(X))
+let to_dot_formatter ?in_kf reason fmt =
+ let module Dot = Dot(struct
+ let nodes_origin = reason.nodes_origin
+ let initial_nodes = reason.initial_nodes
+ let in_kf = in_kf
+ end) in
+ Kernel.Unicode.without_unicode (Dot.fprint_graph fmt) reason.reason_graph
+
(* May raise [Sys_error] *)
let to_dot_file ~temp ?in_kf reason =
let dot_file =
@@ -196,12 +203,8 @@ let to_dot_file ~temp ?in_kf reason =
Options.abort "cannot create temporary file: %s" s
in
let cout = open_out dot_file in
- let module Dot = Dot(struct
- let nodes_origin = reason.nodes_origin
- let initial_nodes = reason.initial_nodes
- let in_kf = in_kf
- end) in
- Kernel.Unicode.without_unicode (Dot.output_graph cout) reason.reason_graph;
+ let fmt = Format.formatter_of_out_channel cout in
+ to_dot_formatter ?in_kf reason fmt;
close_out cout;
dot_file
@@ -213,8 +216,6 @@ let print_dot_graph reason =
Options.error "Could not generate impact graph: %s"
(Printexc.to_string exn)
-
-
(* Very basic textual debugging function *)
let print_reason reason =
let pp_node = !Db.Pdg.pretty_node false in
@@ -222,10 +223,10 @@ let print_reason reason =
Format.fprintf fmt "@[<v 2>%a -> %a (%s)@]"
pp_node nsrc pp_node ndst
(match reason with
- | Intraprocedural dpd ->
- Format.asprintf "intra %a" PdgTypes.Dpd.pretty dpd
- | InterproceduralDownward -> "downward"
- | InterproceduralUpward -> "upward"
+ | Intraprocedural dpd ->
+ Format.asprintf "intra %a" PdgTypes.Dpd.pretty dpd
+ | InterproceduralDownward -> "downward"
+ | InterproceduralUpward -> "upward"
)
in
Options.result "Impact graph:@.%a"
diff --git a/src/plugins/impact/register_gui.ml b/src/plugins/impact/register_gui.ml
index 8d5440c104e789c97c1057151d64ef8d26847445..322197c5bc6bf2c291164653964f996eae190a15 100644
--- a/src/plugins/impact/register_gui.ml
+++ b/src/plugins/impact/register_gui.ml
@@ -27,11 +27,11 @@ open Cil_types
module SelectedStmt = struct
include State_builder.Option_ref
- (Cil_datatype.Stmt)
- (struct
- let name = "Impact_gui.SelectedStmt"
- let dependencies = [ Ast.self ]
- end)
+ (Cil_datatype.Stmt)
+ (struct
+ let name = "Impact_gui.SelectedStmt"
+ let dependencies = [ Ast.self ]
+ end)
let set s =
set s;
@@ -41,9 +41,9 @@ end
let () =
Cmdline.run_after_extended_stage
(fun () ->
- State_dependency_graph.add_codependencies
- ~onto:SelectedStmt.self
- [ !Db.Pdg.self ])
+ State_dependency_graph.add_codependencies
+ ~onto:SelectedStmt.self
+ [ !Db.Pdg.self ])
module Highlighted_stmt : sig
val add: Kernel_function.t -> stmt -> unit
@@ -57,10 +57,10 @@ end = struct
Kernel_function.Make_Table
(Stmt.Set)
(struct
- let name = "Impact_gui.Highlighted_stmt"
- let size = 7
- let dependencies = [ SelectedStmt.self ]
- end)
+ let name = "Impact_gui.Highlighted_stmt"
+ let size = 7
+ let dependencies = [ SelectedStmt.self ]
+ end)
let add kf s =
ignore
@@ -109,12 +109,12 @@ let update_column = ref (fun _ -> ())
(* Are results shown? *)
module Enabled = struct
include State_builder.Ref
- (Datatype.Bool)
- (struct
- let name = "Impact_gui.State"
- let dependencies = []
- let default () = false
- end)
+ (Datatype.Bool)
+ (struct
+ let name = "Impact_gui.State"
+ let dependencies = []
+ let default () = false
+ end)
end
(* Should perform slicing after impact? *)
@@ -125,7 +125,7 @@ module Slicing =
let name = "Impact_gui.Slicing"
let dependencies = []
let default () = false
- end)
+ end)
(* Follow Focus mode *)
module FollowFocus =
@@ -135,7 +135,7 @@ module FollowFocus =
let name = "Impact_gui.FollowFocus"
let dependencies = []
let default () = false
- end)
+ end)
let apply_on_stmt f = function
| PStmt (kf,s) -> f kf s
@@ -154,31 +154,19 @@ let impact_highlighter buffer loc ~start ~stop =
else
SelectedStmt.may
(fun sel -> if Cil_datatype.Stmt.equal sel s then
- tag "selected_impact" "cyan")
+ tag "selected_impact" "cyan")
in
apply_on_stmt hilight loc
-let reason_graph_window main_window ?in_kf reason =
+let reason_graph_window parent ?in_kf reason =
try
- let dot_file = Reason_graph.to_dot_file ~temp:true ?in_kf reason in
- let reason_graph ~packing =
- snd (Dgraph.DGraphContainer.Dot.from_dot_with_commands ~packing dot_file)
- in
- let height = int_of_float (float main_window#default_height *. 3. /. 4.) in
- let width = int_of_float (float main_window#default_width *. 3. /. 4.) in
- let window =
- GWindow.window ~width ~height ~resizable:true ~position:`CENTER ()
- in
- let view = reason_graph ~packing:window#add in
- window#show ();
- view#adapt_zoom ()
+ let mk_dot_file = Reason_graph.to_dot_formatter ?in_kf reason in
+ Dgraph_helper.graph_window_through_dot
+ ~parent ~title:"Impact graph" mk_dot_file
with
- | Dgraph.DGraphModel.DotError _ as exn ->
- Options.error "@[cannot display impact graph:@ %s@]"
- (Printexc.to_string exn)
- | Sys_error _ as exn ->
- Options.error "issue when generating impact graph: %s"
- (Printexc.to_string exn)
+ | Sys_error _ as exn ->
+ Options.error "issue when generating impact graph: %s"
+ (Printexc.to_string exn)
let impact_statement restrict s =
@@ -195,9 +183,9 @@ let impact_statement restrict s =
let stmts = ref [] in
Kernel_function.Map.iter
(fun kf s ->
- let stmts' = Compute_impact.nodes_to_stmts s in
- stmts := stmts' :: !stmts;
- List.iter (Highlighted_stmt.add kf) stmts'
+ let stmts' = Compute_impact.nodes_to_stmts s in
+ stmts := stmts' :: !stmts;
+ List.iter (Highlighted_stmt.add kf) stmts'
) impact;
let impact = List.concat !stmts in
if Slicing.get () then ignore (Register.slice impact);
@@ -227,16 +215,11 @@ let impact_statement_ui (main_ui:Design.main_window_extension_points) s =
else (
!update_column `Contents;
main_ui#rehighlight ()
- );
- if false && Options.Reason.get () then
- let g = ReasonGraph.get () in
- let open Reason_graph in
- if not (Reason.Set.is_empty g.reason_graph) then
- reason_graph_window main_ui#main_window g
+ )
let impact_graph_of_function (main_ui:Design.main_window_extension_points) kf =
let g = ReasonGraph.get () in
- let open Reason_graph in
+ let open Reason_graph in
if not (Reason.Set.is_empty g.reason_graph) then
reason_graph_window main_ui#main_window ~in_kf:kf g
@@ -250,16 +233,16 @@ let pp_impact_on_inputs (main_ui:Design.main_window_extension_points) kf =
let call, formals, zones =
Pdg_aux.NS.fold
(fun (node, z) (call, formals, zones as acc) ->
- match !Pdg.node_key node with
- | SigCallKey _ | CallStmt _ | Stmt _ | Label _ ->
- acc (* Related to one stmt: skip *)
- | VarDecl _ -> acc (* skip *)
- | SigKey (Out _) -> acc (* probably impossible *)
- | SigKey (In InCtrl) -> (true, formals, zones)
- | SigKey (In (InNum i)) -> (call, i :: formals, zones)
- | SigKey (In (InImpl z')) ->
- let z = Locations.Zone.narrow z z' in
- (call, formals, Locations.Zone.join zones z)
+ match !Pdg.node_key node with
+ | SigCallKey _ | CallStmt _ | Stmt _ | Label _ ->
+ acc (* Related to one stmt: skip *)
+ | VarDecl _ -> acc (* skip *)
+ | SigKey (Out _) -> acc (* probably impossible *)
+ | SigKey (In InCtrl) -> (true, formals, zones)
+ | SigKey (In (InNum i)) -> (call, i :: formals, zones)
+ | SigKey (In (InImpl z')) ->
+ let z = Locations.Zone.narrow z z' in
+ (call, formals, Locations.Zone.join zones z)
) nodes (false, [], Locations.Zone.bottom)
in
if call = true || formals <> [] || not (Locations.Zone.is_bottom zones) then
@@ -267,17 +250,18 @@ let pp_impact_on_inputs (main_ui:Design.main_window_extension_points) kf =
main_ui#pretty_information
"@[<hov 2>Impacted inputs of the function:@ %t%t@]@."
(fun fmt ->
- if call then
- Format.fprintf fmt "call@ may@ be@ entirely@ skipped; ")
+ if call then
+ Format.fprintf fmt "call@ may@ be@ entirely@ skipped; ")
(fun fmt ->
- if formals <> [] then
- Pretty_utils.pp_list ~pre:"argument(s)@ " ~sep:"@ " ~suf:",@ "
- Datatype.Int.pretty fmt formals;
- if not (Locations.Zone.is_bottom zones) then
- Locations.Zone.pretty fmt zones
+ if formals <> [] then
+ Pretty_utils.pp_list ~pre:"argument(s)@ " ~sep:"@ " ~suf:",@ "
+ Datatype.Int.pretty fmt formals;
+ if not (Locations.Zone.is_bottom zones) then
+ Locations.Zone.pretty fmt zones
)
-let pp_impacted_call_outputs (main_ui:Design.main_window_extension_points) kf call_stmt =
+let pp_impacted_call_outputs
+ (main_ui:Design.main_window_extension_points) kf call_stmt =
let nodes = impact_in_kf kf in
if !pretty_info && not (Pdg_aux.NS.is_empty nodes) then
let open PdgIndex.Signature in
@@ -285,17 +269,17 @@ let pp_impacted_call_outputs (main_ui:Design.main_window_extension_points) kf ca
let ret, zones =
Pdg_aux.NS.fold
(fun (node, z) (ret, zones as acc) ->
- match !Pdg.node_key node with
- | SigCallKey (stmt', key)
- when Cil_datatype.Stmt.equal call_stmt stmt' ->
- (match key with
- | In _ -> acc (* impossible *)
- | Out OutRet -> (true, zones)
- | Out (OutLoc z') ->
- let z = Locations.Zone.narrow z z' in
- (ret, Locations.Zone.join zones z)
- )
- | _ -> acc
+ match !Pdg.node_key node with
+ | SigCallKey (stmt', key)
+ when Cil_datatype.Stmt.equal call_stmt stmt' ->
+ (match key with
+ | In _ -> acc (* impossible *)
+ | Out OutRet -> (true, zones)
+ | Out (OutLoc z') ->
+ let z = Locations.Zone.narrow z z' in
+ (ret, Locations.Zone.join zones z)
+ )
+ | _ -> acc
) nodes (false, Locations.Zone.bottom)
in
if ret = true || not (Locations.Zone.is_bottom zones) then
@@ -303,49 +287,57 @@ let pp_impacted_call_outputs (main_ui:Design.main_window_extension_points) kf ca
"@[<hov 2>Memory impacted by this call:@ %t%t@]@."
(fun fmt -> if ret then Format.fprintf fmt "return code; ")
(fun fmt ->
- if not (Locations.Zone.is_bottom zones) then
- Locations.Zone.pretty fmt zones
+ if not (Locations.Zone.is_bottom zones) then
+ Locations.Zone.pretty fmt zones
)
let impact_selector
(popup_factory:GMenu.menu GMenu.factory) main_ui ~button localizable =
match localizable with
- | PStmt (kf, s) ->
- if button = 3 || FollowFocus.get () then (
- let callback () = ignore (impact_statement_ui main_ui s) in
- ignore (popup_factory#add_item "_Impact analysis" ~callback);
- if FollowFocus.get () then
- ignore (Glib.Idle.add (fun () -> callback (); false))
- );
- if button = 1 then begin
- (* Initial nodes, at the source of the impact *)
- (match SelectedStmt.get_option () with
- | Some s' when Cil_datatype.Stmt.equal s s' ->
- if !pretty_info then
- main_ui#pretty_information "@[Impact initial nodes:@ %a@]@."
- (Pretty_utils.pp_iter Pdg_aux.NS.iter'
- ~sep:",@ " Pdg_aux.pretty_node)
- (InitialNodes.get ());
- | _ -> ()
- );
- pp_impacted_call_outputs main_ui kf s
- end
-
- | PVDecl (_, _, vi) | PGlobal (GFun ({ svar = vi }, _))
- when Cil.isFunctionType vi.vtype ->
- if button = 1 then begin
- let kf = Globals.Functions.get vi in
- pp_impact_on_inputs main_ui kf;
- end;
- if button = 3 then begin
- let g = ReasonGraph.get () in
- let open Reason_graph in
- if not (Reason.Set.is_empty g.reason_graph) then
- let kf = Globals.Functions.get vi in
- let callback () = impact_graph_of_function main_ui kf in
- ignore (popup_factory#add_item "_Impact graph" ~callback);
- end
- | _ -> ()
+ | PStmt (kf, s) ->
+ if button = 3 || FollowFocus.get () then (
+ let callback () = ignore (impact_statement_ui main_ui s) in
+ ignore (popup_factory#add_item "_Impact analysis" ~callback);
+ if Options.Reason.get ()then begin
+ let g = ReasonGraph.get () in
+ if not Reason_graph.(Reason.Set.is_empty g.reason_graph) then begin
+ let callback () =
+ reason_graph_window main_ui#main_window ~in_kf:kf g in
+ ignore (popup_factory#add_item "Impact _graph" ~callback);
+ end;
+ end;
+ if FollowFocus.get () then
+ ignore (Glib.Idle.add (fun () -> callback (); false))
+ );
+ if button = 1 then begin
+ (* Initial nodes, at the source of the impact *)
+ (match SelectedStmt.get_option () with
+ | Some s' when Cil_datatype.Stmt.equal s s' ->
+ if !pretty_info then
+ main_ui#pretty_information "@[Impact initial nodes:@ %a@]@."
+ (Pretty_utils.pp_iter Pdg_aux.NS.iter'
+ ~sep:",@ " Pdg_aux.pretty_node)
+ (InitialNodes.get ());
+ | _ -> ()
+ );
+ pp_impacted_call_outputs main_ui kf s
+ end
+
+ | PVDecl (_, _, vi) | PGlobal (GFun ({ svar = vi }, _))
+ when Cil.isFunctionType vi.vtype ->
+ if button = 1 then begin
+ let kf = Globals.Functions.get vi in
+ pp_impact_on_inputs main_ui kf;
+ end;
+ if button = 3 then begin
+ let g = ReasonGraph.get () in
+ let open Reason_graph in
+ if not (Reason.Set.is_empty g.reason_graph) then
+ let kf = Globals.Functions.get vi in
+ let callback () = impact_graph_of_function main_ui kf in
+ ignore (popup_factory#add_item "_Impact graph" ~callback);
+ end
+ | _ -> ()
let impact_panel main_ui =
let w = GPack.vbox () in
@@ -353,9 +345,9 @@ let impact_panel main_ui =
let enabled_button =
on_bool w "Enable" Enabled.get
(fun b ->
- Enabled.set b;
- !update_column `Visibility;
- main_ui#rehighlight ())
+ Enabled.set b;
+ !update_column `Visibility;
+ main_ui#rehighlight ())
in
let slicing_button =
on_bool w "Slicing after impact" Slicing.get Slicing.set
@@ -376,19 +368,19 @@ let file_tree_decorate (file_tree:Filetree.t) =
file_tree#append_pixbuf_column
~title:"Impact"
(fun globs ->
- let is_hilighted = function
- | GFun ({svar = v }, _) ->
- Highlighted_stmt.mem_kf (Globals.Functions.get v)
- | _ -> false
- in
- let id =
- (* laziness of && is used for efficiency *)
- if Enabled.get () && SelectedStmt.get_option () <> None &&
- List.exists is_hilighted globs then "gtk-apply"
- else ""
- in
- [ `STOCK_ID id ])
- (fun () -> Enabled.get () && SelectedStmt.get_option () <> None);
+ let is_hilighted = function
+ | GFun ({svar = v }, _) ->
+ Highlighted_stmt.mem_kf (Globals.Functions.get v)
+ | _ -> false
+ in
+ let id =
+ (* laziness of && is used for efficiency *)
+ if Enabled.get () && SelectedStmt.get_option () <> None &&
+ List.exists is_hilighted globs then "gtk-apply"
+ else ""
+ in
+ [ `STOCK_ID id ])
+ (fun () -> Enabled.get () && SelectedStmt.get_option () <> None);
!update_column `Visibility
let main main_ui =
diff --git a/src/plugins/inout/operational_inputs.ml b/src/plugins/inout/operational_inputs.ml
index 1c070d2ddf96a72f356d251e2394de36da5f4ced..ea48d5ad04b302cde1962649b6154f0c8b2e16db 100644
--- a/src/plugins/inout/operational_inputs.ml
+++ b/src/plugins/inout/operational_inputs.ml
@@ -115,20 +115,21 @@ let eval_assigns kf state assigns =
not (Kernel_function.is_formal v kf)
| Base.CLogic_Var _ | Base.Null | Base.String _ -> true)
in
+ let out_term = out.it_content in
let outputs_under, outputs_over, deps =
try
- if Logic_utils.is_result out.it_content
+ if Logic_const.(is_result out_term || is_exit_status out_term)
then (Zone.bottom, Zone.bottom, Zone.bottom)
else
let loc_out_under, loc_out_over, deps =
- !Db.Properties.Interp.loc_to_loc_under_over ~result:None state out.it_content
+ !Db.Properties.Interp.loc_to_loc_under_over ~result:None state out_term
in
(enumerate_valid_bits_under Write loc_out_under,
enumerate_valid_bits Write loc_out_over,
clean_deps deps)
with Db.Properties.Interp.No_conversion ->
Inout_parameters.warning ~current:true ~once:true
- "failed to interpret assigns clause '%a'" Printer.pp_term out.it_content;
+ "failed to interpret assigns clause '%a'" Printer.pp_term out_term;
(Zone.bottom, Zone.top, Zone.top)
in
(* Compute all inputs as a zone *)
@@ -699,7 +700,7 @@ module FunctionWise = struct
let module Computer = Computer(Fenv)(struct
let _version = "functionwise"
let _kf = kf
- let stmt_state = Db.Value.get_stmt_state
+ let stmt_state s = Db.Value.get_stmt_state s
let at_call stmt kf = get_external_aux ~stmt kf
end) in
Stack.iter
diff --git a/src/plugins/qed/listmap.ml b/src/plugins/qed/listmap.ml
index d83fbecf9bc96f487b8932022a807d2bdd756a1b..b8e3d5aab747b37efe9b35121f5f359d6a608cc4 100644
--- a/src/plugins/qed/listmap.ml
+++ b/src/plugins/qed/listmap.ml
@@ -43,6 +43,7 @@ struct
let equal eq = Hcons.equal_list (fun (i,x) (j,y) -> K.equal i j && eq x y)
let empty = []
+ let is_empty = function [] -> true | _ -> false
(* used for better sharing between a list and a modified list *)
let rev_append_until i l1 l2 =
diff --git a/src/plugins/qed/listmap.mli b/src/plugins/qed/listmap.mli
index 5819c1b62ae7b9918baf261a6939ec1c76c3a004..2c8d45acd8c2aca57560412886fdfd1bcb5527c1 100644
--- a/src/plugins/qed/listmap.mli
+++ b/src/plugins/qed/listmap.mli
@@ -42,6 +42,8 @@ sig
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val empty : 'a t
+ val is_empty : 'a t -> bool
+
val add : key -> 'a -> 'a t -> 'a t
val mem : key -> 'a t -> bool
val find : key -> 'a t -> 'a
diff --git a/src/plugins/qed/listset.ml b/src/plugins/qed/listset.ml
index 228dfd3439e239797292da925ac9ac6f07e73920..ab081f890b2c86987e4e6cd30832ac8a7adc13a7 100644
--- a/src/plugins/qed/listset.ml
+++ b/src/plugins/qed/listset.ml
@@ -42,6 +42,7 @@ struct
let equal = Hcons.equal_list E.equal
let empty = []
+ let is_empty = function [] -> true | _ -> false
(* used for better sharing between a list and a modified list *)
let rev_append_until i l1 l2 =
diff --git a/src/plugins/qed/listset.mli b/src/plugins/qed/listset.mli
index e37b3a70c4cfcc71b479a66a7cb74560bc9be49d..761b54bd054ed02aa158bf6d08307204cddca987 100644
--- a/src/plugins/qed/listset.mli
+++ b/src/plugins/qed/listset.mli
@@ -41,6 +41,7 @@ sig
val compare : t -> t -> int
val empty : t
+ val is_empty : t -> bool
(* good sharing *)
val add : elt -> t -> t
diff --git a/src/plugins/qed/logic.ml b/src/plugins/qed/logic.ml
index 4f1a82c6759eb17ad4812cec64dc1d0096a5fbfd..b9d0ee14b1e19d06d027192e4f0cdf1048abf1fe 100644
--- a/src/plugins/qed/logic.ml
+++ b/src/plugins/qed/logic.ml
@@ -519,9 +519,9 @@ sig
order of definition: each trailing terms only depend on heading ones.
The traversal is controlled by two optional arguments:
- - [shared] those terms are not traversed (considered as atomic, default to none)
- - [shareable] those terms ([is_simple] excepted) that can be shared (default to all)
- - [subterms] those sub-terms a term to be considered during
+ - [shared] those terms are not traversed (considered as atomic, default to none)
+ - [shareable] those terms ([is_simple] excepted) that can be shared (default to all)
+ - [subterms] those sub-terms a term to be considered during
traversal ([lc_iter] by default)
*)
diff --git a/src/plugins/rte/visit.ml b/src/plugins/rte/visit.ml
index a5e8ad38578f28365e4d918436372992d73386f9..f8e123d52089317afb287a36c3f50da7dcaedb11 100644
--- a/src/plugins/rte/visit.ml
+++ b/src/plugins/rte/visit.ml
@@ -108,15 +108,15 @@ class annot_visitor kf flags on_alarm = object (self)
method private generate_assertion: 'a. 'a Rte.alarm_gen -> 'a -> unit =
fun fgen ->
- let curr_stmt = self#current_stmt in
- let on_alarm ~invalid a =
- match curr_stmt with
- | None -> Options.warning ~current:true
- "Alarm generated outside any statement:@ %a"
- Alarms.pretty a
- | Some stmt -> on_alarm stmt ~invalid a
- in
- fgen ~remove_trivial:flags.Flags.remove_trivial ~on_alarm
+ let curr_stmt = self#current_stmt in
+ let on_alarm ~invalid a =
+ match curr_stmt with
+ | None -> Options.warning ~current:true
+ "Alarm generated outside any statement:@ %a"
+ Alarms.pretty a
+ | Some stmt -> on_alarm stmt ~invalid a
+ in
+ fgen ~remove_trivial:flags.Flags.remove_trivial ~on_alarm
(* Do not visit variable declarations, as no alarm should be emitted here,
and there is no statement to emit an alarm anyway ([generate_assertion]
diff --git a/src/plugins/server/Makefile.in b/src/plugins/server/Makefile.in
index f70395724dae585cc902a00f8ca0dcc190d9ace0..4035bc252a9bffce81e5de5b686fba20e51908cb 100644
--- a/src/plugins/server/Makefile.in
+++ b/src/plugins/server/Makefile.in
@@ -29,17 +29,13 @@ ifndef FRAMAC_LIBDIR
FRAMAC_LIBDIR :=$(shell frama-c-config -print-libpath)
endif
-include $(FRAMAC_SHARE)/Makefile.config
-# --------------------------------------------------------------------------
-# --- Plugin Setting
-# --------------------------------------------------------------------------
+###################
+# Plug-in Setting #
+###################
+PLUGIN_DIR ?=.
PLUGIN_ENABLE:=@ENABLE_SERVER@
PLUGIN_NAME:=Server
-PLUGIN_DISTRIBUTED:=$(PLUGIN_ENABLE)
-PLUGIN_DISTRIB_EXTERNAL:= Makefile.in configure.ac configure
-
-PLUGIN_REQUIRES:= yojson
PLUGIN_CMO:= \
server_parameters \
jbuffer \
@@ -48,30 +44,34 @@ PLUGIN_CMO:= \
kernel_main \
kernel_project \
kernel_ast
+PLUGIN_DISTRIBUTED:=$(PLUGIN_ENABLE)
+PLUGIN_DISTRIB_EXTERNAL:= Makefile.in configure.ac configure
+PLUGIN_TESTS_DIRS := batch
+
+PLUGIN_REQUIRES:= yojson
PLUGIN_UNDOC:= server_batch.ml server_zmq.ml
PLUGIN_GENERATED:= $(PLUGIN_DIR)/Server.mli
-PLUGIN_TESTS :=
-# --------------------------------------------------------------------------
-# --- ZeroMQ Support
-# --------------------------------------------------------------------------
+##################
+# ZeroMQ Support #
+##################
ifeq (@SERVER_ZMQ@,yes)
PLUGIN_REQUIRES+= zmq
PLUGIN_CMO+= server_zmq
endif
-# --------------------------------------------------------------------------
-# --- Frama-C Dynamic Plug-in
-# --------------------------------------------------------------------------
+################
+# Generic part #
+################
include $(FRAMAC_SHARE)/Makefile.dynamic
-# --------------------------------------------------------------------------
-# --- Server API
-# --------------------------------------------------------------------------
+##############
+# Server API #
+##############
SERVER_API= \
doc.mli syntax.mli data.mli request.mli
@@ -100,9 +100,9 @@ $(Server_DIR)/Server.mli: $(Server_DIR)/Makefile $(SERVER_MLI)
$(CHMOD_RO) $@.tmp
$(MV) $@.tmp $@
-# --------------------------------------------------------------------------
-# --- Configure
-# --------------------------------------------------------------------------
+#####################################
+# Regenerating the Makefile on need #
+#####################################
ifeq ("$(FRAMAC_INTERNAL)","yes")
CONFIG_STATUS_DIR=$(FRAMAC_SRC)
@@ -113,5 +113,3 @@ endif
$(Server_DIR)/Makefile: $(Server_DIR)/Makefile.in \
$(CONFIG_STATUS_DIR)/config.status
cd $(CONFIG_STATUS_DIR) && ./config.status --file $@
-
-# --------------------------------------------------------------------------
diff --git a/src/plugins/server/data.mli b/src/plugins/server/data.mli
index 8c12a9465e4098629c4a1afd215439e31a481ef8..3e10ece5cbfb35d8753129d85d094c118919bab0 100644
--- a/src/plugins/server/data.mli
+++ b/src/plugins/server/data.mli
@@ -40,9 +40,9 @@ end
(** Datatype registration.
Name and page must be consistent with each other:
- - The name must be lowercase, dash-separated list of identifiers
- - Protocol data must start with ["<server>-*"]
- - Plugin data must start with ["<plugin>-*"]
+ - The name must be lowercase, dash-separated list of identifiers
+ - Protocol data must start with ["<server>-*"]
+ - Plugin data must start with ["<plugin>-*"]
*)
module type Info =
sig
diff --git a/src/plugins/server/request.mli b/src/plugins/server/request.mli
index c855405cb85088b1d88e60660a5a6e86e268493e..51d2ac92caf569f6a3e67ac342231468eee638ec 100644
--- a/src/plugins/server/request.mli
+++ b/src/plugins/server/request.mli
@@ -49,12 +49,12 @@ type 'b output = (module Output with type t = 'b)
(** Register a simple request of type [(a -> b)].
Name, page and kind must be consistent with each others:
- - No publication on [`Protocol] pages
- - Kernel requests shall starts with ["Kernel.*"]
- - Plugin requests shall starts with ["<Plugin>.*"]
- - SET requests must contain ["set"] (case insensitive)
- - GET requests must contain ["get"] or ["print"] (case insensitive)
- - EXEC requests must contain ["exec"] or ["compute"] (case insensitive)
+ - No publication on [`Protocol] pages
+ - Kernel requests shall starts with ["Kernel.*"]
+ - Plugin requests shall starts with ["<Plugin>.*"]
+ - SET requests must contain ["set"] (case insensitive)
+ - GET requests must contain ["get"] or ["print"] (case insensitive)
+ - EXEC requests must contain ["exec"] or ["compute"] (case insensitive)
*)
val register :
diff --git a/src/plugins/server/server_batch.ml b/src/plugins/server/server_batch.ml
index 0aa3c03b310a2c1104baf91a712a17bd17a9f01b..87a3fd9c4907562237c4d23e495f91397a59df10 100644
--- a/src/plugins/server/server_batch.ml
+++ b/src/plugins/server/server_batch.ml
@@ -41,8 +41,19 @@ module Batch = Senv.String_list
associated results in <file.out.json>."
end)
+let () = Parameter_customize.set_group batch_group
+module BatchOutputDir = Senv.Empty_string
+ (struct
+ let option_name = "-server-batch-output-dir"
+ let arg_name = "path"
+ let help =
+ "Outputs the results of -server-batch in <path> instead of the input \
+ directory."
+ end)
+
let _ = Doc.page `Protocol ~title:"Batch Protocol" ~filename:"server_batch.md"
+
(* -------------------------------------------------------------------------- *)
(* --- Execute JSON --- *)
(* -------------------------------------------------------------------------- *)
@@ -64,9 +75,8 @@ let execute_command js =
try
Senv.feedback "[%a] %s" Main.pp_kind kind request ;
`Assoc [ "id" , id ; "data" , handler data ]
- with Ju.Type_error(msg,js) ->
- Senv.error "[%s] incorrect encoding:@\n%s@\n@[<hov 2>At: %a@]@."
- request msg pretty js ;
+ with Data.InputError(msg) ->
+ Senv.error "[%s] %s@." request msg ;
`Assoc [ "id" , id ; "error" , `String msg ; "at" , js ]
let rec execute_batch js =
@@ -90,9 +100,15 @@ let execute () =
begin fun file ->
Senv.feedback "Script %S" file ;
let response = execute_batch (Js.from_file file) in
- let output = Filename.remove_extension file ^ ".out.js" in
+ let output = Filename.remove_extension file ^ ".out.json" in
+ let output = match BatchOutputDir.get () with
+ | "" -> output
+ | dir -> Filename.(dir ^ dir_sep ^ basename output)
+ in
Senv.feedback "Output %S" output ;
- Js.to_file output response ;
+ let out = open_out output in
+ Js.pretty_to_channel out response ;
+ close_out out
end
(Batch.get()) ;
end
diff --git a/src/plugins/server/tests/.gitignore b/src/plugins/server/tests/.gitignore
new file mode 100644
index 0000000000000000000000000000000000000000..e2f5dd2eb20cb10838ae60e263317b57fdec63e7
--- /dev/null
+++ b/src/plugins/server/tests/.gitignore
@@ -0,0 +1 @@
+result
\ No newline at end of file
diff --git a/src/plugins/server/tests/batch/ast_services.i b/src/plugins/server/tests/batch/ast_services.i
new file mode 100644
index 0000000000000000000000000000000000000000..b875167edd1a3b6d5904bb4db378c8be91b18310
--- /dev/null
+++ b/src/plugins/server/tests/batch/ast_services.i
@@ -0,0 +1,2 @@
+void main() {}
+void f() {}
\ No newline at end of file
diff --git a/src/plugins/server/tests/batch/ast_services.json b/src/plugins/server/tests/batch/ast_services.json
new file mode 100644
index 0000000000000000000000000000000000000000..45254f96445b99992be0bc44a46207c195e72b54
--- /dev/null
+++ b/src/plugins/server/tests/batch/ast_services.json
@@ -0,0 +1,4 @@
+[
+ { id:"getFunctions", request:"kernel.ast.getFunctions", data:null },
+ { id:"printFunction", request:"kernel.ast.printFunction", data:"f" }
+]
\ No newline at end of file
diff --git a/src/plugins/server/tests/batch/kernel_services.i b/src/plugins/server/tests/batch/kernel_services.i
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/src/plugins/server/tests/batch/kernel_services.json b/src/plugins/server/tests/batch/kernel_services.json
new file mode 100644
index 0000000000000000000000000000000000000000..5b58c627bfe01240de30931928d88a35352fbc83
--- /dev/null
+++ b/src/plugins/server/tests/batch/kernel_services.json
@@ -0,0 +1,4 @@
+[
+ { id:"getLogs", request:"kernel.getLogs", data:null },
+ { id:"setLogs", request:"kernel.setLogs", data:false }
+]
\ No newline at end of file
diff --git a/src/plugins/server/tests/batch/oracle/ast_services.out.json b/src/plugins/server/tests/batch/oracle/ast_services.out.json
new file mode 100644
index 0000000000000000000000000000000000000000..40a40546e0dd93809a46d584a1df5efa783faf27
--- /dev/null
+++ b/src/plugins/server/tests/batch/oracle/ast_services.out.json
@@ -0,0 +1,14 @@
+[
+ { "id": "getFunctions", "data": [ "f", "main" ] },
+ {
+ "id": "printFunction",
+ "data": [
+ "",
+ [ "#v19", "void f(void)" ],
+ "\n{\n ",
+ [ "#s7", [ "#k7", "return;" ] ],
+ "\n}\n",
+ "\n"
+ ]
+ }
+]
\ No newline at end of file
diff --git a/src/plugins/server/tests/batch/oracle/ast_services.res.oracle b/src/plugins/server/tests/batch/oracle/ast_services.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..f91a4f9d11d9733287e6673255e3dc07ccf12def
--- /dev/null
+++ b/src/plugins/server/tests/batch/oracle/ast_services.res.oracle
@@ -0,0 +1,5 @@
+[kernel] Parsing tests/batch/ast_services.i (no preprocessing)
+[server] Script "tests/batch/ast_services.json"
+[server] [GET] kernel.ast.getFunctions
+[server] [GET] kernel.ast.printFunction
+[server] Output "tests/batch/result/ast_services.out.json"
diff --git a/src/plugins/server/tests/batch/oracle/kernel_services.out.json b/src/plugins/server/tests/batch/oracle/kernel_services.out.json
new file mode 100644
index 0000000000000000000000000000000000000000..80065331f0735613e4a74e0a75df36f60d10ac4f
--- /dev/null
+++ b/src/plugins/server/tests/batch/oracle/kernel_services.out.json
@@ -0,0 +1 @@
+[ { "id": "getLogs", "data": [] }, { "id": "setLogs", "data": null } ]
\ No newline at end of file
diff --git a/src/plugins/server/tests/batch/oracle/kernel_services.res.oracle b/src/plugins/server/tests/batch/oracle/kernel_services.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..7e1c091eeec6f5d3fdd51a5d05c677f0e1fee812
--- /dev/null
+++ b/src/plugins/server/tests/batch/oracle/kernel_services.res.oracle
@@ -0,0 +1,5 @@
+[kernel] Parsing tests/batch/kernel_services.i (no preprocessing)
+[server] Script "tests/batch/kernel_services.json"
+[server] [GET] kernel.getLogs
+[server] [SET] kernel.setLogs
+[server] Output "tests/batch/result/kernel_services.out.json"
diff --git a/src/plugins/server/tests/batch/oracle/wrong.out.json b/src/plugins/server/tests/batch/oracle/wrong.out.json
new file mode 100644
index 0000000000000000000000000000000000000000..4bf1761a32d70d5658b681897a5b5278f43511f8
--- /dev/null
+++ b/src/plugins/server/tests/batch/oracle/wrong.out.json
@@ -0,0 +1,14 @@
+[
+ { "id": "unknown request", "error": "request not found" },
+ {
+ "id": "wrong data",
+ "error":
+ "Expected string, got object:\n{ \"f1\": 1, \"f2\": { \"x\": 1, \"y\": 2 }, \"f3\": null }",
+ "at": {
+ "id": "wrong data",
+ "request": "kernel.ast.printFunction",
+ "data": { "f1": 1, "f2": { "x": 1, "y": 2 }, "f3": null },
+ "comment": "ident is expected, object is given"
+ }
+ }
+]
\ No newline at end of file
diff --git a/src/plugins/server/tests/batch/oracle/wrong.res.oracle b/src/plugins/server/tests/batch/oracle/wrong.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..76ac96361f0316a6703142ce491f2500e89790ee
--- /dev/null
+++ b/src/plugins/server/tests/batch/oracle/wrong.res.oracle
@@ -0,0 +1,9 @@
+[kernel] Parsing tests/batch/wrong.i (no preprocessing)
+[server] Script "tests/batch/wrong.json"
+[server] User Error: [batch] "unknown request": request "kernel.unknown" not found
+[server] [GET] kernel.ast.printFunction
+[server] User Error: [kernel.ast.printFunction] Expected string, got object:
+ { "f1": 1, "f2": { "x": 1, "y": 2 }, "f3": null }
+[server] Output "tests/batch/result/wrong.out.json"
+[server] User Error: Deferred error message was emitted during execution. See above messages for more information.
+[kernel] Plug-in server aborted: invalid user input.
diff --git a/src/plugins/server/tests/batch/test_config b/src/plugins/server/tests/batch/test_config
new file mode 100644
index 0000000000000000000000000000000000000000..15a16cd4f95d4ced405bb04b6a13382efcd47e7f
--- /dev/null
+++ b/src/plugins/server/tests/batch/test_config
@@ -0,0 +1,2 @@
+LOG: @PTEST_NAME@.out.json
+OPT: -no-autoload-plugins -load-module server -check -server-batch @PTEST_DIR@/@PTEST_NAME@.json -server-batch-output-dir @PTEST_RESULT@
diff --git a/src/plugins/server/tests/batch/wrong.i b/src/plugins/server/tests/batch/wrong.i
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/src/plugins/server/tests/batch/wrong.json b/src/plugins/server/tests/batch/wrong.json
new file mode 100644
index 0000000000000000000000000000000000000000..0178e8af2950cbc6b6a49d98367265e2bf993989
--- /dev/null
+++ b/src/plugins/server/tests/batch/wrong.json
@@ -0,0 +1,4 @@
+[
+ { id:"unknown request", request:"kernel.unknown", data:null, comment:"the request doesn't exist" },
+ { id:"wrong data", request:"kernel.ast.printFunction", data:{f1:1, f2:{x:1, y:2}, f3:null}, comment:"ident is expected, object is given" }
+]
\ No newline at end of file
diff --git a/src/plugins/value/domains/abstract_domain.mli b/src/plugins/value/domains/abstract_domain.mli
index b512325ade4b44e3cc3eecf4700c20f1de57a9e3..1b8ed544fad1662faaae03fbbf7678e2b27b818b 100644
--- a/src/plugins/value/domains/abstract_domain.mli
+++ b/src/plugins/value/domains/abstract_domain.mli
@@ -128,8 +128,8 @@ module type Queries = sig
of [exp]. [Alarmset.all] is always a sound over-approximation of these
alarms.
- a value for the expression, which can be:
- - `Bottom if its evaluation is infeasible;
- - `Value (v, o) where [v] is an over-approximation of the abstract
+ – `Bottom if its evaluation is infeasible;
+ – `Value (v, o) where [v] is an over-approximation of the abstract
value of the expression [exp], and [o] is the origin of the value. *)
(** Query function for compound expressions:
@@ -193,6 +193,8 @@ module type Transfer = sig
assignment has been performed.
- [kinstr] is the statement of the assignment, or Kglobal for the
initialization of a global variable.
+ - when the kinstr is a function call, [expr] is the special variable in
+ [!Eval.call.return].
- [v] carries the value being assigned to [lv], i.e. the value of the
expression [expr]. [v] also denotes the kind of assignment: Assign for
the default assignment of the value, or Copy for the exact copy of a
@@ -230,7 +232,7 @@ module type Transfer = sig
- [stmt] is the statement of the call site;
- [call] represents the function call and its arguments.
- [pre] and [post] are the states before and at the end of the call
- respectively. *)
+ respectively. *)
val finalize_call:
stmt -> (location, value) call -> pre:state -> post:state -> state or_bottom
@@ -382,8 +384,8 @@ module type S = sig
(** [initialize_variable lval loc ~initialized init_value state] initializes
the value of the location [loc] of lvalue [lval] in [state] with:
- - bits 0 if init_value = Zero;
- - any bits if init_value = Top.
+ – bits 0 if init_value = Zero;
+ – any bits if init_value = Top.
The boolean initialized is true if the location is initialized, and false
if the location may be not initialized. *)
val initialize_variable:
@@ -394,73 +396,12 @@ module type S = sig
val initialize_variable_using_type: init_kind -> varinfo -> t -> t
include Recycle with type t := t
-end
-
-
-(** Keys identify abstract domains through the type of their abstract values. *)
-type 'a key = 'a Structure.Key_Domain.k
-
-(** Describes the internal structure of a domain.
- Used internally to automatically generate efficient accessors from a
- generic abstract domain, which may be a combination of several domains,
- to a specific one. *)
-type 'a structure = 'a Structure.Key_Domain.structure =
- | Void : 'a structure
- | Leaf : 'a key -> 'a structure
- | Node : 'a structure * 'b structure -> ('a * 'b) structure
-
-(**
- For a simple 'leaf' domain, the structure should be:
- [let key = Structure.Key_Domain.create_key "name_of_the_domain";;
- let structure = Leaf key;;]
-
- Then, the key should be exported by the domain, to allow the use of the
- functions defined in the {!Interface} interface below.
-
- A compound domain may use the {!Node} constructor to provide a separate
- access to each of its parts.
-
- A domain can also use the {!Void} constructor to prevent access to itself.
-*)
-
-(** Structure of a domain. *)
-module type S_with_Structure = sig
- include S
-
- (** A structure matching the type of the domain. *)
- val structure : t structure
(** Category for the messages about the domain.
Must be created through {!Value_parameters.register_category}. *)
val log_category : Value_parameters.category
end
-(** External interface of a domain, with accessors.
- Automatically built by the functor {!Structure.Open}.
- When a generic domain is a combination of several domains, these functions
- allow interacting with its subparts. Note that their behavior is undefined
- if the overall domain contains several times the same domain. *)
-module type Interface = sig
- type t
-
- (** Tests whether a key belongs to the domain. *)
- val mem : 'a key -> bool
-
- (** For a key of type [k key]:
- - if the states of this domain (of type [t]) contain a part (of type [k])
- from the domain identified by the key,
- then [get key] returns an accessor for this part of a state.
- - otherwise, [get key] returns None. *)
- val get : 'a key -> (t -> 'a) option
-
- (** For a key of type [k key]:
- - if the states of this domain (of type [t]) contain a part (of type [k])
- from the domain identified by the key,
- then [set key d state] returns the state [state] in which this part
- has been replaced by [d].
- - otherwise, [set key _] is the identity function. *)
- val set : 'a key -> 'a -> t -> t
-end
(** Automatic storage of the states computed during the analysis. *)
module type Store = sig
@@ -470,12 +411,14 @@ module type Store = sig
val register_state_before_stmt: Value_types.callstack -> stmt -> state -> unit
val register_state_after_stmt: Value_types.callstack -> stmt -> state -> unit
+ (** Allows accessing the states inferred by an Eva analysis after it has
+ been computed with the domain enabled. *)
val get_global_state: unit -> state 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
- val get_stmt_state: stmt -> state or_bottom
+ val get_stmt_state: after:bool -> stmt -> state or_bottom
val get_stmt_state_by_callstack:
after:bool -> stmt -> state Value_types.Callstack.Hashtbl.t or_top_or_bottom
end
@@ -483,7 +426,7 @@ end
(** Full implementation of domains. Automatically built by
{!Domain_builder.Complete} from an {!S_with_Structure} domain. *)
module type Internal = sig
- include S_with_Structure
+ include S
module Store: Store with type state := state
(** This function is called after the analysis. The argument is the state
@@ -493,11 +436,14 @@ module type Internal = sig
val post_analysis: t or_bottom -> unit
end
-(** Final interface of domains, as generated and used by Eva, with generic
- accessors for domains. *)
-module type External = sig
+type 't key = 't Structure.Key_Domain.key
+
+(** Signature for a leaf module of a domain. *)
+module type Leaf = sig
include Internal
- include Interface with type t := state
+
+ (** The key identifies the domain and the type [t] of its states. *)
+ val key: t key
end
diff --git a/src/plugins/value/domains/apron/apron_domain.ok.ml b/src/plugins/value/domains/apron/apron_domain.ml
similarity index 95%
rename from src/plugins/value/domains/apron/apron_domain.ok.ml
rename to src/plugins/value/domains/apron/apron_domain.ml
index e69f47ab8625886339479d8da73957603665d6aa..15035124c408a28ef47136b8b728305bdab97c97 100644
--- a/src/plugins/value/domains/apron/apron_domain.ok.ml
+++ b/src/plugins/value/domains/apron/apron_domain.ml
@@ -20,22 +20,14 @@
(* *)
(**************************************************************************)
-#24 "src/plugins/value/domains/apron/apron_domain.ok.ml"
-
open Cil_types
open Eval
open Apron
let dkey = Value_parameters.register_category "d-apron"
-let ok = true
-
let debug = false
-module type S = Abstract_domain.Internal
- with type value = Main_values.Interval.t
- and type location = Precise_locs.precise_location
-
let abort exclog =
let open Manager in
Value_parameters.fatal
@@ -357,22 +349,19 @@ let ival_to_interval = function
(* Abstract Domain Functor *)
(* -------------------------------------------------------------------------- *)
-module Make
- (Man: sig
- type t
- val manager: t Manager.t
- val name: string
- val key: t Abstract1.t Abstract_domain.key
- end)
-= struct
+module type Input = sig
+ type t
+ val manager: t Manager.t
+ val name: string
+end
+
+module Make (Man : Input) = struct
type state = Man.t Abstract1.t
type value = Main_values.Interval.t
type location = Precise_locs.precise_location
let man = Man.manager
-
- let structure = Abstract_domain.Leaf Man.key
let log_category = dkey
let empty_env = Environment.make [||] [||]
@@ -725,54 +714,52 @@ module Make
end
-let octagon_key = Structure.Key_Domain.create_key "apron-octagon"
-let box_key = Structure.Key_Domain.create_key "apron-box"
-let polka_loose_key = Structure.Key_Domain.create_key "polka-loose"
-let polka_strict_key = Structure.Key_Domain.create_key "polka-strict"
-let polka_equalities_key = Structure.Key_Domain.create_key "polka-equalities"
-
-
module Apron_Octagon = struct
type t = Oct.t
let manager = Oct.manager_alloc ()
let name = "Apron octagon domain"
- let key = octagon_key
end
module Apron_Box = struct
type t = Box.t
let manager = Box.manager_alloc ()
let name = "Apron box domain"
- let key = box_key
end
module Apron_Polka_Loose = struct
type t = Polka.loose Polka.t
let manager = Polka.manager_alloc_loose ()
let name = "Polka loose polyhedra domain"
- let key = polka_loose_key
end
module Apron_Polka_Strict = struct
type t = Polka.strict Polka.t
let manager = Polka.manager_alloc_strict ()
let name = "Polka strict polyhedra domain"
- let key = polka_strict_key
end
module Apron_Polka_Equalities = struct
type t = Polka.equalities Polka.t
let manager = Polka.manager_alloc_equalities ()
let name = "Polka linear equalities domain"
- let key = polka_equalities_key
end
(** Apron manager allocation changes the rounding mode. *)
let () = Floating_point.set_round_nearest_even ()
-module Octagon = Domain_builder.Complete (Make (Apron_Octagon))
-module Box = Domain_builder.Complete (Make (Apron_Box))
-module Polka_Loose = Domain_builder.Complete (Make (Apron_Polka_Loose))
-module Polka_Strict = Domain_builder.Complete (Make (Apron_Polka_Strict))
-module Polka_Equalities = Domain_builder.Complete (Make (Apron_Polka_Equalities))
+let make name enable (module Man: Input) =
+ let module Domain = Domain_builder.Complete (Make (Man)) in
+ let open Abstractions in
+ register ~enable { name; priority = 1;
+ values = Single (module Main_values.Interval);
+ domain = Domain (module Domain); }
+
+let () =
+ let open Value_parameters in
+ make "apron octagons" ApronOctagon.get (module Apron_Octagon);
+ make "apron box" ApronBox.get (module Apron_Box);
+ make "polka loose" PolkaLoose.get (module Apron_Polka_Loose);
+ make "polka strict" PolkaStrict.get (module Apron_Polka_Strict);
+ make "polka equalities" PolkaEqualities.get (module Apron_Polka_Equalities);
+ register_apron ()
(*
diff --git a/src/plugins/value/domains/apron/apron_domain.mli b/src/plugins/value/domains/apron/apron_domain.mli
index 19c6611afb1159e90e569e04971eec187da1bbab..5d86a35d509779c5d55ddf1de342b5f592f297fa 100644
--- a/src/plugins/value/domains/apron/apron_domain.mli
+++ b/src/plugins/value/domains/apron/apron_domain.mli
@@ -24,43 +24,6 @@
the APRON library: http://apron.cri.ensmp.fr/library
For now, this binding only processes scalar integer variables. *)
-(** Are apron domains available? *)
-val ok : bool
-
-(** Signature of an Apron domain in Eva. *)
-module type S = Abstract_domain.Internal
- with type value = Main_values.Interval.t
- and type location = Precise_locs.precise_location
-
-
-(** Apron domains available for Eva. *)
-
-(** Octagons abstract domain. *)
-module Octagon : S
-
-(** Intervals abstract domain. *)
-module Box : S
-
-(** Loose polyhedra of the NewPolka library.
- Cannot have strict inequality constraints. Algorithmically more efficient. *)
-module Polka_Loose : S
-
-(** Strict polyhedra of the NewPolka library. *)
-module Polka_Strict : S
-
-(** Linear equalities. *)
-module Polka_Equalities : S
-
-
-(** Domain keys for the Apron domains in Eva. *)
-
-val octagon_key : Octagon.t Abstract_domain.key
-val box_key : Box.t Abstract_domain.key
-val polka_loose_key : Polka_Loose.t Abstract_domain.key
-val polka_strict_key : Polka_Strict.t Abstract_domain.key
-val polka_equalities_key : Polka_Equalities.t Abstract_domain.key
-
-
(*
Local Variables:
compile-command: "make -C ../../../.."
diff --git a/src/plugins/value/domains/cvalue/builtins_malloc.ml b/src/plugins/value/domains/cvalue/builtins_malloc.ml
index b696a031f3ceb94b2b0dc803d4a12e2ebe6fbee8..f85c0c466ee462a48d0fb8bbd14878a4890e4a62 100644
--- a/src/plugins/value/domains/cvalue/builtins_malloc.ml
+++ b/src/plugins/value/domains/cvalue/builtins_malloc.ml
@@ -54,9 +54,9 @@ let () = Ast.add_monotonic_state Dynamic_Alloc_Bases.self
(* Remove some parts of the callstack:
- Remove the bottom of the call tree until we get to the call site
- of the call to the first malloc function. The idea is that each of
- these call site correspond to a different use of a malloc function,
- so it is interesting to keep their bases separated. *)
+ of the call to the first malloc function. The idea is that each of
+ 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
assert (stack != []);
diff --git a/src/plugins/value/domains/cvalue/cvalue_domain.ml b/src/plugins/value/domains/cvalue/cvalue_domain.ml
index 995298130d6c76007449e4477f00dbb2b82b3439..019f87cc0ee61fa5f2fb0ab04a5b43ce16e56256 100644
--- a/src/plugins/value/domains/cvalue/cvalue_domain.ml
+++ b/src/plugins/value/domains/cvalue/cvalue_domain.ml
@@ -22,15 +22,8 @@
open Eval
-let key = Structure.Key_Domain.create_key "cvalue_domain"
let dkey_card = Value_parameters.register_category "cardinal"
-let extract get = match get key with
- | None -> fun _ -> Cvalue.Model.top
- | Some get -> function
- | `Bottom -> Cvalue.Model.bottom
- | `Value state -> get state
-
module Model = struct
include Cvalue.Model
@@ -168,10 +161,6 @@ module State = struct
type state = Model.t * Locals_scoping.clobbered_set
- let structure =
- Abstract_domain.Node (Abstract_domain.Leaf key,
- Abstract_domain.Leaf Locals_scoping.key)
-
let log_category = Value_parameters.dkey_cvalue_domain
include Datatype.Make_with_collections (
@@ -193,6 +182,7 @@ module State = struct
end )
let name = "Cvalue domain"
+ let key = Structure.Key_Domain.create_key "cvalue_domain"
type value = Model.value
type location = Model.location
@@ -473,7 +463,9 @@ module State = struct
| None -> `Bottom
else `Top
- let get_stmt_state stmt = return (Db.Value.get_stmt_state stmt)
+ let get_stmt_state ~after stmt =
+ return (Db.Value.get_stmt_state ~after stmt)
+
let get_stmt_state_by_callstack ~after stmt =
if Storage.get ()
then
@@ -550,9 +542,6 @@ end
let () = Db.Value.display := (fun fmt kf -> State.display ~fmt kf)
-let inject cvalue_model = cvalue_model, Locals_scoping.bottom ()
-let project (state, _) = state
-
type prefix = Hptmap.prefix
module Subpart = struct
@@ -560,12 +549,12 @@ module Subpart = struct
let hash = Model.hash_subtree
let equal = Model.equal_subtree
end
-let distinct_subpart a b =
+let distinct_subpart (a, _) (b, _) =
if Model.equal a b then None
else
try Model.comp_prefixes a b; None
with Model.Found_prefix (p, s1, s2) -> Some (p, s1, s2)
-let find_subpart s prefix = Model.find_prefix s prefix
+let find_subpart (s, _) prefix = Model.find_prefix s prefix
(*
Local Variables:
diff --git a/src/plugins/value/domains/cvalue/cvalue_domain.mli b/src/plugins/value/domains/cvalue/cvalue_domain.mli
index 34436ded0ad5db8a2d0b97d157f0d802891256a4..cf750b4e60f4caad41803517a7d468d98c6b948b 100644
--- a/src/plugins/value/domains/cvalue/cvalue_domain.mli
+++ b/src/plugins/value/domains/cvalue/cvalue_domain.mli
@@ -22,28 +22,18 @@
(** Main domain of the Value Analysis. *)
-module State : Abstract_domain.Internal
+module State : Abstract_domain.Leaf
with type value = Main_values.CVal.t
and type location = Main_locations.PLoc.location
-
-
-val key : Cvalue.Model.t Abstract_domain.key
-
-val extract :
- (Cvalue.Model.t Abstract_domain.key -> ('state -> Cvalue.Model.t) option) ->
- 'state Eval.or_bottom -> Cvalue.Model.t
-
-val inject : Cvalue.Model.t -> State.t
-val project : State.t -> Cvalue.Model.t
-
+ and type state = Cvalue.Model.t * Locals_scoping.clobbered_set
(** Specific functions for partitioning optimizations. *)
type prefix
module Subpart : Hashtbl.HashedType
val distinct_subpart :
- Cvalue.Model.t -> Cvalue.Model.t -> (prefix * Subpart.t * Subpart.t) option
-val find_subpart : Cvalue.Model.t -> prefix -> Subpart.t option
+ State.t -> State.t -> (prefix * Subpart.t * Subpart.t) option
+val find_subpart : State.t -> prefix -> Subpart.t option
diff --git a/src/plugins/value/domains/cvalue/locals_scoping.ml b/src/plugins/value/domains/cvalue/locals_scoping.ml
index 2059c345c71b2421ed931990f7471fccdfa83ad5..0399ececdacea419c547292619239e0b51aceea7 100644
--- a/src/plugins/value/domains/cvalue/locals_scoping.ml
+++ b/src/plugins/value/domains/cvalue/locals_scoping.ml
@@ -27,8 +27,6 @@ type clobbered_set = {
mutable clob: Base.SetLattice.t
}
-let key = Structure.Key_Domain.create_key "clobbered_set"
-
let structural_descr =
let open Structural_descr in
t_record [| Base.SetLattice.packed_descr |]
diff --git a/src/plugins/value/domains/cvalue/locals_scoping.mli b/src/plugins/value/domains/cvalue/locals_scoping.mli
index e0b8c5d181d57181580186b48c8a832594d15550..8f0835453855fa211165d61038556ce98f03a81d 100644
--- a/src/plugins/value/domains/cvalue/locals_scoping.mli
+++ b/src/plugins/value/domains/cvalue/locals_scoping.mli
@@ -30,8 +30,6 @@ type clobbered_set = {
mutable clob: Base.SetLattice.t
}
-val key: clobbered_set Abstract_domain.key
-
val structural_descr: Structural_descr.t
val bottom: unit -> clobbered_set
diff --git a/src/plugins/value/domains/domain_builder.ml b/src/plugins/value/domains/domain_builder.ml
index b27b01329e10386ad60dee893ca52c897b1d10a5..7406f3753ddcdd15481c6defa1d9e2a36c403c12 100644
--- a/src/plugins/value/domains/domain_builder.ml
+++ b/src/plugins/value/domains/domain_builder.ml
@@ -22,7 +22,7 @@
module type InputDomain = sig
- include Abstract_domain.S_with_Structure
+ include Abstract_domain.S
val storage: unit -> bool
end
@@ -33,6 +33,9 @@ module Complete
include Domain
module Store = Domain_store.Make (Domain)
+ let key: Domain.t Structure.Key_Domain.key =
+ Structure.Key_Domain.create_key Domain.name
+
let post_analysis _state = ()
end
@@ -57,7 +60,6 @@ module Make_Minimal
include Domain
- let structure = Abstract_domain.Void
let log_category = Value_parameters.register_category ("d-" ^ name)
type value = Value.t
@@ -185,7 +187,6 @@ 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 structure = Abstract_domain.Void
let log_category = Value_parameters.register_category ("d-" ^ name)
type value = Cvalue.V.t
diff --git a/src/plugins/value/domains/domain_builder.mli b/src/plugins/value/domains/domain_builder.mli
index 7d3b426a606878abe05699292d827739fcec4948..1eddbb4b8b52625248ac77e374a6af904047cdf5 100644
--- a/src/plugins/value/domains/domain_builder.mli
+++ b/src/plugins/value/domains/domain_builder.mli
@@ -24,34 +24,34 @@
simplified interfaces. *)
module type InputDomain = sig
- include Abstract_domain.S_with_Structure
+ include Abstract_domain.S
val storage: unit -> bool
end
module Complete
(Domain: InputDomain)
- : Abstract_domain.Internal with type state = Domain.state
- and type value = Domain.value
- and type location = Domain.location
+ : Abstract_domain.Leaf with type state = Domain.state
+ and type value = Domain.value
+ and type location = Domain.location
module Complete_Minimal
(Value: Abstract_value.S)
(Location: Abstract_location.S)
(Domain: Simpler_domains.Minimal)
- : Abstract_domain.Internal with type value = Value.t
- and type location = Location.location
- and type state = Domain.t
+ : Abstract_domain.Leaf with type value = Value.t
+ and type location = Location.location
+ and type state = Domain.t
module Complete_Minimal_with_datatype
(Value: Abstract_value.S)
(Location: Abstract_location.S)
(Domain: Simpler_domains.Minimal_with_datatype)
- : Abstract_domain.Internal with type value = Value.t
- and type location = Location.location
- and type state = Domain.t
+ : Abstract_domain.Leaf with type value = Value.t
+ and type location = Location.location
+ and type state = Domain.t
module Complete_Simple_Cvalue
(Domain: Simpler_domains.Simple_Cvalue)
- : Abstract_domain.Internal with type value = Cvalue.V.t
- and type location = Precise_locs.precise_location
- and type state = Domain.t
+ : Abstract_domain.Leaf with type value = Cvalue.V.t
+ and type location = Precise_locs.precise_location
+ and type state = Domain.t
diff --git a/src/plugins/value/domains/domain_lift.ml b/src/plugins/value/domains/domain_lift.ml
index 02eaa96e98d63b5f8cccfe3bfa8463d6565ef361..0256e97c80d334675f3171ec8e0e2dfb1eb4ae86 100644
--- a/src/plugins/value/domains/domain_lift.ml
+++ b/src/plugins/value/domains/domain_lift.ml
@@ -37,7 +37,7 @@ end
module Make
- (Domain: Abstract_domain.Internal)
+ (Domain: Abstract_domain.Leaf)
(Convert : Conversion with type internal_value := Domain.value
and type internal_location := Domain.location)
= struct
@@ -45,7 +45,8 @@ module Make
include (Domain : Datatype.S_with_collections with type t = Domain.t)
include (Domain : Abstract_domain.Lattice with type state = Domain.state)
- let structure = Domain.structure
+ let structure = Abstract.Domain.Leaf (Domain.key, (module Domain))
+
let log_category = Domain.log_category
type value = Convert.extended_value
diff --git a/src/plugins/value/domains/domain_lift.mli b/src/plugins/value/domains/domain_lift.mli
index 9e16a8a292ee65d5fd7ff670ac2e9228b9180ba1..9ed356565906f71c2c7aace94cb44fc0e9f5ad9b 100644
--- a/src/plugins/value/domains/domain_lift.mli
+++ b/src/plugins/value/domains/domain_lift.mli
@@ -36,10 +36,10 @@ end
module Make
- (Domain: Abstract_domain.Internal)
+ (Domain: Abstract_domain.Leaf)
(Convert : Conversion with type internal_value := Domain.value
and type internal_location := Domain.location)
- : Abstract_domain.Internal with type state = Domain.state
+ : Abstract.Domain.Internal with type state = Domain.state
and type value = Convert.extended_value
and type location = Convert.extended_location
and type origin = Domain.origin
diff --git a/src/plugins/value/domains/domain_product.ml b/src/plugins/value/domains/domain_product.ml
index fffc784d6c8ec628b931a200e587caf909a8c86c..1985b6c173ad631b55d0401c0bf67494861cf831 100644
--- a/src/plugins/value/domains/domain_product.ml
+++ b/src/plugins/value/domains/domain_product.ml
@@ -28,8 +28,8 @@ let product_category = Value_parameters.register_category "domain_product"
module Make
(Value: Abstract_value.S)
- (Left: Abstract_domain.Internal with type value = Value.t)
- (Right: Abstract_domain.Internal with type value = Left.value
+ (Left: Abstract.Domain.Internal with type value = Value.t)
+ (Right: Abstract.Domain.Internal with type value = Left.value
and type location = Left.location)
= struct
@@ -51,7 +51,7 @@ module Make
(struct let module_name = name end)
type state = t
- let structure = Abstract_domain.Node (Left.structure, Right.structure)
+ let structure = Abstract.Domain.Node (Left.structure, Right.structure)
let log_category = product_category
@@ -366,9 +366,9 @@ module Make
and right_tbl = Right.Store.get_initial_state_by_callstack kf in
merge_callstack_tbl left_tbl right_tbl
- let get_stmt_state stmt =
- Left.Store.get_stmt_state stmt >>- fun left ->
- Right.Store.get_stmt_state stmt >>-: fun right ->
+ let get_stmt_state ~after stmt =
+ Left.Store.get_stmt_state ~after stmt >>- fun left ->
+ Right.Store.get_stmt_state ~after stmt >>-: fun right ->
left, right
let get_stmt_state_by_callstack ~after stmt =
let left_tbl = Left.Store.get_stmt_state_by_callstack ~after stmt
diff --git a/src/plugins/value/domains/domain_product.mli b/src/plugins/value/domains/domain_product.mli
index c883a94ba8d1cb26816c742f8c8bf9a5bbe8532c..859988e255221878be47fd1ef9fc7836ca81e6a6 100644
--- a/src/plugins/value/domains/domain_product.mli
+++ b/src/plugins/value/domains/domain_product.mli
@@ -24,10 +24,10 @@ val product_category: Value_parameters.category
module Make
(Value: Abstract_value.S)
- (Left: Abstract_domain.Internal with type value = Value.t)
- (Right: Abstract_domain.Internal with type value = Left.value
+ (Left: Abstract.Domain.Internal with type value = Value.t)
+ (Right: Abstract.Domain.Internal with type value = Left.value
and type location = Left.location)
- : Abstract_domain.Internal with type value = Value.t
+ : Abstract.Domain.Internal with type value = Value.t
and type location = Left.location
and type state = Left.state * Right.state
diff --git a/src/plugins/value/domains/domain_store.ml b/src/plugins/value/domains/domain_store.ml
index 6bcf2d60866172e9f4e3e0889fa671f5c0d0dec4..592b14ca41dcd5dab4a337323e090a112c851dd9 100644
--- a/src/plugins/value/domains/domain_store.ml
+++ b/src/plugins/value/domains/domain_store.ml
@@ -104,6 +104,13 @@ module Make (Domain: InputDomain) = struct
let size = size
let dependencies = dependencies
end)
+ module AfterTable =
+ Cil_state_builder.Stmt_hashtbl (Domain)
+ (struct
+ let name = name ^ ".AfterTable"
+ let size = size
+ let dependencies = [ AfterTable_By_Callstack.self ]
+ end)
module Called_Functions_By_Callstack =
State_builder.Hashtbl
@@ -201,13 +208,18 @@ module Make (Domain: InputDomain) = struct
try `Value (Called_Functions_By_Callstack.find kf)
with Not_found -> `Bottom
- let get_stmt_state s =
+ let get_stmt_state ~after s =
if not (Storage.get ())
then `Value Domain.top
else
- try `Value (Table.find s)
+ let (find, add), find_by_callstack =
+ if after
+ then AfterTable.(find, add), AfterTable_By_Callstack.find
+ else Table.(find, add), Table_By_Callstack.find
+ in
+ try `Value (find s)
with Not_found ->
- let ho = try Some (Table_By_Callstack.find s) with Not_found -> None in
+ let ho = try Some (find_by_callstack s) with Not_found -> None in
let state =
match ho with
| None -> `Bottom
@@ -216,7 +228,7 @@ module Make (Domain: InputDomain) = struct
(fun _cs state acc -> Bottom.join Domain.join acc (`Value state))
h `Bottom
in
- ignore (state >>-: Table.add s);
+ ignore (state >>-: add s);
state
let get_stmt_state_by_callstack ~after stmt =
diff --git a/src/plugins/value/domains/equality/equality.ml b/src/plugins/value/domains/equality/equality.ml
index 278404749c6349fd2f5ac17cbc0a3cf21da46c44..3aebc0c885bd3c2cbaa08d8aed9ccc8549a6ac0b 100644
--- a/src/plugins/value/domains/equality/equality.ml
+++ b/src/plugins/value/domains/equality/equality.ml
@@ -70,8 +70,8 @@ module Set = struct
from each lvalue or expression to:
- the equality in which it is involved;
- for a lvalue [lv], the set of expressions that contain [lv] in the map.
- This last information is needed when removing a lvalue, to remove or
- replace all expressions containing this lvalue. *)
+ This last information is needed when removing a lvalue, to remove or
+ replace all expressions containing this lvalue. *)
module Data = struct
(* For a lvalue [lv], the first set gathers the expressions that depends on
diff --git a/src/plugins/value/domains/equality/equality_domain.ml b/src/plugins/value/domains/equality/equality_domain.ml
index 7ccb02c97211ab9dfbf100b5cf16abd9c45358d0..7186aaebe57942d239821101d28e1f9770848930 100644
--- a/src/plugins/value/domains/equality/equality_domain.ml
+++ b/src/plugins/value/domains/equality/equality_domain.ml
@@ -122,9 +122,8 @@ module Internal = struct
type state = t
let name = "Equality domain"
- let key = Structure.Key_Domain.create_key "equality_domain"
- let structure : t Abstract_domain.structure = Abstract_domain.Leaf key
let log_category = dkey
+ let key = Structure.Key_Domain.create_key "equality_domain"
type equalities = Equality.Set.t
let project (t, _, _) = t
@@ -180,13 +179,13 @@ module Store = Domain_store.Make (Internal)
(* ------------------------- Abstract Domain -------------------------------- *)
module Make
- (Value : Abstract_value.External)
+ (Value : Abstract.Value.External)
= struct
include Internal
module Store = Store
- let get_cvalue = Value.get Main_values.cvalue_key
+ let get_cvalue = Value.get Main_values.CVal.key
type value = Value.t
type location = Precise_locs.precise_location
@@ -218,7 +217,7 @@ module Make
let c = get v in
if Cvalue.V.is_imprecise c then
let c' = Cvalue.V.topify_with_origin Origin.top c in
- Value.set Main_values.cvalue_key c' v
+ Value.set Main_values.CVal.key c' v
else v
let coop_eval oracle equalities atom_src =
diff --git a/src/plugins/value/domains/equality/equality_domain.mli b/src/plugins/value/domains/equality/equality_domain.mli
index 6f6d041654125ff27303bcd95cd853297b8ba836..1242e9d2e9cc9af841e56d5ffcad96c5c0595747 100644
--- a/src/plugins/value/domains/equality/equality_domain.mli
+++ b/src/plugins/value/domains/equality/equality_domain.mli
@@ -31,10 +31,9 @@ type call_init_state =
| ISEmpty (** completely empty state, without impact on Memexec. *)
-module Make (Value : Abstract_value.External) : sig
- include Abstract_domain.Internal with type value = Value.t
- and type location = Precise_locs.precise_location
- val key : t Abstract_domain.key
+module Make (Value : Abstract.Value.External) : sig
+ include Abstract_domain.Leaf with type value = Value.t
+ and type location = Precise_locs.precise_location
val pretty_debug : Format.formatter -> t -> unit
diff --git a/src/plugins/value/domains/gauges/gauges_domain.ml b/src/plugins/value/domains/gauges/gauges_domain.ml
index 1af3127519259cc44ffd7db880c28f39dc8983da..e45fc726212b250492260e4c551bc5c1bed3dea4 100644
--- a/src/plugins/value/domains/gauges/gauges_domain.ml
+++ b/src/plugins/value/domains/gauges/gauges_domain.ml
@@ -1120,7 +1120,7 @@ end
let dkey = Value_parameters.register_category "d-gauges"
-module D_Impl : Abstract_domain.S_with_Structure
+module D_Impl : Abstract_domain.S
with type state = G.t
and type value = Cvalue.V.t
and type location = Precise_locs.precise_location
@@ -1132,8 +1132,6 @@ module D_Impl : Abstract_domain.S_with_Structure
include G
let name = "Gauges domain"
-
- let structure = Abstract_domain.Void
let log_category = dkey
let empty _ = G.empty
diff --git a/src/plugins/value/domains/gauges/gauges_domain.mli b/src/plugins/value/domains/gauges/gauges_domain.mli
index a1609d838a046745346cd36f02e063314057b88a..f51fdfbc660171bd5485c37869384790319e43e1 100644
--- a/src/plugins/value/domains/gauges/gauges_domain.mli
+++ b/src/plugins/value/domains/gauges/gauges_domain.mli
@@ -23,6 +23,6 @@
(** Gauges domain ("Arnaud Venet: The Gauge Domain: Scalable Analysis of
Linear Inequality Invariants. CAV 2012") *)
-module D: Abstract_domain.Internal
+module D: Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
diff --git a/src/plugins/value/domains/inout_domain.ml b/src/plugins/value/domains/inout_domain.ml
index 12ba3cd152852bbd7ea98e40b0921ae2110bc5a6..1a5a4888c93f0f23d46045a7048f47755e2075b2 100644
--- a/src/plugins/value/domains/inout_domain.ml
+++ b/src/plugins/value/domains/inout_domain.ml
@@ -204,8 +204,6 @@ module Transfer = struct
end
-let key = Structure.Key_Domain.create_key "inout domain"
-
module Internal
(*: Domain_builder.InputDomain
with type state = inout
@@ -221,7 +219,7 @@ module Internal
include Abstract_domain.Lattice with type state := state
end)
- let structure : t Abstract_domain.structure = Abstract_domain.Leaf key
+ let name = "inout"
let log_category = Value_parameters.register_category "d-inout"
let enter_scope _kf _vars state = state
diff --git a/src/plugins/value/domains/inout_domain.mli b/src/plugins/value/domains/inout_domain.mli
index 0304f94f6900c3178afd03ca5c1d3534896a70a6..f759f59bfe6bff258657a4623bfdec01048222e4 100644
--- a/src/plugins/value/domains/inout_domain.mli
+++ b/src/plugins/value/domains/inout_domain.mli
@@ -22,8 +22,6 @@
(** Computation of inputs of outputs. *)
-module D: Abstract_domain.Internal
+module D: Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
-
-val key: D.t Abstract_domain.key
diff --git a/src/plugins/value/domains/numerors/numerors_domain.ok.ml b/src/plugins/value/domains/numerors/numerors_domain.ml
similarity index 57%
rename from src/plugins/value/domains/numerors/numerors_domain.ok.ml
rename to src/plugins/value/domains/numerors/numerors_domain.ml
index cf8e73a78c435b8f993f61ab80c07057b10d60d4..6295adc0eed64e7d4495b8c1dc62ed8aba6ec0cf 100644
--- a/src/plugins/value/domains/numerors/numerors_domain.ok.ml
+++ b/src/plugins/value/domains/numerors/numerors_domain.ml
@@ -20,17 +20,10 @@
(* *)
(**************************************************************************)
-#24 "src/plugins/value/domains/numerors/numerors_domain.ok.ml"
-
open Eval
open Cil_types
-type value = Numerors_value.t
-type location = Precise_locs.precise_location
-let value_key = Numerors_value.error_key
-
-let ok = true
-
+(* The numerors values, plus some builtin functions. *)
module Numerors_Value = struct
include Numerors_value
@@ -87,61 +80,7 @@ module Numerors_Value = struct
]
end
-let add_numerors_value (module Value: Abstract_value.Internal) =
- let module External_Value = Structure.Open (Structure.Key_Value) (Value) in
- let module V = struct
- include Value_product.Make (Value) (Numerors_value)
-
- let forward_cast = match External_Value.get Main_values.cvalue_key with
- | None -> forward_cast
- | Some get_cvalue ->
- fun ~src_type ~dst_type (value, num) ->
- forward_cast ~src_type ~dst_type (value, num) >>-: fun (value', num) ->
- let num = match src_type, dst_type with
- | Eval_typ.TSInt _, Eval_typ.TSFloat fkind ->
- begin
- try
- let cvalue = get_cvalue value in
- let ival = Cvalue.V.project_ival cvalue in
- match Ival.min_and_max ival with
- | Some min, Some max ->
- let min, max = Integer.to_int min, Integer.to_int max in
- let prec = Numerors_utils.Precisions.of_fkind fkind in
- Numerors_value.of_ints ~prec min max
- | _, _ -> num
- (* Integer.to_int may fail for too big integers. *)
- with Cvalue.V.Not_based_on_null | Z.Overflow -> num
- end
- | _, _ -> num
- in
- value', num
- end in
- (module V: Abstract_value.Internal)
-
-let reduce_error (type v) (module V: Abstract_value.External with type t = v) =
- match V.get Numerors_value.error_key, V.get Main_values.cvalue_key with
- | Some get_error, Some get_cvalue ->
- begin
- let set_error = V.set Numerors_value.error_key in
- fun t ->
- let cvalue = get_cvalue t in
- try
- let ival = Cvalue.V.project_ival cvalue in
- match ival with
- | Ival.Float fval ->
- begin
- let error = get_error t in
- let error = Numerors_value.reduce fval error in
- match error with
- | `Value error -> set_error error t
- | `Bottom -> t (* TODO: we should be able to reduce to bottom. *)
- end
- | _ -> t
- with Cvalue.V.Not_based_on_null -> t
- end
- | _, _ -> fun x -> x
-
-
+(* The numerors domain: a simple memory over the numerors value. *)
module Domain = struct
module Name = struct let name = "numerors" end
include Simple_memory.Make_Domain (Name) (Numerors_Value)
@@ -157,7 +96,72 @@ module Domain = struct
| _, _ -> ()
end
-let numerors_domain () =
- Value_parameters.warning "The numerors domain is experimental.";
- (module Domain: Abstract_domain.Internal with type value = value
- and type location = location)
+(* Reduced product between the cvalue values and the numerors values. *)
+let reduce_error cvalue error =
+ try
+ let ival = Cvalue.V.project_ival cvalue in
+ match ival with
+ | Ival.Float fval ->
+ begin
+ match Numerors_value.reduce fval error with
+ | `Value error -> cvalue, error
+ | `Bottom -> cvalue, error (* TODO: we should be able to reduce to bottom. *)
+ end
+ | _ -> cvalue, error
+ with Cvalue.V.Not_based_on_null -> cvalue, error
+
+(* Reduction of the numerors value resulting from a cast from int to float type,
+ using the cvalue component of value abstractions. *)
+let reduce_cast (module Abstract: Abstractions.S) =
+ let module Val = struct
+ include Abstract.Val
+
+ (* Redefines the [forward_cast] function of the value component. *)
+ let forward_cast =
+ (* If cvalue or numerors do not belong to the abstraction, no reduction:
+ the [forward_cast] function is unchanged. *)
+ match get Main_values.CVal.key, mem Numerors_value.key with
+ | None, _ | _, false -> forward_cast
+ | Some get_cvalue, true ->
+ (* Otherwise, applies the [forward_cast] function, but updates the
+ numerors component of the result. *)
+ fun ~src_type ~dst_type value ->
+ forward_cast ~src_type ~dst_type value >>-: fun result ->
+ match src_type, dst_type with
+ | Eval_typ.TSInt _, Eval_typ.TSFloat fkind ->
+ begin
+ try
+ let cvalue = get_cvalue value in
+ let ival = Cvalue.V.project_ival cvalue in
+ match Ival.min_and_max ival with
+ | Some min, Some max ->
+ let min, max = Integer.to_int min, Integer.to_int max in
+ let prec = Numerors_utils.Precisions.of_fkind fkind in
+ let num = Numerors_value.of_ints ~prec min max in
+ set Numerors_value.key num result
+ | _, _ -> result
+ (* Integer.to_int may fail for too big integers. *)
+ with Cvalue.V.Not_based_on_null | Z.Overflow -> result
+ end
+ | _, _ -> result
+ end in
+ (module struct
+ module Val = Val
+ module Loc = Abstract.Loc
+ module Dom = Abstract.Dom
+ end: Abstractions.S)
+
+(* Register the domain as an Eva abstractions. *)
+let () =
+ let open Abstractions in
+ let domain =
+ { name = "numerors";
+ priority = 0;
+ values = Single (module Numerors_value);
+ domain = Domain (module Domain); }
+ in
+ let reduced_product = Main_values.CVal.key, Numerors_value.key, reduce_error in
+ register ~enable:Value_parameters.NumerorsDomain.get domain;
+ register_value_reduction reduced_product;
+ register_hook reduce_cast;
+ Value_parameters.register_numerors ()
diff --git a/src/plugins/value/domains/numerors/numerors_domain.mli b/src/plugins/value/domains/numerors/numerors_domain.mli
index d08ef39909623588ccb4c7582daf7c7a05bdce2a..6fcd35b31eed7cff62e5bdbbda30383c54f47cfc 100644
--- a/src/plugins/value/domains/numerors/numerors_domain.mli
+++ b/src/plugins/value/domains/numerors/numerors_domain.mli
@@ -20,30 +20,7 @@
(* *)
(**************************************************************************)
-type value
-type location = Precise_locs.precise_location
-val value_key : value Structure.Key_Value.k
-
-(** True if the numerors domain is available;
- False if the MPFR library has not been found. *)
-val ok: bool
-
-(** Functions used by the engine to build numerors abstractions. *)
-
-(** Builds the product between a given value module and the numerors value
- module. If the given value module contains Cvalue, uses cvalues to reduce
- numerors values on casts from integer to floating-point values.
- Fails if numerors domain is not available. *)
-val add_numerors_value:
- (module Abstract_value.Internal) -> (module Abstract_value.Internal)
-
-(* From a given abstract value product, creates the reduction function that
- reduces numerors values by using cvalues. Returns the identity if the given
- value product does not contain numerors and cvalue componants. *)
-val reduce_error:
- (module Abstract_value.External with type t = 'v) -> ('v -> 'v)
-
-(** Returns the numerors domain module, if available. Fails otherwise. *)
-val numerors_domain:
- unit -> (module Abstract_domain.Internal with type value = value
- and type location = location)
+(** Numerors domain: computes over-approximations of the rounding errors bounds
+ of floating-point computations.
+ Nothing is exported: the domain is registered as an analysis abstraction
+ in the Eva engine, enabled by the -eva-numerors-domain option. *)
diff --git a/src/plugins/value/domains/offsm_domain.ml b/src/plugins/value/domains/offsm_domain.ml
index 8ab4ee60ca741522d565be563559c1224d23022d..f491384582b905f2aba39ffa65dc80f073344669 100644
--- a/src/plugins/value/domains/offsm_domain.ml
+++ b/src/plugins/value/domains/offsm_domain.ml
@@ -103,7 +103,6 @@ module Internal : Domain_builder.InputDomain
end)
let name = "Bitwise domain"
- let structure = Abstract_domain.Void
let log_category = dkey
let empty _ = Memory.empty_map
diff --git a/src/plugins/value/domains/offsm_domain.mli b/src/plugins/value/domains/offsm_domain.mli
index 4567fc14d3f21c1ad2db640e9264fe6ec387e4cb..8833d4b88cb93b0134e3239aa139a3c6a34585a5 100644
--- a/src/plugins/value/domains/offsm_domain.mli
+++ b/src/plugins/value/domains/offsm_domain.mli
@@ -20,6 +20,6 @@
(* *)
(**************************************************************************)
-module D : Abstract_domain.Internal
+module D : Abstract_domain.Leaf
with type value = Offsm_value.offsm_or_top
and type location = Precise_locs.precise_location
diff --git a/src/plugins/value/domains/printer_domain.mli b/src/plugins/value/domains/printer_domain.mli
index 5355cebbd9cbf82b76690098e670e0af76855c9c..febfc6902d6a8cdf0d0bee4a199bbdadd5cc094d 100644
--- a/src/plugins/value/domains/printer_domain.mli
+++ b/src/plugins/value/domains/printer_domain.mli
@@ -23,5 +23,5 @@
(** An abstract domain built on top of the Simpler_domains.Simple_Cvalue
interface that just prints the transfer functions called by the engine
during an analysis. *)
-include Abstract_domain.Internal with type value = Cvalue.V.t
- and type location = Precise_locs.precise_location
+include Abstract_domain.Leaf with type value = Cvalue.V.t
+ and type location = Precise_locs.precise_location
diff --git a/src/plugins/value/domains/sign_domain.mli b/src/plugins/value/domains/sign_domain.mli
index fafc9f18c67cf1cd72ee5d88375dfce1631f8fe6..b32803feb652aad71ea799b02aff6a7c733f6b40 100644
--- a/src/plugins/value/domains/sign_domain.mli
+++ b/src/plugins/value/domains/sign_domain.mli
@@ -22,5 +22,5 @@
(** Abstraction of the sign of integer variables. *)
-include Abstract_domain.Internal with type value = Sign_value.t
- and type location = Precise_locs.precise_location
+include Abstract_domain.Leaf with type value = Sign_value.t
+ and type location = Precise_locs.precise_location
diff --git a/src/plugins/value/domains/simple_memory.ml b/src/plugins/value/domains/simple_memory.ml
index f312b589f11a835903ac4080566ce7f14b81df3a..ea1757685829577ec77aa94c1c1de8ff79dc8ce2 100644
--- a/src/plugins/value/domains/simple_memory.ml
+++ b/src/plugins/value/domains/simple_memory.ml
@@ -188,9 +188,6 @@ module Make_Internal (Info: sig val name: string end) (Value: Value) = struct
type value = Value.t
type location = Precise_locs.precise_location
- let key = Structure.Key_Domain.create_key (Info.name ^ " domain")
- let structure : t Abstract_domain.structure = Abstract_domain.Leaf key
-
let log_category = Value_parameters.register_category ("d-" ^ Info.name)
let widen _kf _stmt = widen
diff --git a/src/plugins/value/domains/simple_memory.mli b/src/plugins/value/domains/simple_memory.mli
index e45eef5cb3a61dcb648a8934330ceabd2d36552f..0ea8a003a607d3271ff50d8c4909948c933b520b 100644
--- a/src/plugins/value/domains/simple_memory.mli
+++ b/src/plugins/value/domains/simple_memory.mli
@@ -106,8 +106,8 @@ module Make_Domain
(Value: Value)
: sig
- include Abstract_domain.Internal with type value = Value.t
- and type location = Precise_locs.precise_location
+ include Abstract_domain.Leaf with type value = Value.t
+ and type location = Precise_locs.precise_location
include S with type t := t
and type value := Value.t
diff --git a/src/plugins/value/domains/symbolic_locs.ml b/src/plugins/value/domains/symbolic_locs.ml
index 42db4cd7cb58a9c6b6cd3cd75b24f28ab2bd0149..00220370476099169b87412b86f2b397e6574c2f 100644
--- a/src/plugins/value/domains/symbolic_locs.ml
+++ b/src/plugins/value/domains/symbolic_locs.ml
@@ -472,7 +472,6 @@ module Internal : Domain_builder.InputDomain
end)
let name = "Symbolic locations domain"
- let structure = Abstract_domain.Void
let log_category = dkey
let empty _ = Memory.empty_map
diff --git a/src/plugins/value/domains/symbolic_locs.mli b/src/plugins/value/domains/symbolic_locs.mli
index 06cda3ce5eb47f2d1ac33fdfe85205c3dbb1afbb..7cebf7b9f4cb6083bf3625b520be6bf5c1e30ae1 100644
--- a/src/plugins/value/domains/symbolic_locs.mli
+++ b/src/plugins/value/domains/symbolic_locs.mli
@@ -23,6 +23,6 @@
(** Domain that store information on non-precise l-values such as
[t[i]] or [*p] when [i] or [p] is not exact. *)
-module D: Abstract_domain.Internal
+module D: Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
diff --git a/src/plugins/value/domains/traces_domain.ml b/src/plugins/value/domains/traces_domain.ml
new file mode 100644
index 0000000000000000000000000000000000000000..e12ed3ebeb31e4ca7e08daba038558caa5385053
--- /dev/null
+++ b/src/plugins/value/domains/traces_domain.ml
@@ -0,0 +1,1300 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(** traces domain *)
+
+(** This domain build an over-approximation of all the traces that leads to a statement.
+ These sets of traces is represented using CFGs.
+*)
+
+module OCamlGraph = Graph
+module Frama_c_File = File
+open Cil_types
+open Cil_datatype
+
+[@@@ warning "-40-42"]
+
+module Node : sig
+ include Datatype.S_with_collections
+ val id: t -> int
+ val start: t
+ val dumb: t
+ val next: unit -> t
+end = struct
+ include Datatype.Int
+ let id x = x
+ let start = 0
+ let dumb = (- 1)
+ module Counter =
+ State_builder.Counter
+ (struct let name = "Value.Traces_domain.Node.Counter" end)
+ let next () = Counter.next ()
+end
+
+(** Can't use Graph.t it needs an impossible recursive module *)
+module GraphShape = Hptmap.Shape(Node)
+
+type node = Node.t
+
+type transition =
+ | Assign of kinstr * lval * typ * exp
+ | Assume of stmt * exp * bool
+ | EnterScope of kernel_function * varinfo list
+ | LeaveScope of kernel_function * varinfo list
+ (** For call of functions without definition *)
+ | CallDeclared of kernel_function * exp list * lval option
+ | Loop of stmt * node (** start *) * edge list GraphShape.t
+ | Msg of string
+
+and edge = {
+ edge_trans : transition;
+ edge_dst : node;
+}
+
+module rec Edge : sig
+ include Datatype.S_with_collections with type t = edge
+ val succ : t -> node
+ val change_next : node -> t -> t
+
+ val has_transition : transition -> edge -> bool
+
+ val pretty_list : t list Pretty_utils.formatter
+end = struct
+ module T = struct
+ type t = edge
+ let name = "Value.Traces_domain.Edge"
+
+ include Datatype.Serializable_undefined
+
+ let reprs = [ {
+ edge_trans = Msg "msg";
+ edge_dst = Node.start;
+ }]
+
+ let structural_descr = Structural_descr.t_abstract
+
+ let compare (e1: t) (e2 : t) =
+ let c = Node.compare e1.edge_dst e2.edge_dst in
+ if c <> 0 then c else
+ Transition.compare e1.edge_trans e2.edge_trans
+
+ let equal = Datatype.from_compare
+
+ let pretty fmt e =
+ Format.fprintf fmt "@[<hv 2>%a @[-> %a@]@]"
+ Transition.pretty e.edge_trans Node.pretty e.edge_dst
+
+ let hash e =
+ Hashtbl.seeded_hash (Node.hash e.edge_dst) (Transition.hash e.edge_trans)
+ end
+
+ include Datatype.Make_with_collections(T)
+
+ let has_transition t e = Transition.equal t e.edge_trans
+
+ let pretty_list fmt l = Pretty_utils.pp_list ~sep:";@ " pretty fmt l
+
+ let succ e = e.edge_dst
+ let change_next n e = { e with edge_dst = n }
+end
+and Transition : sig
+ type t = transition
+
+ val compare : t -> t -> int
+ val equal : t -> t -> bool
+ val hash : t -> int
+
+ val pretty : t Pretty_utils.formatter
+end = struct
+ type t = transition
+
+ let compare (t1: t) (t2: t) = match t1, t2 with
+ | Assign (_, loc1, typ1, exp1), Assign (_, loc2, typ2, exp2) ->
+ let c = Lval.compare loc1 loc2 in
+ if c <> 0 then c else
+ let c = Typ.compare typ1 typ2 in
+ if c <> 0 then c else
+ ExpStructEq.compare exp1 exp2
+ | Assume (_, e1, b1), Assume (_, e2, b2) ->
+ let c = ExpStructEq.compare e1 e2 in
+ if c <> 0 then c else
+ Transitioning.Stdlib.compare b1 b2
+ | EnterScope (_, vs1), EnterScope (_, vs2) ->
+ Extlib.list_compare Varinfo.compare vs1 vs2
+ | LeaveScope (_, vs1), LeaveScope (_, vs2) ->
+ Extlib.list_compare Varinfo.compare vs1 vs2
+ | CallDeclared (kf1, es1, lv1), CallDeclared (kf2, es2, lv2) ->
+ let c = Kernel_function.compare kf1 kf2 in
+ if c <> 0 then c else
+ let c = Extlib.list_compare ExpStructEq.compare es1 es2 in
+ if c <> 0 then c else
+ Extlib.opt_compare Lval.compare lv1 lv2
+ | Msg s1, Msg s2 ->
+ String.compare s1 s2
+ | Loop (stmt1, s1, g1), Loop (stmt2, s2, g2) ->
+ let c = Stmt.compare stmt1 stmt2 in
+ if c <> 0 then c else
+ let c = Node.compare s1 s2 in
+ if c <> 0 then c else
+ GraphShape.compare (Extlib.list_compare Edge.compare) g1 g2
+ | Assign _, _ -> -1
+ | _ , Assign _ -> 1
+ | Assume _, _ -> -1
+ | _ , Assume _ -> 1
+ | EnterScope _, _ -> -1
+ | _ , EnterScope _ -> 1
+ | LeaveScope _, _ -> -1
+ | _ , LeaveScope _ -> 1
+ | CallDeclared _, _ -> -1
+ | _ , CallDeclared _ -> 1
+ | Msg _, _ -> -1
+ | _, Msg _ -> 1
+
+ let equal t1 t2 = (compare t1 t2 = 0)
+
+ let pretty fmt = function
+ | Assign (_, loc, _typ, exp) ->
+ Format.fprintf fmt "Assign:@ %a = %a"
+ Lval.pretty loc ExpStructEq.pretty exp
+ | Assume (_, e, b) ->
+ Format.fprintf fmt "Assume:@ %a %b" ExpStructEq.pretty e b
+ | EnterScope (_, vs) ->
+ Format.fprintf fmt "EnterScope:@ %a"
+ (Pretty_utils.pp_list ~sep:"@ " Varinfo.pretty) vs
+ | LeaveScope (_, vs) ->
+ Format.fprintf fmt "LeaveScope:@ %a"
+ (Pretty_utils.pp_list ~sep:"@ " Varinfo.pretty) vs
+ | CallDeclared(kf1, exp1, lval1) ->
+ Format.fprintf fmt "CallDeclared:@ %a%s(%a)"
+ (Pretty_utils.pp_opt ~pre:"" ~suf:" =@ " Lval.pretty) lval1
+ (Kernel_function.get_name kf1)
+ (Pretty_utils.pp_list ~sep:",@ " ExpStructEq.pretty) exp1
+ | Msg s -> Format.fprintf fmt "%s" s
+ | Loop(stmt, s, g) ->
+ Format.fprintf fmt "@[Loop(%a) %a@] %a"
+ Stmt.pretty_sid stmt
+ Node.pretty s
+ (GraphShape.pretty (Edge.pretty_list)) g
+
+ let hash = function
+ | Assume (_, e, b) ->
+ Hashtbl.seeded_hash (Hashtbl.hash b) (ExpStructEq.hash e)
+ | Assign (_, lv, t, e) ->
+ Hashtbl.seeded_hash (ExpStructEq.hash e)
+ (Hashtbl.seeded_hash (Typ.hash t)
+ (Hashtbl.seeded_hash 2 (Lval.hash lv)))
+ | EnterScope (_, vs) ->
+ List.fold_left
+ (fun acc e -> Hashtbl.seeded_hash acc (Varinfo.hash e)) 3 vs
+ | LeaveScope (_, vs) ->
+ List.fold_left
+ (fun acc e -> Hashtbl.seeded_hash acc (Varinfo.hash e)) 5 vs
+ | CallDeclared (kf, es, lv) ->
+ let x = Kernel_function.hash kf in
+ let x = Hashtbl.seeded_hash x (Extlib.opt_hash Lval.hash lv) in
+ List.fold_left
+ (fun acc e -> Hashtbl.seeded_hash acc (ExpStructEq.hash e)) x es
+ | Msg s -> Hashtbl.seeded_hash 7 s
+ | Loop (stmt, s, g) ->
+ Hashtbl.seeded_hash (Stmt.hash stmt)
+ (Hashtbl.seeded_hash (GraphShape.hash g)
+ (Hashtbl.seeded_hash 11 (Node.hash s)))
+end
+
+module EdgeList = struct
+ include Datatype.List_with_collections(Edge)
+ (struct let module_name = "Value.Traces_domain.EdgeList" end)
+ let pretty = Edge.pretty_list
+ let pretty_debug = pretty
+end
+
+module Graph = struct
+ include Hptmap.Make(Node)(EdgeList)(Hptmap.Comp_unused)
+ (struct let v = [[]] end)
+ (struct let l = [Ast.self] end)
+
+ let is_included =
+ let cache = Hptmap_sig.NoCache in
+ let decide_fast = decide_fast_inclusion in
+ let decide_fst _n _v1 = false in
+ let decide_snd _n _v2 = true in
+ let rec decide_both k l1 l2 =
+ match l1, l2 with
+ | [], _ -> true
+ | _, [] -> false
+ | h1 :: t1, h2 :: t2 ->
+ let c = Edge.compare h1 h2 in
+ if c = 0 then decide_both k t1 t2
+ else if c < 0 then false
+ else decide_both k l1 t2
+ in
+ binary_predicate cache UniversalPredicate
+ ~decide_fast ~decide_fst ~decide_snd ~decide_both
+
+ let join =
+ let cache = Hptmap_sig.NoCache in
+ let rec merge_edge k l1 l2 =
+ match l1, l2 with
+ | [], l2 -> l2
+ | l1, [] -> l1
+ | h1 :: t1, h2 :: t2 ->
+ let c = Edge.compare h1 h2 in
+ if c = 0 then h1 :: merge_edge k t1 t2
+ else if c < 0 then h1 :: merge_edge k t1 l2
+ else h2 :: merge_edge k l1 t2
+ in
+ join ~cache ~symmetric:true ~idempotent:true ~decide:merge_edge
+
+ let diff =
+ let cache = Hptmap_sig.NoCache in
+ let decide_left = Neutral in
+ let decide_right = Absorbing in
+ let rec diff_list k l1 l2 =
+ match l1, l2 with
+ | [], _ -> []
+ | l1, [] -> l1
+ | h1 :: t1, h2 :: t2 ->
+ let c = Edge.compare h1 h2 in
+ if c = 0 then diff_list k t1 t2
+ else if c < 0 then h1 :: diff_list k t1 l2
+ else diff_list k l1 t2
+ in
+ let decide_both k l1 l2 = match diff_list k l1 l2 with [] -> None | l -> Some l in
+ merge ~cache ~symmetric:false ~idempotent:false
+ ~decide_both ~decide_left ~decide_right
+
+ let succs (n : Node.t) g = try find n g with Not_found -> []
+
+ let rec epsilon_path current stop g =
+ Node.equal current stop ||
+ begin
+ Node.compare current stop <= 0 &&
+ match find current g with
+ | exception Not_found -> false
+ | l ->
+ let exists = function
+ | { edge_dst; edge_trans = Msg _ } -> epsilon_path edge_dst stop g
+ | _ -> false
+ in
+ List.exists exists l
+ end
+end
+
+let create_edge all_edges_ever_created current e =
+ let m = Graph.singleton current [e] in
+ let old = !all_edges_ever_created in
+ let new_ = Graph.join old m in
+ (* if not (Graph.equal old new_) then *)
+ (* Format.printf "@[<hv>@[create_edge: %a ->@]@ %a@]@." *)
+ (* Node.pretty current Edge.pretty e; *)
+ all_edges_ever_created := new_;
+ m
+
+let join_path ~all_edges_ever_created g c1 c2 =
+ if Graph.epsilon_path c1 c2 g then (c2, g)
+ else if Graph.epsilon_path c2 c1 g then (c1, g)
+ else
+ let t_join = Msg "join" in
+ let is_join e = Transition.equal e.edge_trans t_join in
+ let e =
+ let succs1 = Graph.succs c1 !all_edges_ever_created in
+ let succs2 = Graph.succs c2 !all_edges_ever_created in
+ let succs1 = List.filter is_join succs1 in
+ let find s1 = List.exists (Edge.equal s1) succs2 in
+ begin match List.find find succs1 with
+ | exception Not_found ->
+ { edge_dst = Node.next () ; edge_trans = t_join }
+ | m ->
+ { edge_dst = Edge.succ m ; edge_trans = t_join }
+ end
+ in
+ let m1 = create_edge all_edges_ever_created c1 e in
+ let m2 = create_edge all_edges_ever_created c2 e in
+ let g = Graph.join (Graph.join m1 g) m2 in
+ (e.edge_dst, g)
+
+(* A loop .*)
+type loops =
+ | Base of Node.t * Graph.t (* current last *)
+ | OpenLoop of Cil_types.stmt * Node.t (* start node *) * Graph.t (* last iteration *) * Node.t (** current *) * Graph.t * loops
+ | UnrollLoop of Cil_types.stmt * loops
+
+module Loops = struct
+ type t = loops
+
+ let rec is_included l1 l2 = match l1, l2 with
+ | Base _, (OpenLoop _ | UnrollLoop _)
+ | (OpenLoop _ | UnrollLoop _), Base _ ->
+ (* not in the same number of loops *)
+ false
+ | Base (c1,_), Base (c2,g2) ->
+ Graph.epsilon_path c1 c2 g2
+ | (OpenLoop(stmt1,_,_,_,_,_) | UnrollLoop(stmt1,_)),
+ (OpenLoop(stmt2,_,_,_,_,_) | UnrollLoop(stmt2,_)) when not (Stmt.equal stmt1 stmt2) ->
+ (* not same loop *)
+ false
+ | OpenLoop(_,s1,_,_,_,_), OpenLoop(_,s2,_,_,_,_) when not (Node.equal s1 s2) ->
+ (* not entered in the loop at the same time, take arbitrarily one of them *)
+ false
+ | OpenLoop(_,_,last1,c1,g1,l1), OpenLoop(_,_,last2,c2,g2,l2) ->
+ let g2' = Graph.join last2 g2 in
+ is_included l1 l2 &&
+ Graph.is_included last1 last2 &&
+ Graph.is_included g1 g2' &&
+ Graph.epsilon_path c1 c2 g2'
+ | UnrollLoop(_,l1), UnrollLoop(_,l2) ->
+ is_included l1 l2
+ | OpenLoop(_,_,_,_,_,_), UnrollLoop(_,_) ->
+ false
+ | UnrollLoop(_,l1), OpenLoop(_,_,_,_,_,l2) ->
+ is_included l1 l2
+
+ let rec diff l1 l2 = match l1, l2 with
+ | Base _, (OpenLoop _ | UnrollLoop _) | (OpenLoop _ | UnrollLoop _), Base _ ->
+ (* not in the same number of loops *)
+ `Bottom
+ | Base (c1,g1), Base (_,g2) ->
+ let g = Graph.diff g1 g2 in
+ `Value (Base (c1, g))
+ | (OpenLoop(stmt1,_,_,_,_,_) | UnrollLoop(stmt1,_)),
+ (OpenLoop(stmt2,_,_,_,_,_) | UnrollLoop(stmt2,_)) when not (Stmt.equal stmt1 stmt2) ->
+ (* not same loop *)
+ `Bottom
+ | OpenLoop(stmt1,s1,last1,c1,g1,l1), OpenLoop(_,s2,_,_,_,l2) when not (Node.equal s1 s2) ->
+ (* not entered in the loop at the same time, take arbitrarily one of them *)
+ begin match diff l1 l2 with
+ | `Bottom -> `Bottom
+ | `Value(l) -> `Value(OpenLoop(stmt1,s1,last1,c1,g1,l))
+ end
+ | OpenLoop(stmt,s,last1,c1,g1,l1), OpenLoop(_,_,last2,_,g2,l2) ->
+ begin match diff l1 l2 with
+ | `Bottom -> `Bottom
+ | `Value(l) ->
+ let last = Graph.diff last1 last2 in
+ let g = Graph.diff g1 g2 in
+ `Value(OpenLoop(stmt,s,last,c1,g,l))
+ end
+ | UnrollLoop(stmt,l1), UnrollLoop(_,l2) ->
+ begin match diff l1 l2 with
+ | `Bottom -> `Bottom
+ | `Value l -> `Value (UnrollLoop(stmt,l))
+ end
+ | (OpenLoop(stmt,s,last,c,g,l1), UnrollLoop(_,l2)) ->
+ begin match diff l1 l2 with
+ | `Bottom -> `Bottom
+ | `Value l -> `Value (OpenLoop(stmt,s,last,c,g,l))
+ end
+ | (UnrollLoop(stmt,l2), OpenLoop(_,_,_,_,_,l1)) ->
+ begin match diff l1 l2 with
+ | `Bottom -> `Bottom
+ | `Value l -> `Value (UnrollLoop(stmt,l))
+ end
+
+ let rec compare l1 l2 = match l1, l2 with
+ | Base (c1,g1), Base (c2,g2) ->
+ let c = Node.compare c1 c2 in
+ if c <> 0 then c else
+ Graph.compare g1 g2
+ | OpenLoop(stmt1,s1, last1, c1, g1, l1), OpenLoop(stmt2,s2, last2, c2, g2, l2) ->
+ let c = Stmt.compare stmt1 stmt2 in
+ if c <> 0 then c else
+ let c = Node.compare s1 s2 in
+ if c <> 0 then c else
+ let c = Graph.compare last1 last2 in
+ if c <> 0 then c else
+ let c = Node.compare c1 c2 in
+ if c <> 0 then c else
+ let c = Graph.compare g1 g2 in
+ if c <> 0 then c else
+ compare l1 l2
+ | UnrollLoop(stmt1,l1), UnrollLoop(stmt2,l2) ->
+ let c = Stmt.compare stmt1 stmt2 in
+ if c <> 0 then c else
+ compare l1 l2
+ | Base _, _ -> -1
+ | _, Base _ -> 1
+ | OpenLoop _, _ -> -1
+ | _, OpenLoop _ -> 1
+
+ let rec pretty fmt = function
+ | Base (c,g) ->
+ Format.fprintf fmt "@[<hv>%a @[at %a@]@]"
+ Graph.pretty g Node.pretty c
+ | OpenLoop(stmt,s,last,c,g,l) ->
+ Format.fprintf fmt "@[<hv 1>@[loop(%a) %a@]@ @[<hv 1>@[last:@]@ %a@]@ @[<hv 1>@[c:@]@ %a@]@ @[at %a@]@]@ %a"
+ Stmt.pretty_sid stmt
+ Node.pretty s Graph.pretty last Graph.pretty g Node.pretty c pretty l
+ | UnrollLoop(stmt,l) ->
+ Format.fprintf fmt "@[<hv>@[unroll(%a)@]@ %a"
+ Stmt.pretty_sid stmt
+ pretty l
+
+ let rec hash = function
+ | Base (c,g) ->
+ Hashtbl.seeded_hash (Hashtbl.seeded_hash 1 (Graph.hash g)) (Node.hash c)
+ | OpenLoop(stmt,s,last,c,g,l) ->
+ Hashtbl.seeded_hash 2
+ (Stmt.hash stmt, Node.hash s, Graph.hash last, Node.hash c,
+ Graph.hash g, hash l)
+ | UnrollLoop(stmt,l) ->
+ Hashtbl.seeded_hash 2
+ (Stmt.hash stmt, hash l)
+end
+
+let rec join_loops ~all_edges_ever_created l1 l2 =
+ match l1, l2 with
+ | Base _, (OpenLoop _ | UnrollLoop _) | (OpenLoop _ | UnrollLoop _), Base _ ->
+ (* not in the same number of loops *)
+ `Top
+ | Base (c1,g1), Base (c2,g2) ->
+ let g = Graph.join g1 g2 in
+ let (n,g) = join_path ~all_edges_ever_created g c1 c2 in
+ `Value( Base (n, g))
+ | (OpenLoop(stmt1,_,_,_,_,_) | UnrollLoop(stmt1,_)),
+ (OpenLoop(stmt2,_,_,_,_,_) | UnrollLoop(stmt2,_)) when not (Stmt.equal stmt1 stmt2) ->
+ (* not same loop *)
+ `Top
+ | OpenLoop(stmt1,s1,last1,c1,g1,l1), OpenLoop(_,s2,_,_,_,l2) when not (Node.equal s1 s2) ->
+ (* not entered in the loop at the same time, take arbitrarily one of them *)
+ begin match join_loops ~all_edges_ever_created l1 l2 with
+ | `Top -> `Top
+ | `Value(l) -> `Value(OpenLoop(stmt1,s1,last1,c1,g1,l))
+ end
+ | OpenLoop(stmt,s,last1,c1,g1,l1), OpenLoop(_,_,last2,c2,g2,l2) ->
+ begin match join_loops ~all_edges_ever_created l1 l2 with
+ | `Top -> `Top
+ | `Value(l) ->
+ let last = Graph.join last1 last2 in
+ let g = Graph.join g1 g2 in
+ let (n,g) = join_path ~all_edges_ever_created g c1 c2 in
+ `Value(OpenLoop(stmt,s,last,n,g,l))
+ end
+ | UnrollLoop(stmt,l1), UnrollLoop(_,l2) ->
+ begin match join_loops ~all_edges_ever_created l1 l2 with
+ | `Top -> `Top
+ | `Value l -> `Value (UnrollLoop(stmt,l))
+ end
+ | (OpenLoop(stmt,s,last,c,g,l1), UnrollLoop(_,l2))
+ | (UnrollLoop(_,l2), OpenLoop(stmt,s,last,c,g,l1)) ->
+ begin match join_loops ~all_edges_ever_created l1 l2 with
+ | `Top -> `Top
+ | `Value l -> `Value (OpenLoop(stmt,s,last,c,g,l))
+ end
+
+
+type state = { start : Node.t; current : loops;
+ call_declared_function: bool;
+ globals : Cil_types.varinfo list;
+ main_formals : Cil_types.varinfo list;
+ (** kind of memoization of the edges *)
+ all_edges_ever_created : Graph.t ref;
+ all_loop_start : (Node.t * Graph.t) Stmt.Hashtbl.t;
+ }
+
+let start s = s.start
+let current s = s.current
+let globals s = s.globals
+let entry_formals s = s.main_formals
+
+(* Lattice structure for the abstract state above *)
+module Traces = struct
+
+ (** impossible for normal values start must be bigger than current *)
+ let new_empty () = { start = Node.start; current = Base (Node.start, Graph.empty);
+ call_declared_function = false;
+ globals = []; main_formals = [];
+ all_edges_ever_created = ref Graph.empty;
+ all_loop_start = Stmt.Hashtbl.create 10;
+ }
+ let empty = new_empty ()
+ let top = { (new_empty ()) with current = Base (Node.dumb, Graph.empty); }
+
+ (* Frama-C "datatype" for type [inout] *)
+ include Datatype.Make_with_collections(struct
+ include Datatype.Serializable_undefined
+
+ type t = state
+ let name = "Value.Traces_domain.Traces.state"
+
+ let reprs = [empty]
+
+ let structural_descr = Structural_descr.t_record
+ [| Descr.pack Datatype.Int.descr;
+ Descr.pack Datatype.Int.descr;
+ Descr.pack Graph.descr;
+ Descr.pack Datatype.Bool.descr;
+ Structural_descr.pack Structural_descr.t_abstract;
+ Structural_descr.pack Structural_descr.t_abstract;
+ |]
+
+ let compare m1 m2 =
+ let c = Node.compare m1.start m2.start in
+ if c <> 0 then c else
+ let c = Loops.compare m1.current m2.current in
+ if c <> 0 then c else
+ let c = Datatype.Bool.compare m1.call_declared_function m2.call_declared_function in
+ if c <> 0 then c else
+ 0
+
+ let equal = Datatype.from_compare
+
+ let pretty fmt m =
+ if m == top then Format.fprintf fmt "TOP"
+ else
+ Format.fprintf fmt "@[<hv>@[@[start: %a;@]@ @[globals = %a;@]@ @[main_formals = %a;@]@]@ %a@]"
+ Node.pretty m.start
+ (Pretty_utils.pp_list ~sep:",@ " Varinfo.pretty) m.globals
+ (Pretty_utils.pp_list ~sep:",@ " Varinfo.pretty) m.main_formals
+ Loops.pretty m.current
+
+ let hash m =
+ Hashtbl.seeded_hash (Node.hash m.start) (Loops.hash m.current)
+
+ let copy c = c
+
+ end)
+
+ let view m =
+ if m == top then `Top
+ else `Other m
+
+ let map_base f state =
+ let rec aux = function
+ | Base (c, g) ->
+ let c, g = f (c, g) in Base (c, g)
+ | OpenLoop (stmt, s, last, c, g, l) ->
+ let c, g = f (c, g) in OpenLoop(stmt, s, last, c, g, l)
+ | UnrollLoop (stmt, l) -> UnrollLoop (stmt, aux l)
+ in { state with current = aux state.current }
+
+ let move_to c g = map_base (fun _ -> c, g)
+ let replace_to c = map_base (fun (_, g) -> c, g)
+
+ let get_current state =
+ let rec aux = function
+ | Base (c,g) -> (c,g)
+ | OpenLoop(_,_,_,c,g,_) -> (c,g)
+ | UnrollLoop(_,l) ->
+ aux l in
+ aux state.current
+
+ let add_trans_aux state t =
+ let add_edge (current, graph) =
+ let e =
+ (** try to reuse an edge from the pool *)
+ let succs = Graph.succs current !(state.all_edges_ever_created) in
+ try List.find (Edge.has_transition t) succs
+ with Not_found ->
+ (** create a new edge *)
+ { edge_trans = t; edge_dst = Node.next () }
+ in
+ let n = e.edge_dst in
+ let m = create_edge state.all_edges_ever_created current e in
+ let graph = Graph.join m graph in
+ (n, graph)
+ in
+ map_base add_edge state
+
+ let add_trans c t =
+ if c == top then c
+ else if c.call_declared_function then c (** forget intermediary state *)
+ else
+ let c = if c == empty then new_empty () else c in
+ add_trans_aux c t
+
+ let copy_edges s old_current_node g state =
+ let cache = Node.Hashtbl.create 10 in
+ let rec aux old_current_node state =
+ let current_node = (fst (get_current state)) in
+ let succs = Graph.succs old_current_node g in
+ let fold state e =
+ let next_old = Edge.succ e in
+ let state = match Node.Hashtbl.find cache next_old with
+ | exception Not_found ->
+ let state = add_trans state e.edge_trans in
+ Node.Hashtbl.add cache next_old (fst (get_current state));
+ let state = aux next_old state in
+ replace_to current_node state
+ | next ->
+ let (_,g) = get_current state in
+ let e = Edge.change_next next e in
+ let m = create_edge state.all_edges_ever_created current_node e in
+ let g = Graph.join m g in
+ move_to next g state
+ in
+ replace_to current_node state
+ in
+ List.fold_left fold state succs
+ in
+ let state = aux s state in
+ let c = Node.Hashtbl.find cache old_current_node in
+ replace_to c state
+
+ let is_included c1 c2 =
+ (* start is the same *)
+ let r =
+ c1.start = c2.start &&
+ Loops.is_included c1.current c2.current in
+ if not r && compare c1 c2 = 0 then
+ Printf.printf "bad is_included@.";
+ r
+
+ let not_same_origin c1 c2 =
+ c1.start != c2.start ||
+ c1.globals != c2.globals ||
+ c1.main_formals != c2.main_formals ||
+ c1.all_edges_ever_created != c2.all_edges_ever_created
+
+ 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@]"
+ pretty c1 pretty c2
+ else
+ match view c1, view c2 with
+ | `Top, _ -> c1
+ | _, `Top -> c2
+ | `Other c1, `Other c2 when is_included c1 c2 -> c2
+ | `Other c1, `Other c2 when is_included c2 c1 -> c1
+ | `Other c1, `Other c2 ->
+ if not_same_origin c1 c2 then assert false
+ else
+ let all_edges_ever_created = c1.all_edges_ever_created in
+ match join_loops ~all_edges_ever_created c1.current c2.current with
+ | `Top -> top
+ | `Value(current) -> {c1 with current}
+
+ let add_loop stmt state =
+ let (n,g) = get_current state in
+ let succs = Graph.succs n g in
+ let rec find_same_loop = function
+ | [] ->
+ Stmt.Hashtbl.memo state.all_loop_start stmt (fun _ -> Node.next (),Graph.empty)
+ | edge :: tl ->
+ match edge.edge_trans with
+ | Loop (stmt',s,last) when Stmt.equal stmt' stmt ->
+ s, Graph.from_shape_id last
+ | _ -> find_same_loop tl
+ in
+ let s,last = find_same_loop succs in
+ let current = OpenLoop(stmt,s,last,s,Graph.empty,state.current) in
+ { state with current }
+
+ let widen _ stmt' c1 c2 =
+ if false then
+ begin
+ if Loops.compare c1.current c2.current = 0
+ then
+ Format.printf "@[<hv 2>@[widen %a: same loops, states are%s equal @]@]@."
+ Stmt.pretty_sid stmt' (if compare c1 c2 = 0 then "" else " not")
+ else
+ let c1' = Loops.diff c1.current c2.current in
+ let c2' = Loops.diff c2.current c1.current in
+ if (Bottom.compare Loops.compare) c1' c2' = 0 then
+ Format.printf "@[<hv 2>@[widen %a diff equal:@]@ @[<hv 1>@[c1:@]@ %a@]@ @[<hv 1>@[c2:@]@ %a@]@]@."
+ Stmt.pretty_sid stmt'
+ Loops.pretty c1.current
+ Loops.pretty c2.current
+
+ else
+ Format.printf "@[<hv 2>@[widen %a diff different:@]@ @[<hv 1>@[c1':@]@ %a@]@ @[<hv 1>@[c2':@]@ %a@]@]@."
+ Stmt.pretty_sid stmt'
+ (Bottom.pretty Loops.pretty) c1'
+ (Bottom.pretty Loops.pretty) c2'
+ end;
+ if false then
+ begin
+ if Loops.compare c1.current c2.current = 0
+ then
+ Format.printf "@[<hv 2>@[widen %a: same loops, states are%s equal @]@]@."
+ Stmt.pretty_sid stmt' (if compare c1 c2 = 0 then "" else " not")
+ else
+ Format.printf "@[<hv 2>@[widen %a@]@]@." Stmt.pretty_sid stmt'
+ end;
+ if not (Value_parameters.TracesUnrollLoop.get ())
+ then c2
+ else begin
+ match c2.current with
+ | Base _ -> assert false (** must be in a loop *)
+ | OpenLoop(stmt,_,_,_,_,_) ->
+ assert (Stmt.equal stmt' stmt);
+ c2
+ | UnrollLoop(stmt,l) ->
+ assert (Stmt.equal stmt' stmt);
+ add_loop stmt' {c2 with current = l}
+ end
+
+ let narrow _c1 c2 = `Value c2
+end
+
+
+module GraphDot = OCamlGraph.Graphviz.Dot(struct
+ module V = struct type t = {node : Node.t; loops : Node.t list} end
+ module E = struct
+ open V
+ type t =
+ | Usual of Node.t * Edge.t * Node.t list
+ | Head of Node.t * Node.t list * Node.t * Node.t list
+ | Back of Node.t * Node.t list * Node.t
+ let src = function
+ | Usual (src,_,loops) -> {node=src;loops}
+ | Head (src,loops,_,_) -> {node=src;loops}
+ | Back (_,loops,src) -> {node=src;loops}
+ let dst = function
+ | Usual (_,edge,loops) -> {node=Edge.succ edge;loops}
+ | Head (_,_,s,loops) -> {node=s;loops}
+ | Back (dst,loops,_) -> {node=dst;loops}
+ end
+ open V
+ open E
+ type t = Graph.t
+ let iter_vertex f g =
+ let rec iter_edge k (l: Node.t list) e = match e.edge_trans with
+ | Loop(_,_,g) -> iter_vertex (k::l) g
+ | _ -> ()
+ and iter_vertex l g =
+ GraphShape.iter (fun k e -> f {node=k;loops=l}; List.iter (iter_edge k l) e) g
+ in
+ iter_vertex [] (Graph.shape g)
+ let iter_edges_e f g =
+ let rec iter_edge k l e =
+ f (Usual(k,e,l));
+ match e.edge_trans with
+ | Loop(_,s,g) ->
+ let l' = (k::l) in
+ f (Head(k,l,s,l'));
+ iter_vertex (Some s) l' g
+ | _ -> ()
+ and iter_vertex back l g =
+ GraphShape.iter (fun k e ->
+ match e, back with
+ | [], Some back -> f (Back(back,l,k))
+ | e, _ -> List.iter (iter_edge k l) e) g
+ in
+ iter_vertex None [] (Graph.shape g)
+
+ let graph_attributes _ = []
+ let default_vertex_attributes :
+ t -> OCamlGraph.Graphviz.DotAttributes.vertex list = fun _ -> []
+ let subgraph_name loops =
+ Format.asprintf "S%a"
+ (fun fmt -> List.iter (fun s -> Format.fprintf fmt "L%a" Node.pretty s))
+ loops
+ let vertex_name v = Format.asprintf "n%a%s" Node.pretty v.node
+ (subgraph_name v.loops)
+ let vertex_attributes :
+ V.t -> OCamlGraph.Graphviz.DotAttributes.vertex list =
+ fun n -> [`Label (Format.asprintf "%a" Node.pretty n.node)]
+ let get_subgraph v =
+ match v.loops with
+ | [] -> None
+ | _::l -> Some
+ {OCamlGraph.Graphviz.DotAttributes.sg_name = subgraph_name v.loops;
+ sg_attributes = [];
+ sg_parent = if l = [] then None else Some (subgraph_name l); }
+ let default_edge_attributes :
+ t -> OCamlGraph.Graphviz.DotAttributes.edge list = fun _ -> []
+ let edge_attributes : E.t -> OCamlGraph.Graphviz.DotAttributes.edge list =
+ function
+ | Usual(_,{edge_trans = Loop _},_) -> [`Label (Format.asprintf "leave_loop")]
+ | Usual(_,e,_) -> [`Label (Format.asprintf "@[<h>%a@]" Transition.pretty e.edge_trans)]
+ | Head _ -> []
+ | Back(_,_,_) -> [`Constraint false]
+ end)
+
+(** adds n -> [] for leaves *)
+let rec complete_graph (graph:Graph.t) =
+ Graph.fold (fun k l graph ->
+ let graph, l =
+ Extlib.fold_map (fun graph e ->
+ let m = Graph.singleton (Edge.succ e) [] in
+ let e = match e.edge_trans with
+ | Assign (_, _,_,_)
+ | Assume (_, _,_)
+ | EnterScope _
+ | LeaveScope _
+ | CallDeclared (_,_,_)
+ | Msg _ -> e
+ | Loop (stmt,s,g) ->
+ let n = e.edge_dst in
+ let g = Graph.shape (complete_graph (Graph.from_shape_id g)) in
+ { edge_dst = n; edge_trans = Loop(stmt,s,g) }
+ in
+ Graph.join graph m, e)
+ graph l
+ in
+ Graph.join graph (Graph.singleton k l)
+ ) graph Graph.empty
+
+
+module Internal = struct
+ type nonrec state = state
+ type value = Cvalue.V.t
+ type location = Precise_locs.precise_location
+
+ include (Traces: sig
+ include Datatype.S_with_collections with type t = state
+ include Abstract_domain.Lattice with type state := state
+ end)
+
+ let log_category = Value_parameters.register_category "d-traces"
+
+ type origin = unit
+
+ module Transfer (Valuation: Abstract_domain.Valuation
+ with type value = value
+ and type origin = origin
+ and type loc = Precise_locs.precise_location)
+ : Abstract_domain.Transfer
+ with type state = state
+ and type value = Cvalue.V.t
+ and type location = Precise_locs.precise_location
+ and type valuation = Valuation.t
+ = struct
+ type value = Cvalue.V.t
+ type state = t
+ type location = Precise_locs.precise_location
+ type valuation = Valuation.t
+
+ let assign ki lv e _v _valuation state =
+ let trans = Assign (ki, lv.Eval.lval, lv.Eval.ltyp, e) in
+ `Value (Traces.add_trans state trans)
+
+ let assume stmt e pos _valuation state =
+ let trans = Assume (stmt, e, pos) in
+ `Value (Traces.add_trans state trans)
+
+ let start_call stmt call _valuation state =
+ let kf = call.Eval.kf in
+ if Kernel_function.is_definition kf then
+ let msg = Format.asprintf "start_call: %s (%b)" (Kernel_function.get_name call.Eval.kf)
+ (Kernel_function.is_definition call.Eval.kf) in
+ let state = Traces.add_trans state (Msg msg) in
+ let formals = List.map (fun arg -> arg.Eval.formal) call.Eval.arguments in
+ let state = Traces.add_trans state (EnterScope (kf, formals)) in
+ let state = List.fold_left (fun state arg ->
+ Traces.add_trans state
+ (Assign (Kstmt stmt, Cil.var arg.Eval.formal,
+ arg.Eval.formal.Cil_types.vtype,
+ arg.Eval.concrete))) state call.Eval.arguments in
+ `Value state
+ else
+ (** enter the scope of the dumb result variable *)
+ let var = call.Eval.return in
+ let state = match var with
+ | Some var -> Traces.add_trans state (EnterScope (kf, [var]))
+ | None -> state in
+ let exps = List.map (fun arg -> arg.Eval.concrete) call.Eval.arguments in
+ let state = Traces.add_trans state
+ (CallDeclared (call.Eval.kf, exps, Extlib.opt_map Cil.var var))
+ in `Value {state with call_declared_function = true}
+
+ let finalize_call _stmt call ~pre:_ ~post =
+ if post.call_declared_function
+ then `Value {post with call_declared_function = false}
+ else
+ let msg = Format.asprintf "finalize_call: %s" (Kernel_function.get_name call.Eval.kf) in
+ let state = Traces.add_trans post (Msg msg) in
+ `Value state
+
+ let update _valuation state = `Value state
+
+ let show_expr _valuation state fmt _expr = Traces.pretty fmt state
+ end
+
+ (* Memexec *)
+ (* This domains infers no relation between variables. *)
+ let relate _kf _bases _state = Base.SetLattice.bottom
+ (* Do not filter the state: the memexec cache will be applied only on function
+ calls for which the entry states are equal. This almost completely
+ disable memexec, but is always sound. *)
+ let filter _kf _kind _bases state = state
+ (* As memexec cache is only applied on equal entry states, the previous
+ output state is a correct output for the current input state. *)
+ let reuse _kf _bases ~current_input:_ ~previous_output:state = state
+
+ let empty () = Traces.empty
+ let introduce_globals vars state =
+ {state with globals = vars @ state.globals}
+ let initialize_variable lv _ ~initialized:_ _ state =
+ Traces.add_trans state (Msg(Format.asprintf "initialize variable: %a" Printer.pp_lval lv ))
+ let initialize_variable_using_type init_kind varinfo state =
+ let state =
+ match init_kind with
+ | Abstract_domain.Main_Formal -> {state with main_formals = varinfo::state.main_formals}
+ | _ -> state
+ in
+ let msg = Format.asprintf "initialize@ variable@ using@ type@ %a@ %a"
+ (fun fmt init_kind ->
+ match init_kind with
+ | Abstract_domain.Main_Formal -> Format.pp_print_string fmt "Main_Formal"
+ | Abstract_domain.Library_Global -> Format.pp_print_string fmt "Library_Global"
+ | Abstract_domain.Spec_Return kf -> Format.fprintf fmt "Spec_Return(%s)" (Kernel_function.get_name kf))
+ init_kind
+ Varinfo.pretty varinfo
+ in
+ Traces.add_trans state (Msg msg)
+
+ (* TODO *)
+ let logic_assign _assign _location ~pre:_ state =
+ Traces.add_trans state (Msg "logic assign")
+
+ (* Logic *)
+ let evaluate_predicate _ _ _ = Alarmset.Unknown
+ let reduce_by_predicate _ state _ _ = `Value state
+
+ let storage () = true
+
+ let top_query = `Value (Cvalue.V.top, ()), Alarmset.all
+
+ let extract_expr _oracle _state _expr = top_query
+ let extract_lval _oracle _state _lv _typ _locs = top_query
+
+ let backward_location _state _lval _typ loc value =
+ `Value (loc, value)
+
+ let enter_loop stmt state =
+ let state = Traces.add_trans state (Msg "enter_loop") in
+ let state = if not (Value_parameters.TracesUnrollLoop.get ())
+ then Traces.add_loop stmt state
+ else { state with current = UnrollLoop(stmt,state.current) } in
+ state
+
+ let incr_loop_counter _ state =
+ match state.current with
+ | Base _ -> assert false
+ | UnrollLoop(_,_) -> state
+ | OpenLoop(stmt,s,last,_,g,l) ->
+ let last = Graph.join last g in
+ let last = if Value_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');
+ Stmt.Hashtbl.add state.all_loop_start stmt (s,last);
+ last
+ else last
+ in
+ let current = OpenLoop(stmt,s,last,s,Graph.empty,l) in
+ let state = { state with current } in
+ (* Traces.add_trans state (Msg("incr_loop_counter")) *)
+ state
+
+ let leave_loop stmt' state =
+ match state.current with
+ | Base _ -> assert false (* absurd: we are in at least a loop *)
+ | UnrollLoop(_,l) -> { state with current = l }
+ | 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 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');
+ Stmt.Hashtbl.add state.all_loop_start stmt (s,last);
+ last
+ else last
+ in
+ let state = if Graph.is_empty last then state
+ else Traces.add_trans state (Loop(stmt,s,Graph.shape last)) in
+ let state = Traces.copy_edges s old_current_node g state in
+ Traces.add_trans state (Msg "leave_loop")
+
+
+ let enter_scope kf vars state = Traces.add_trans state (EnterScope (kf, vars))
+ let leave_scope kf vars state = Traces.add_trans state (LeaveScope (kf, vars))
+
+ let reduce_further _state _expr _value = [] (*Nothing intelligent to suggest*)
+
+end
+
+let dummy_loc = Location.unknown
+
+let subst_in_full var_mapping =
+ let visit = Visitor_behavior.copy (Project.current ()) in
+ visit, object
+ inherit Cil.genericCilVisitor (visit)
+ method! vvrbl vi =
+ match Varinfo.Map.find vi var_mapping with
+ | exception Not_found -> Cil.DoChildren
+ | v -> Cil.ChangeTo v
+ method! vlogic_var_use lv =
+ match lv.Cil_types.lv_origin with
+ | None -> Cil.DoChildren
+ | Some vi ->
+ match Varinfo.Map.find vi var_mapping with
+ | exception Not_found -> Cil.DoChildren
+ | v -> Cil.ChangeTo (Cil.cvar_to_lvar v)
+ end
+
+let subst_in var_mapping = (snd (subst_in_full var_mapping))
+
+let sanitize_name s =
+ String.map
+ (fun c ->
+ if
+ ('0' <= c && c <= '9') ||
+ ('a' <= c && c <= 'z') ||
+ ('A' <= c && c <= 'Z')
+ then c else '_') s
+
+let subst_in_exp var_map exp = Cil.visitCilExpr (subst_in var_map) exp
+let subst_in_lval var_map exp = Cil.visitCilLval (subst_in var_map) exp
+let subst_in_varinfo var_map v =
+ match Varinfo.Map.find v var_map with
+ | exception Not_found -> v
+ | v -> v
+
+let fresh_varinfo var_map v =
+ let v' = Cil.copyVarinfo v (sanitize_name v.Cil_types.vname) in
+ v'.Cil_types.vdefined <- false;
+ Varinfo.Map.add v v' var_map
+
+let valid_sid = true
+
+let rec stmts_of_cfg cfg current var_map locals return_exp acc =
+ match Graph.find current cfg with
+ | exception Not_found ->
+ begin match return_exp with
+ | None -> List.rev acc
+ | Some (var,exp) ->
+ let exp = subst_in_exp var_map exp in
+ let return_stmt = Cil.mkStmtOneInstr ~valid_sid (Cil_types.Set(Cil.var var,exp,dummy_loc)) in
+ List.rev (return_stmt::acc)
+ end
+ | [] -> assert false
+ | [a] -> begin
+ let n = a.edge_dst in
+ match a.edge_trans with
+
+ | Assign (_, lval,_typ,exp) ->
+ let exp = subst_in_exp var_map exp in
+ let lval = subst_in_lval var_map lval in
+ let stmt = Cil.mkStmtOneInstr ~valid_sid (Cil_types.Set(lval,exp,dummy_loc)) in
+ stmts_of_cfg cfg n var_map locals return_exp (stmt::acc)
+
+ | Assume (_, exp,b) ->
+ let exp = subst_in_exp var_map exp in
+ let predicate = (Logic_utils.expr_to_predicate ~cast:true exp).Cil_types.ip_content in
+ let predicate = if b then predicate else Logic_const.pnot predicate in
+ let code_annot = Logic_const.new_code_annotation(Cil_types.AAssert([],Assert,predicate)) in
+ let stmt = Cil.mkStmtOneInstr ~valid_sid (Cil_types.Code_annot(code_annot,dummy_loc)) in
+ stmts_of_cfg cfg n var_map locals return_exp (stmt::acc)
+
+ | EnterScope (_, vs) ->
+ (** all our variables are assigned, not defined *)
+ let var_map = List.fold_left fresh_varinfo var_map vs in
+ let vs = List.map (subst_in_varinfo var_map) vs in
+ locals := vs @ !locals;
+ let block = { Cil_types.battrs = [];
+ bscoping = true;
+ blocals = vs;
+ bstatics = [];
+ bstmts = stmts_of_cfg cfg n var_map locals return_exp [] } in
+ let stmt = Cil.mkStmt ~valid_sid (Cil_types.Block(block)) in
+ List.rev (stmt::acc)
+
+ | LeaveScope _ -> stmts_of_cfg cfg n var_map locals return_exp acc
+
+ | CallDeclared (kf,exps,lval) ->
+ let exps = List.map (subst_in_exp var_map) exps in
+ let lval = Extlib.opt_map (subst_in_lval var_map) lval in
+ let call = Cil.evar ~loc:dummy_loc (subst_in_varinfo var_map (Kernel_function.get_vi kf)) in
+ let stmt = Cil.mkStmtOneInstr ~valid_sid (Cil_types.Call(lval,call,exps,dummy_loc)) in
+ stmts_of_cfg cfg n var_map locals return_exp (stmt::acc)
+
+ | Msg _ -> stmts_of_cfg cfg n var_map locals return_exp acc
+ | Loop (_,s,g) ->
+ let g = Graph.from_shape (fun _ v -> v) g in
+ let is_while =
+ match Graph.succs s g, Graph.succs n cfg with
+ | [{ edge_dst = n1'; edge_trans = Assume(_,exp1,b1) }],
+ [{ edge_dst = n2'; edge_trans = Assume(_,exp2,b2) }]
+ when ExpStructEq.equal exp1 exp2 && b1 != b2 ->
+ Some (exp1, n1', b1, n2')
+ | _ -> None in
+ match is_while with
+ | None -> Value_parameters.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
+ let body = stmts_of_cfg g nloop var_map locals None [] in
+ let acc = (List.rev (Cil.mkLoop ?sattr:None ~guard:exp ~body)) @ acc in
+ stmts_of_cfg cfg n2 var_map locals return_exp acc
+ end
+ | l ->
+ let is_if = match l with
+ | [] | [_] -> assert false (* absurd *)
+ | [{ edge_dst = n1'; edge_trans = Assume(_,exp1,b1) } ;
+ { edge_dst = n2'; edge_trans = Assume(_,exp2,b2) }]
+ when ExpStructEq.equal exp1 exp2 && b1 != b2 ->
+ if b1 then Some (exp1, n1', n2') else Some (exp1,n2',n1')
+ | _ -> None in
+ let stmt =
+ match is_if with
+ | None -> Value_parameters.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
+ let block2 = Cil.mkBlock (stmts_of_cfg cfg n2 var_map locals return_exp []) in
+ Cil.mkStmt ~valid_sid (Cil_types.If(exp,block1,block2,dummy_loc)) in
+ List.rev (stmt::acc)
+
+let project_of_cfg vreturn s =
+ let main = Kernel_function.get_vi (fst (Globals.entry_point ())) in
+
+ let visit project =
+ let visitor =
+ object (self)
+ inherit Visitor.frama_c_copy project
+ method! vglob_aux global =
+ match global with
+ | Cil_types.GFun(fundec,_) when Varinfo.equal fundec.svar main ->
+ Cil.DoChildren
+ | Cil_types.GFun _ -> Cil.ChangeTo([])
+ | _ -> Cil.JustCopy
+ method! vfunc fundec =
+ if Varinfo.equal (Visitor_behavior.Get_orig.varinfo self#behavior fundec.Cil_types.svar) main then begin
+ (** copy of the fundec structure has already been done *)
+ fundec.slocals <- [];
+ let var_map = Varinfo.Map.empty in
+ let return_stmt, return_equal, blocals = match vreturn with
+ | None -> Cil.mkStmt ~valid_sid (Cil_types.Return(None,dummy_loc)), None, []
+ | Some exp ->
+ let var = Cil.makeVarinfo false false "__traces_domain_return" (Cil.typeOf exp) in
+ Cil.mkStmt ~valid_sid (Cil_types.Return(Some (Cil.evar var),dummy_loc)),
+ Some (var,exp), [var]
+ 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
+ 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;
+ fundec.sbody <- sbody;
+ fundec.slocals <- blocals @ !locals @ fundec.slocals;
+ Cil.setMaxId fundec;
+ let fundec = {fundec with sbody} in
+ Cil.ChangeDoChildrenPost(fundec,(fun x -> x))
+ end
+ else
+ Cil.JustCopy
+ end
+ in
+ visitor
+ in
+
+ let _project = Frama_c_File.create_project_from_visitor "Eva.Traces_domain" visit in
+ ()
+(* let selection = *)
+(* State_selection.diff *)
+(* State_selection.full *)
+(* (State_selection.list_union *)
+(* (List.map State_selection.with_dependencies *)
+(* [Cil.Builtin_functions.self; *)
+(* Ast.self; *)
+(* Frama_c_File.files_pre_register_state])) *)
+(* in *)
+(* let project = Project.create_by_copy ~selection ~last:true "Eva.Traces_domain" in *)
+(* let fundecls = *)
+(* let l = ref [] in *)
+(* Globals.Functions.iter (fun kf -> *)
+(* if not (Kernel_function.is_definition kf) then *)
+(* l := (kf.Cil_types.spec, Kernel_function.get_vi kf)::!l *)
+(* ); *)
+(* !l in *)
+(* Project.on project (fun () -> *)
+
+(* let var_map = Varinfo.Map.empty in *)
+(* let var_map = List.fold_left fresh_varinfo var_map s.globals in *)
+(* let var_map = List.fold_left fresh_varinfo var_map s.main_formals in *)
+(* let fundecls, var_map = List.fold_left (fun (fundecls,var_map) (funspec,v) -> *)
+(* let fundecl = Cil_types.GFunDecl(funspec,v,dummy_loc) in *)
+(* let behavior,visitor = subst_in_full var_map in *)
+(* let fundecl = Cil.visitCilGlobal visitor fundecl in *)
+(* let v' = Cil.get_varinfo behavior v in *)
+(* (fundecl @ fundecls), Varinfo.Map.add v v' var_map *)
+(* (\* (fundecl :: fundecls, var_map) *\) *)
+(* ) ([],var_map) fundecls in *)
+(* let globals = [] in *)
+(* (\** main function *\) *)
+(* let var_map = fresh_varinfo var_map main in *)
+(* let main = subst_in_varinfo var_map main in *)
+(* let fundec = Cil.emptyFunctionFromVI main in *)
+(* fundec.Cil_types.sformals <- List.map (subst_in_varinfo var_map) s.main_formals; *)
+(* let stmts = Cil.mkBlock (stmts_of_cfg s.graph s.start var_map vreturn []) in *)
+(* fundec.Cil_types.sbody <- stmts; *)
+(* let globals = Cil_types.GFun(fundec,dummy_loc) :: globals in *)
+(* (\* declared functions *\) *)
+(* let globals = fundecls @ globals in *)
+(* (\* globals *\) *)
+(* let globals = (List.map (fun v -> Cil_types.GVarDecl(subst_in_varinfo var_map v,dummy_loc)) s.globals) @ globals in *)
+(* let file = { Cil_types.fileName = "Traces_domain"; *)
+(* globals; *)
+(* globinit = None; *)
+(* globinitcalled = false; } in *)
+(* Globals.set_entry_point (main.Cil_types.vname) false; *)
+(* Format.printf "@[<2>@[file1:@] %a@]@." Printer.pp_file file; *)
+(* (\* let file = Cil.visitCilFileCopy (new Cil.genericCilVisitor (Cil.refresh_visit project)) file in *\) *)
+(* Format.printf "@[<2>@[file2:@] %a@]@." Printer.pp_file file; *)
+(* Ast.set_file file; *)
+(* Format.printf "@[<2>@[file3:@] %a@]@." Printer.pp_file file; *)
+(* ) () *)
+
+
+let output_dot filename state =
+ let out = open_out filename in
+ Value_parameters.feedback ~dkey:Internal.log_category "@[Output dot produced to %s.@]" filename;
+ (** *)
+ GraphDot.output_graph out (complete_graph (snd (Traces.get_current state)));
+ close_out out
+
+module D = struct
+ include Domain_builder.Complete (Internal)
+
+ let post_analysis state =
+ let return_stmt = Kernel_function.find_return (fst (Globals.entry_point ())) in
+ let return_exp = match return_stmt.Cil_types.skind with
+ | Cil_types.Return (oexp,_) -> oexp
+ | _ -> assert false in
+ let header fmt = Format.fprintf fmt "Trace domains:" in
+ let body = Bottom.pretty Traces.pretty in
+ Value_parameters.printf ~dkey:Internal.log_category ~header " @[%a@]" body state;
+ if Value_parameters.TracesProject.get () ||
+ not (Value_parameters.TracesDot.is_default ()) then
+ match state with
+ | `Bottom ->
+ Value_parameters.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"
+ | `Value state ->
+ if not (Value_parameters.TracesDot.is_default ())
+ then output_dot (Value_parameters.TracesDot.get ()) state;
+ if Value_parameters.TracesProject.get ()
+ then project_of_cfg return_exp state
+end
+
+
+(*
+Local Variables:
+compile-command: "make -C ../../.."
+End:
+*)
diff --git a/src/plugins/value/domains/traces_domain.mli b/src/plugins/value/domains/traces_domain.mli
new file mode 100644
index 0000000000000000000000000000000000000000..a1c57a5359d505bcb8ba41a06b9ab4d7003f649f
--- /dev/null
+++ b/src/plugins/value/domains/traces_domain.mli
@@ -0,0 +1,77 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(** Traces domain *)
+open Cil_types
+
+module Node : Datatype.S
+
+module GraphShape : sig type 'value t end
+
+type node = Node.t
+
+type transition =
+ | Assign of kinstr * lval * typ * exp
+ | Assume of stmt * exp * bool
+ | EnterScope of kernel_function * varinfo list
+ | LeaveScope of kernel_function * varinfo list
+ (** For call of functions without definition *)
+ | CallDeclared of kernel_function * exp list * lval option
+ | Loop of stmt * node (** start *) * edge list GraphShape.t
+ | Msg of string
+
+and edge = {
+ edge_trans : transition;
+ edge_dst : node;
+}
+
+module Edge : Datatype.S with type t = edge
+
+module Graph : sig
+ include Hptmap_sig.S with type key = Node.t
+ and type v = edge list
+ and type 'a shape = 'a GraphShape.t
+
+ val join : t -> t -> t
+end
+
+(** stack of open loops *)
+type loops =
+ | Base of Node.t * Graph.t (* current last *)
+ | OpenLoop of Cil_types.stmt * Node.t (* start node *) * Graph.t (* last iteration *) * Node.t (** current *) * Graph.t * loops
+ | UnrollLoop of Cil_types.stmt * loops
+
+module Loops : sig
+ type t = loops
+end
+
+type state
+
+val start: state -> Node.t
+val current: state -> loops
+val globals: state -> Cil_types.varinfo list
+val entry_formals: state -> Cil_types.varinfo list
+
+module D: Abstract_domain.Leaf
+ with type value = Cvalue.V.t
+ and type location = Precise_locs.precise_location
+ and type state = state
diff --git a/src/plugins/value/domains/unit_domain.ml b/src/plugins/value/domains/unit_domain.ml
index 4bb14526c7b277ba0348fd36954e862c6d997ab4..e78644f8c489b4125db88289516e89dec38bc0f3 100644
--- a/src/plugins/value/domains/unit_domain.ml
+++ b/src/plugins/value/domains/unit_domain.ml
@@ -28,8 +28,8 @@ module Static = struct
type state = t
let name = "Unit domain"
- let structure = Abstract_domain.Void
let log_category = log_key
+ let structure = Abstract.Domain.Unit
let top = ()
let is_included _ _ = true
diff --git a/src/plugins/value/domains/unit_domain.mli b/src/plugins/value/domains/unit_domain.mli
index 03a18359466383b2b457973f30e5d872e498228f..e1ed4495741e0e69942ef91292998f274f08b9c9 100644
--- a/src/plugins/value/domains/unit_domain.mli
+++ b/src/plugins/value/domains/unit_domain.mli
@@ -23,7 +23,7 @@
module Make
(Value: Abstract_value.S)
(Loc: Abstract_location.S)
- : Abstract_domain.Internal with type state = unit
+ : Abstract.Domain.Internal with type state = unit
and type value = Value.t
and type location = Loc.location
diff --git a/src/plugins/value/engine/abstractions.ml b/src/plugins/value/engine/abstractions.ml
index 2d68429dc36fafde3a69ae79f5bed2ffcbd5cc77..5781d60bf7672faf0129790ab98f89cde419dd68 100644
--- a/src/plugins/value/engine/abstractions.ml
+++ b/src/plugins/value/engine/abstractions.ml
@@ -20,568 +20,424 @@
(* *)
(**************************************************************************)
-(* Configuration of the abstract domain. *)
-
-type config = {
- cvalue : bool;
- equalities : bool;
- symbolic_locs : bool;
- bitwise : bool;
- gauges : bool;
- apron_oct : bool;
- apron_box : bool;
- polka_loose : bool;
- polka_strict : bool;
- polka_equalities : bool;
- inout: bool;
- signs: bool;
- printer: bool;
- numerors: bool;
-}
-
-let configure () = {
- cvalue = Value_parameters.CvalueDomain.get ();
- equalities = Value_parameters.EqualityDomain.get ();
- symbolic_locs = Value_parameters.SymbolicLocsDomain.get ();
- bitwise = Value_parameters.BitwiseOffsmDomain.get ();
- gauges = Value_parameters.GaugesDomain.get ();
- apron_oct = Value_parameters.ApronOctagon.get ();
- apron_box = Value_parameters.ApronBox.get ();
- polka_loose = Value_parameters.PolkaLoose.get ();
- polka_strict = Value_parameters.PolkaStrict.get ();
- polka_equalities = Value_parameters.PolkaEqualities.get ();
- inout = Value_parameters.InoutDomain.get ();
- signs = Value_parameters.SignDomain.get ();
- printer = Value_parameters.PrinterDomain.get ();
- numerors = Value_parameters.NumerorsDomain.get ();
-}
-
-let default_config = configure ()
-
-let legacy_config = {
- cvalue = true;
- equalities = false;
- symbolic_locs = false;
- bitwise = false;
- gauges = false;
- apron_oct = false;
- apron_box = false;
- polka_loose = false;
- polka_strict = false;
- polka_equalities = false;
- inout = false;
- signs = false;
- printer = false;
- numerors = false;
-}
+(* --- Registration types --------------------------------------------------- *)
-module type Value = sig
- include Abstract_value.External
- val reduce : t -> t
+type 'v value =
+ | Single of (module Abstract_value.Leaf with type t = 'v)
+ | Struct of 'v Abstract.Value.structure
+
+type precise_loc = Precise_locs.precise_location
+
+module type leaf_domain = Abstract_domain.Leaf with type location = precise_loc
+
+module type domain_functor =
+ functor (Value: Abstract.Value.External) ->
+ (leaf_domain with type value = Value.t)
+
+type 'v domain =
+ | Domain: (module leaf_domain with type value = 'v) -> 'v domain
+ | Functor: (module domain_functor) -> _ domain
+
+type 'v abstraction =
+ { name: string;
+ priority: int;
+ values: 'v value;
+ domain: 'v domain; }
+
+(* --- Config and registration ---------------------------------------------- *)
+
+module Config = struct
+ type flag = Flag: 'v abstraction -> flag
+
+ module Flag = struct
+ type t = flag
+
+ (* Flags are sorted by increasing priority order, and then by name. *)
+ let compare (Flag f1) (Flag f2) =
+ let c = Datatype.Int.compare f1.priority f2.priority in
+ if c <> 0 then c else Datatype.String.compare f1.name f2.name
+ end
+
+ include Set.Make (Flag)
+
+ type dynamic = Dynamic: (unit -> 'a option) * ('a -> 'v abstraction) -> dynamic
+
+ let abstractions = ref []
+ let dynamic_abstractions : dynamic list ref = ref []
+
+ let register ~enable abstraction =
+ abstractions := (enable, Flag abstraction) :: !abstractions
+
+ let dynamic_register ~configure ~make =
+ dynamic_abstractions := Dynamic (configure, make) :: !dynamic_abstractions
+
+ let configure () =
+ let aux config (enable, flag) =
+ if enable () then add flag config else config
+ in
+ let config = List.fold_left aux empty !abstractions in
+ let aux config (Dynamic (configure, make)) =
+ match configure () with
+ | None -> config
+ | Some c -> add (Flag (make c)) config
+ in
+ List.fold_left aux config !dynamic_abstractions
+
+ (* --- Register default abstractions -------------------------------------- *)
+
+ let create ~enable abstract = register ~enable abstract; Flag abstract
+ let create_domain priority name enable values domain =
+ create ~enable
+ { name; priority; values = Single values; domain = Domain domain }
+
+ open Value_parameters
+
+ (* Register standard domains over cvalues. *)
+ let make rank name enable =
+ create_domain rank name enable (module Main_values.CVal)
+
+ let cvalue = make 9 "cvalue" CvalueDomain.get (module Cvalue_domain.State)
+ let gauges = make 6 "gauges" GaugesDomain.get (module Gauges_domain.D)
+ let inout = make 5 "inout" InoutDomain.get (module Inout_domain.D)
+ let traces = make 2 "traces" TracesDomain.get (module Traces_domain.D)
+ let printer = make 2 "printer" PrinterDomain.get (module Printer_domain)
+ let symbolic_locations =
+ make 7 "symbolic_locations" SymbolicLocsDomain.get (module Symbolic_locs.D)
+
+ let sign =
+ create_domain 4 "sign" SignDomain.get
+ (module Sign_value) (module Sign_domain)
+
+ let bitwise =
+ create_domain 3 "bitwise" BitwiseOffsmDomain.get
+ (module Offsm_value.Offsm) (module Offsm_domain.D)
+
+ let equality_domain =
+ { name = "equality";
+ priority = 8;
+ values = Struct Abstract.Value.Unit;
+ domain = Functor (module Equality_domain.Make); }
+ let equality = create ~enable:EqualityDomain.get equality_domain
+
+ (* --- Default and legacy configurations ---------------------------------- *)
+
+ let default = configure ()
+ let legacy = singleton cvalue
end
-module type S = sig
- module Val : Value
- module Loc : Abstract_location.External with type value = Val.t
- module Dom : Abstract_domain.External with type value = Val.t
- and type location = Loc.location
+let register = Config.register
+let dynamic_register = Config.dynamic_register
+
+(* --- Building value abstractions ------------------------------------------ *)
+
+module Leaf_Value (V: Abstract_value.Leaf) = struct
+ include V
+ let structure = Abstract.Value.Leaf (V.key, (module V))
end
-module type Eva = sig
- include S
- module Eval: Evaluation.S with type state = Dom.t
- and type value = Val.t
- and type loc = Loc.location
- and type origin = Dom.origin
+module Leaf_Location (Loc: Abstract_location.Leaf) = struct
+ include Loc
+ let structure = Abstract.Location.Leaf (Loc.key, (module Loc))
end
-(* -------------------------------------------------------------------------- *)
-(* Value Abstraction *)
-(* -------------------------------------------------------------------------- *)
+module Leaf_Domain (D: Abstract_domain.Leaf) = struct
+ include D
+ let structure = Abstract.Domain.Leaf (D.key, (module D))
+end
-module type V = sig
- include Abstract_value.External
- val structure : t Abstract_value.structure
+module type Acc = sig
+ module Val : Abstract.Value.External
+ module Loc : Abstract.Location.Internal with type value = Val.t
+ and type location = precise_loc
+ module Dom : Abstract.Domain.Internal with type value = Val.t
+ and type location = Loc.location
end
-module CVal = struct
- include Main_values.CVal
- include Structure.Open (Structure.Key_Value) (Main_values.CVal)
+module Internal_Value = struct
+ open Abstract.Value
+
+ type value_key_module = V : 'v key * 'v data -> value_key_module
+
+ let open_value_abstraction (module Value : Internal) =
+ (module struct
+ include Value
+ include Structure.Open (Abstract.Value) (Value)
+ end : Abstract.Value.External)
+
+ let add_value_leaf value (V (key, v)) =
+ let module Value = (val open_value_abstraction value) in
+ if Value.mem key then value else
+ (module struct
+ include Value_product.Make (Value) (val v)
+ let structure = Node (Value.structure, Leaf (key, v))
+ end)
+
+ let add_value_structure value internal =
+ let rec aux: type v. (module Internal) -> v structure -> (module Internal) =
+ fun value -> function
+ | Leaf (key, v) -> add_value_leaf value (V (key, v))
+ | Node (s1, s2) -> aux (aux value s1) s2
+ | Unit -> value
+ in
+ aux value internal
+
+ let build_values config initial_value =
+ let build (Config.Flag abstraction) acc =
+ match abstraction.values with
+ | Struct structure -> add_value_structure acc structure
+ | Single (module V) -> add_value_leaf acc (V (V.key, (module V)))
+ in
+ let value = Config.fold build config initial_value in
+ open_value_abstraction value
+
+
+ module Convert
+ (Value: Abstract.Value.External)
+ (Struct: sig type v val s : v value end)
+ = struct
+
+ let structure = match Struct.s with
+ | Single (module V) -> Abstract.Value.Leaf (V.key, (module V))
+ | Struct s -> s
+
+ type extended_value = Value.t
+
+ let replace_val =
+ let rec set: type v. v structure -> v -> Value.t -> Value.t =
+ function
+ | Leaf (key, _) -> Value.set key
+ | Node (s1, s2) ->
+ let set1 = set s1 and set2 = set s2 in
+ fun (v1, v2) value -> set1 v1 (set2 v2 value)
+ | Unit -> fun () value -> value
+ in
+ set structure
+
+ let extend_val v = replace_val v Value.top
+
+ let restrict_val =
+ let rec get: type v. v structure -> Value.t -> v = function
+ | Leaf (key, _) -> Extlib.the (Value.get key)
+ | Node (s1, s2) ->
+ let get1 = get s1 and get2 = get s2 in
+ fun v -> get1 v, get2 v
+ | Unit -> fun _ -> ()
+ in
+ get structure
+
+ type extended_location = Main_locations.PLoc.location
+
+ let restrict_loc = fun x -> x
+ let extend_loc = fun x -> x
+ end
end
-let has_apron config =
- config.apron_oct || config.apron_box || config.polka_equalities
- || config.polka_loose || config.polka_strict
-
-(* The apron domains relies on a specific interval abstraction to communicate
- with other domains. This function adds the intervals to the current [value]
- abstraction. These intervals carry the same information as the cvalue
- abstractions (if they are enabled). Do not display the intervals in the GUI
- in this case. *)
-let add_apron_value config value =
- let module Left = ((val value: Abstract_value.Internal)) in
- let module V = struct
- include Value_product.Make (Left) (Main_values.Interval)
- let pretty_typ =
- if config.cvalue
- then fun fmt typ (left, _right) -> Left.pretty_typ fmt typ left
- else pretty_typ
- end in
- (module V: Abstract_value.Internal)
-
-let open_value_abstraction value =
- let module Value = (val value : Abstract_value.Internal) in
- (module struct
- include Value
- include Structure.Open (Structure.Key_Value) (Value)
- end : V)
-
-let build_value config =
- let value =
- if config.bitwise
- then (module Offsm_value.CvalueOffsm : Abstract_value.Internal)
- else (module Main_values.CVal : Abstract_value.Internal)
- in
- let value =
- if config.signs
- then
- let module V = Value_product.Make ((val value)) (Sign_value) in
- (module V: Abstract_value.Internal)
- else value
- in
- let value =
- if config.numerors
- then Numerors_domain.add_numerors_value value
- else value
+(* --- Building domain abstractions ----------------------------------------- *)
+
+module type internal_loc =
+ Abstract.Location.Internal with type location = precise_loc
+module type internal_domain =
+ Abstract.Domain.Internal with type location = precise_loc
+
+let eq_value:
+ type a b. a Abstract.Value.structure -> b value -> (a,b) Structure.eq option
+ = fun structure -> function
+ | Struct s -> Abstract.Value.eq_structure structure s
+ | Single (module V) ->
+ match structure with
+ | Abstract.Value.Leaf (key, _) -> Abstract.Value.eq_type key V.key
+ | _ -> None
+
+let add_domain (type v) (abstraction: v abstraction) (module Acc: Acc) =
+ let domain : (module internal_domain with type value = Acc.Val.t) =
+ match abstraction.domain with
+ | Functor make ->
+ let module Make = (val make: domain_functor) in
+ (module Leaf_Domain (Make (Acc.Val)))
+ | Domain domain ->
+ match eq_value Acc.Val.structure abstraction.values with
+ | Some Structure.Eq ->
+ let module Domain = (val domain) in
+ (module Leaf_Domain (Domain))
+ | None ->
+ let module Domain = (val domain : leaf_domain with type value = v) in
+ let module Struct = struct
+ type v = Domain.value
+ let s = abstraction.values
+ end in
+ let module Convert = Internal_Value.Convert (Acc.Val) (Struct) in
+ (module Domain_lift.Make (Domain) (Convert))
in
- let value =
- if has_apron config
- then add_apron_value config value
- else value
+ let domain : (module internal_domain with type value = Acc.Val.t) =
+ match Abstract.Domain.(eq_structure Acc.Dom.structure Unit) with
+ | Some _ -> domain
+ | None ->
+ (* The new [domain] becomes the left leaf of the domain product, and will
+ be processed before the domains from [Acc.Dom] during the analysis. *)
+ (module Domain_product.Make (Acc.Val) ((val domain)) (Acc.Dom))
in
- open_value_abstraction value
-
-(* Builds a module conversion from a generic external value to a key. *)
-module Convert
- (Value : Abstract_value.External)
- (K : sig type v val key : v Abstract_value.key end)
-= struct
- type extended_value = Value.t
- type extended_location = Main_locations.PLoc.location
+ (module struct
+ module Val = Acc.Val
+ module Loc = Acc.Loc
+ module Dom = (val domain)
+ end : Acc)
- let extend_val =
- let set = Value.set K.key in
- fun v -> set v Value.top
+let build_domain config abstract =
+ let build (Config.Flag abstraction) acc = add_domain abstraction acc in
+ (* Domains in the [config] are sorted by increasing priority: domains with
+ higher priority are added last: they will be at the top of the domains
+ tree, and thus will be processed first during the analysis. *)
+ Config.fold build config abstract
- let replace_val = Value.set K.key
- let restrict_val = match Value.get K.key with
- | None -> assert false
- | Some get -> get
+(* --- Value reduced product ----------------------------------------------- *)
- let restrict_loc = fun x -> x
- let extend_loc = fun x -> x
+module type Value = sig
+ include Abstract.Value.External
+ val reduce : t -> t
end
-
-(* -------------------------------------------------------------------------- *)
-(* Cvalue Domain *)
-(* -------------------------------------------------------------------------- *)
-
-(* Abstractions needed for the analysis: value, location and domain. *)
-module type Abstract = sig
- module Val : V
- module Loc : Abstract_location.Internal with type value = Val.t
- and type location = Precise_locs.precise_location
- module Dom : Abstract_domain.Internal with type value = Val.t
+module type S = sig
+ module Val : Value
+ module Loc : Abstract.Location.External with type value = Val.t
+ module Dom : Abstract.Domain.External with type value = Val.t
and type location = Loc.location
end
-let default_root_abstraction config =
- if config.cvalue
- then
- (module struct
- module Val = CVal
- module Loc = Main_locations.PLoc
- module Dom = Cvalue_domain.State
- end : Abstract)
- else
- (module struct
- module Val = CVal
- module Loc = Main_locations.PLoc
- module Dom = Unit_domain.Make (Val) (Loc)
- end : Abstract)
-
-let build_root_abstraction config value =
- let module Val = (val value : V) in
- let module K = struct
- type v = Cvalue.V.t
- let key = Main_values.cvalue_key
- end in
- let module Conv = Convert (Val) (K) in
- if config.cvalue
- then
- (module struct
- module Val = Val
- module Loc = Location_lift.Make (Main_locations.PLoc) (Conv)
- module Dom = Domain_lift.Make (Cvalue_domain.State) (Conv)
- end : Abstract)
- else
- (module struct
- module Val = Val
- module Loc = Location_lift.Make (Main_locations.PLoc) (Conv)
- module Dom = Unit_domain.Make (Val) (Loc)
- end : Abstract)
-
-
-(* -------------------------------------------------------------------------- *)
-(* Apron Domains *)
-(* -------------------------------------------------------------------------- *)
-
-let add_apron_domain abstract apron =
- let module Abstract = (val abstract: Abstract) in
- let module K = struct
- type v = Main_values.Interval.t
- let key = Main_values.interval_key
- end in
- let module Conv = Convert (Abstract.Val) (K) in
- let module Apron = Domain_lift.Make ((val apron : Apron_domain.S)) (Conv) in
- (module struct
- module Val = Abstract.Val
- module Loc = Abstract.Loc
- module Dom = Domain_product.Make (Abstract.Val) (Abstract.Dom) (Apron)
- end : Abstract)
+module type Eva = sig
+ include S
+ module Eval: Evaluation.S with type state = Dom.t
+ and type value = Val.t
+ and type loc = Loc.location
+ and type origin = Dom.origin
+end
-let dkey_experimental = Value_parameters.register_category "experimental-ok"
-let add_apron_domain abstractions apron =
- if not (Value_parameters.is_debug_key_enabled dkey_experimental) then
- Value_parameters.warning "The Apron domains binding is experimental.";
- if Apron_domain.ok
- then add_apron_domain abstractions apron
- else
- Value_parameters.abort
- "Apron domain requested but apron binding not available: analysis aborted."
+type ('a, 'b) value_reduced_product =
+ 'a Abstract.Value.key * 'b Abstract.Value.key * ('a -> 'b -> 'a * 'b)
+type v_reduced_product = R: ('a, 'b) value_reduced_product -> v_reduced_product
-(* -------------------------------------------------------------------------- *)
-(* Equality Domain *)
-(* -------------------------------------------------------------------------- *)
+let value_reduced_product = ref []
-module CvalueEquality = Equality_domain.Make (CVal)
+let register_value_reduction reduced_product =
+ value_reduced_product := (R reduced_product) :: !value_reduced_product
-let add_generic_equalities (module Abstract : Abstract) =
- let module EqDom = Equality_domain.Make (Abstract.Val) in
- let module Dom = Domain_product.Make (Abstract.Val) (Abstract.Dom) (EqDom) in
- (module struct
- module Val = Abstract.Val
- module Loc = Abstract.Loc
- module Dom = Dom
- end : Abstract)
-
-let add_equalities (type v) (module Abstract : Abstract with type Val.t = v) =
- match Abstract.Val.structure with
- | Structure.Key_Value.Leaf key ->
- begin
- match Structure.Key_Value.eq_type key Main_values.cvalue_key with
- | None -> add_generic_equalities (module Abstract)
- | Some Structure.Eq ->
- let module Dom =
- Domain_product.Make (Abstract.Val) (Abstract.Dom) (CvalueEquality)
- in
- (module struct
- module Val = Abstract.Val
- module Loc = Abstract.Loc
- module Dom = Dom
- end : Abstract)
+(* When the value abstraction contains both a cvalue and an interval
+ component (coming currently from an Apron domain), reduce them from each
+ other. If the Cvalue is not a scalar do nothing, because we do not
+ currently use Apron for pointer offsets. *)
+let reduce_apron_itv cvalue ival =
+ match ival with
+ | None -> begin
+ try cvalue, Some (Cvalue.V.project_ival cvalue)
+ with Cvalue.V.Not_based_on_null -> cvalue, ival
end
- | _ -> add_generic_equalities (module Abstract)
-
-
-(* -------------------------------------------------------------------------- *)
-(* Offsetmap Domain *)
-(* -------------------------------------------------------------------------- *)
-
-let add_offsm abstract =
- let module Abstract = (val abstract : Abstract) in
- let module K = struct
- type v = Offsm_value.offsm_or_top
- let key = Offsm_value.offsm_key
- end in
- let module Conv = Convert (Abstract.Val) (K) in
- let module Offsm = Domain_lift.Make (Offsm_domain.D) (Conv) in
- let module Dom = Domain_product.Make (Abstract.Val) (Abstract.Dom) (Offsm) in
- (module struct
- module Val = Abstract.Val
- module Loc = Abstract.Loc
- module Dom = Dom
- end : Abstract)
-
-(* -------------------------------------------------------------------------- *)
-(* Domains on standard locations and values *)
-(* -------------------------------------------------------------------------- *)
-
-module type Standard_abstraction = Abstract_domain.Internal
- with type value = Cvalue.V.t
- and type location = Precise_locs.precise_location
-
-let add_standard_domain d abstract =
- let module Abstract = (val abstract : Abstract) in
- let module K = struct
- type v = Cvalue.V.t
- let key = Main_values.cvalue_key
- end in
- let module Conv = Convert (Abstract.Val) (K) in
- let module D = (val d: Standard_abstraction) in
- let module LD = Domain_lift.Make (D) (Conv) in
- let module Dom = Domain_product.Make (Abstract.Val)(Abstract.Dom)(LD) in
- (module struct
- module Val = Abstract.Val
- module Loc = Abstract.Loc
- module Dom = Dom
- end : Abstract)
-
-(* List of abstractions registered by other plugins *)
-let dynamic_abstractions = ref []
-
-let add_dynamic_abstractions abstract =
- List.fold_left
- (fun d abstract -> add_standard_domain abstract d)
- abstract !dynamic_abstractions
-
-let register_dynamic_abstraction d =
- dynamic_abstractions := d :: !dynamic_abstractions
-
-(* --------------------------------------------------------------------------*)
-(* Symbolic locations *)
-(* --------------------------------------------------------------------------*)
-
-let add_symbolic_locs =
- add_standard_domain (module Symbolic_locs.D)
-
-(* -------------------------------------------------------------------------- *)
-(* Gauges *)
-(* -------------------------------------------------------------------------- *)
-
-let add_gauges =
- add_standard_domain (module Gauges_domain.D)
-
-(* -------------------------------------------------------------------------- *)
-(* Inout *)
-(* -------------------------------------------------------------------------- *)
-
-let add_inout =
- add_standard_domain (module Inout_domain.D)
-
-(* -------------------------------------------------------------------------- *)
-(* Sign Domain *)
-(* -------------------------------------------------------------------------- *)
-
-let add_signs abstract =
- let module Abstract = (val abstract : Abstract) in
- let module K = struct
- type v = Sign_value.t
- let key = Sign_value.sign_key
- end in
- let module Conv = Convert (Abstract.Val) (K) in
- let module Sign = Domain_lift.Make (Sign_domain) (Conv) in
- let module Dom = Domain_product.Make (Abstract.Val) (Abstract.Dom) (Sign) in
- (module struct
- module Val = Abstract.Val
- module Loc = Abstract.Loc
- module Dom = Dom
- end : Abstract)
-
-(* -------------------------------------------------------------------------- *)
-(* Numerors Domain *)
-(* -------------------------------------------------------------------------- *)
-
-let add_errors abstract =
- let module Abstract = (val abstract : Abstract) in
- let module K = struct
- type v = Numerors_domain.value
- let key = Numerors_domain.value_key
- end in
- let module Conv = Convert (Abstract.Val) (K) in
- let module Numerors = (val Numerors_domain.numerors_domain ()) in
- let module Errors = Domain_lift.Make (Numerors) (Conv) in
- let module Dom = Domain_product.Make (Abstract.Val) (Abstract.Dom) (Errors) in
- (module struct
- module Val = Abstract.Val
- module Loc = Abstract.Loc
- module Dom = Dom
- end : Abstract)
+ | Some ival ->
+ try
+ let ival' = Cvalue.V.project_ival cvalue in
+ (match ival' with
+ | Ival.Float _ -> raise Cvalue.V.Not_based_on_null
+ | _ -> ());
+ let reduced_ival = Ival.narrow ival ival' in
+ let cvalue = Cvalue.V.inject_ival reduced_ival in
+ cvalue, Some reduced_ival
+ with Cvalue.V.Not_based_on_null -> cvalue, Some ival
+
+let () =
+ register_value_reduction
+ (Main_values.CVal.key, Main_values.Interval.key, reduce_apron_itv)
+
+module Reduce (Value : Abstract.Value.External) = struct
+ include Value
-(* -------------------------------------------------------------------------- *)
-(* Printer *)
-(* -------------------------------------------------------------------------- *)
+ let make_reduction acc (R (key1, key2, f)) =
+ match Value.get key1, Value.get key2 with
+ | Some get1, Some get2 ->
+ let set1 = Value.set key1
+ and set2 = Value.set key2 in
+ let reduce v = let v1, v2 = f (get1 v) (get2 v) in set1 v1 (set2 v2 v) in
+ reduce :: acc
+ | _, _ -> acc
+
+ let reduce =
+ let list = List.fold_left make_reduction [] !value_reduced_product in
+ fun v -> List.fold_left (fun v reduce -> reduce v) v list
+end
-let add_printer =
- add_standard_domain (module Printer_domain)
+(* --- Final hook ----------------------------------------------------------- *)
-(* -------------------------------------------------------------------------- *)
-(* Build Abstractions *)
-(* -------------------------------------------------------------------------- *)
+let final_hooks = ref []
-let build_abstractions config =
- let value = build_value config in
- let module V = (val value : V) in
- let abstractions =
- match V.structure with
- | Structure.Key_Value.Leaf key
- when Structure.Key_Value.equal key Main_values.cvalue_key ->
- default_root_abstraction config
- | _ -> build_root_abstraction config value
- in
- let abstractions =
- if config.apron_oct
- then add_apron_domain abstractions (module Apron_domain.Octagon)
- else abstractions
- in
- let abstractions =
- if config.apron_box
- then add_apron_domain abstractions (module Apron_domain.Box)
- else abstractions
- in
- let abstractions =
- if config.polka_loose
- then add_apron_domain abstractions (module Apron_domain.Polka_Loose)
- else abstractions
- in
- let abstractions =
- if config.polka_strict
- then add_apron_domain abstractions (module Apron_domain.Polka_Strict)
- else abstractions
- in
- let abstractions =
- if config.polka_equalities
- then add_apron_domain abstractions (module Apron_domain.Polka_Equalities)
- else abstractions
- in
- let module A = (val abstractions : Abstract) in
- let abstractions =
- if config.equalities
- then add_equalities (module A)
- else abstractions
- in
- let abstractions =
- if config.symbolic_locs
- then add_symbolic_locs abstractions
- else abstractions
- in
- let abstractions =
- if config.bitwise
- then add_offsm abstractions
- else abstractions
- in
- let abstractions =
- if config.gauges
- then add_gauges abstractions
- else abstractions
- in
- let abstractions =
- if config.inout
- then add_inout abstractions
- else abstractions
- in
- let abstractions =
- if config.signs
- then add_signs abstractions
- else abstractions
- in
- let abstractions =
- if config.numerors
- then add_errors abstractions
- else abstractions
- in
- let abstractions =
- if config.printer
- then add_printer abstractions
- else abstractions
- in
- let abstractions = add_dynamic_abstractions abstractions in
- abstractions
+let register_hook f =
+ final_hooks := f :: !final_hooks
+let apply_final_hooks abstractions =
+ List.fold_left (fun acc f -> f acc) abstractions !final_hooks
-(* Add the reduce function to the value module. *)
-module Reduce (Value : Abstract_value.External) = struct
+(* --- Building abstractions ------------------------------------------------ *)
- include Value
+module Open (Acc: Acc) : S = struct
+ module Val = Reduce (Acc.Val)
+ module Loc = struct
+ include Acc.Loc
+ include Structure.Open (Abstract.Location)
+ (struct include Acc.Loc type t = location end)
+ end
+ module Dom = struct
+ include Acc.Dom
+ include Structure.Open (Abstract.Domain) (Acc.Dom)
+
+ let get_cvalue = match get Cvalue_domain.State.key with
+ | None -> None
+ | Some get -> Some (fun s -> fst (get s))
+
+ let get_cvalue_or_top = match get Cvalue_domain.State.key with
+ | None -> fun _ -> Cvalue.Model.top
+ | Some get -> fun s -> fst (get s)
- (* When the value abstraction contains both a cvalue and an interval
- component (coming currently from an Apron domain), reduce them from each
- other. If the Cvalue is not a scalar do nothing, because we do not
- currently use Apron for pointer offsets. *)
- let reduce_apron_itv =
- match Value.get Main_values.interval_key, Value.get Main_values.cvalue_key with
- | Some get_interval, Some get_cvalue ->
- begin
- let set_cvalue = Value.set Main_values.cvalue_key in
- let set_interval = Value.set Main_values.interval_key in
- fun t ->
- match get_interval t with
- | None -> begin
- let cvalue = get_cvalue t in
- try
- let ival = Cvalue.V.project_ival cvalue in
- set_interval (Some ival) t
- with Cvalue.V.Not_based_on_null -> t
- end
- | Some ival ->
- let cvalue = get_cvalue t in
- try
- let ival' = Cvalue.V.project_ival cvalue in
- (match ival' with
- | Ival.Float _ -> raise Cvalue.V.Not_based_on_null
- | _ -> ());
- let reduced_ival = Ival.narrow ival ival' in
- let cvalue = Cvalue.V.inject_ival reduced_ival in
- set_interval (Some reduced_ival) (set_cvalue cvalue t)
- with Cvalue.V.Not_based_on_null -> t
- end
- | _, _ -> fun x -> x
-
- let reduce_error = Numerors_domain.reduce_error (module Value)
-
- let reduce t = reduce_apron_itv (reduce_error t)
+ let get_cvalue_or_bottom = function
+ | `Bottom -> Cvalue.Model.bottom
+ | `Value state -> get_cvalue_or_top state
+ end
end
-let open_abstractions abstraction =
- let module Abstract = (val abstraction : Abstract) in
- let module Val = Reduce (Abstract.Val) in
- let module Loc = struct
- include Abstract.Loc
- include Structure.Open
- (Structure.Key_Location)
- (struct include Abstract.Loc type t = location end)
- end in
- let module Domain = struct
- include Abstract.Dom
- include Structure.Open (Structure.Key_Domain) (Abstract.Dom)
- end in
+module CVal = Leaf_Value (Main_values.CVal)
+
+let unit_acc (module Value: Abstract.Value.External) =
+ let loc : (module internal_loc with type value = Value.t) =
+ match Abstract.Value.eq_structure Value.structure CVal.structure with
+ | Some Structure.Eq -> (module Leaf_Location (Main_locations.PLoc))
+ | _ ->
+ let module Struct = struct
+ type v = Cvalue.V.t
+ let s = Single (module Main_values.CVal)
+ end in
+ let module Conv = Internal_Value.Convert (Value) (Struct) in
+ (module Location_lift.Make (Main_locations.PLoc) (Conv))
+ in
(module struct
- module Val = Val
- module Loc = Loc
- module Dom = Domain
- end : S)
+ module Val = Value
+ module Loc = (val loc)
+ module Dom = Unit_domain.Make (Val) (Loc)
+ end : Acc)
+
+let build_abstractions config =
+ let initial_value : (module Abstract.Value.Internal) =
+ if Config.mem Config.bitwise config
+ then (module Offsm_value.CvalueOffsm)
+ else (module CVal)
+ in
+ let value = Internal_Value.build_values config initial_value in
+ let acc = unit_acc value in
+ build_domain config acc
+let configure = Config.configure
let make config =
let abstractions = build_abstractions config in
- open_abstractions abstractions
-
-
-(* -------------------------------------------------------------------------- *)
-(* Default and Legacy Abstractions *)
-(* -------------------------------------------------------------------------- *)
-
-module Legacy = (val make legacy_config)
-module Default = (val make default_config)
-
-
+ let abstractions = (module Open (val abstractions): S) in
+ apply_final_hooks abstractions
-(*
-Local Variables:
-compile-command: "make -C ../../../.."
-End:
-*)
+module Default = (val make Config.default)
+module Legacy = (val make Config.legacy)
diff --git a/src/plugins/value/engine/abstractions.mli b/src/plugins/value/engine/abstractions.mli
index 9b3a1fb81ed87b230ae2828e5b6f8bf51e3233da..4c2909dbb757e52966e0dab66ec42e86473b87b2 100644
--- a/src/plugins/value/engine/abstractions.mli
+++ b/src/plugins/value/engine/abstractions.mli
@@ -20,54 +20,90 @@
(* *)
(**************************************************************************)
-(** Constructions of the abstractions used by Eva. *)
-
-(** Configuration of the abstract domain. *)
-type config = {
- cvalue : bool;
- equalities : bool;
- symbolic_locs : bool;
- bitwise : bool;
- gauges: bool;
- apron_oct : bool;
- apron_box : bool;
- polka_loose : bool;
- polka_strict : bool;
- polka_equalities : bool;
- inout: bool;
- signs: bool;
- printer: bool;
- numerors: bool;
-}
-
-(** Default configuration of Eva. *)
-val default_config : config
-
-(** Legacy configuration of Eva, with only the cvalue domain enabled.
- May be the default config as well. *)
-val legacy_config : config
-
-(** Build a configuration according to the analysis parameters. *)
-val configure : unit -> config
+(** Registration and building of the analysis abstractions. *)
+(** {2 Registration of abstractions.} *)
+(** Dynamic registration of the abstractions to be used in an Eva analysis:
+ - value abstractions, detailled in the {Abstract_value} signature;
+ - location abstractions, detailled in the {Abstract_location} signature;
+ - state abstractions, or abstract domains, detailled in {Abstract_domain}.
+*)
+
+(** Module types of value abstractions: either a single leaf module, or
+ a compound of several modules described by a structure. *)
+type 'v value =
+ | Single of (module Abstract_value.Leaf with type t = 'v)
+ | Struct of 'v Abstract.Value.structure
+
+(** For the moment, all domains must use [precise_loc] as their location
+ abstraction, and no new location abstraction can be registered for an
+ analysis.
+ If you need to build a new location abstraction, please contact us. *)
+type precise_loc = Precise_locs.precise_location
+
+(** Module type of a leaf domain over precise_loc abstraction. *)
+module type leaf_domain = Abstract_domain.Leaf with type location = precise_loc
+
+(** Module type of a functor building a leaf domain from a value abstraction.
+ The resulting domain must use the input value as value abstraction. *)
+module type domain_functor = functor
+ (Value: Abstract.Value.External) -> (leaf_domain with type value = Value.t)
+
+(** Type of domain to be registered: either a leaf module with ['v] as value
+ abstraction, or a functor building a domain from any value abstraction. *)
+type 'v domain =
+ | Domain: (module leaf_domain with type value = 'v) -> 'v domain
+ | Functor: (module domain_functor) -> _ domain
+
+(** Abstraction to be registered. The name of each abstraction must be unique.
+ The priority can be any integer; domains with higher priority are always
+ processed first. The domains currently provided by Eva have priority ranging
+ between 1 and 19, so a priority of 0 (respectively 20) ensures that a new
+ domain is processed after (respectively before) the classic Eva domains. *)
+type 'v abstraction =
+ { name: string; (** Name of the abstraction. Must be unique. *)
+ priority: int; (** Domains with higher priority are processed first. *)
+ values: 'v value; (** The value abstraction. *)
+ domain: 'v domain; (** The domain over the value abstraction. *)
+ }
+
+(** Register an abstraction. The abstraction is used in an Eva analysis only if
+ [enable ()] returns true at the start of the analysis. *)
+val register: enable:(unit -> bool) -> 'v abstraction -> unit
+
+(** Register a dynamic abstraction: the abstraction is built by applying
+ [make (configure ())] at the start of each analysis. *)
+val dynamic_register:
+ configure:(unit -> 'a option) -> make:('a -> 'v abstraction) -> unit
+
+(** Value reduced product between two value abstractions, identified by their
+ keys. *)
+type ('a, 'b) value_reduced_product =
+ 'a Abstract.Value.key * 'b Abstract.Value.key * ('a -> 'b -> 'a * 'b)
+
+(** Register a reduction function for a value reduced product. *)
+val register_value_reduction: ('a, 'b) value_reduced_product -> unit
+
+
+(** {2 Types used in the engine.} *)
+
+(** The external signature of value abstractions, plus the reduction function
+ of the reduced product. *)
module type Value = sig
- include Abstract_value.External
+ include Abstract.Value.External
val reduce : t -> t
end
-(** Types of the abstractions of the analysis: value, location and state
- abstractions.*)
+(** The three abstractions used in an Eva analysis. *)
module type S = sig
module Val : Value
- module Loc : Abstract_location.External with type value = Val.t
- module Dom : Abstract_domain.External with type value = Val.t
+ module Loc : Abstract.Location.External with type value = Val.t
+ module Dom : Abstract.Domain.External with type value = Val.t
and type location = Loc.location
end
-(** Module gathering:
- - the analysis abstractions: value, location and state abstractions;
- - the evaluation functions for these abstractions. *)
+(** The three abstractions plus an evaluation engine for these abstractions. *)
module type Eva = sig
include S
module Eval: Evaluation.S with type state = Dom.t
@@ -76,26 +112,45 @@ module type Eva = sig
and type origin = Dom.origin
end
-(** Type of abstractions that use the builtin types for values and locations *)
-module type Standard_abstraction = Abstract_domain.Internal
- with type value = Cvalue.V.t
- and type location = Precise_locs.precise_location
+(** Register a hook modifying the three abstractions after their building by
+ the engine, before the start of each analysis. *)
+val register_hook: ((module S) -> (module S)) -> unit
-val register_dynamic_abstraction: (module Standard_abstraction) -> unit
+(** {2 Configuration of an analysis.} *)
-(** Builds the abstractions according to a configuration. *)
-val make : config -> (module S)
+(** Configuration defining the abstractions to be used in an analysis. *)
+module Config : sig
+ (** Flag for an abstraction. *)
+ type flag = Flag: 'v abstraction -> flag
+ (** A configuration is a set of flags, i.e. a set of enabled abstractions. *)
+ include Set.S with type elt = flag
-(** Two abstractions are instantiated at compile time: default and legacy
- (which may be the same). *)
+ (** Flags for the standard domains currently provided in Eva. *)
-module Legacy : S
-module Default : S
+ val cvalue: flag
+ val equality: flag
+ val symbolic_locations: flag
+ val gauges: flag
+ val bitwise: flag
+ val inout: flag
+ val sign: flag
+ val traces: flag
+ val printer: flag
+ val default: t (** The default configuration of Eva. *)
+ val legacy: t (** The configuration corresponding to the old "Value" analysis,
+ with only the cvalue domain enabled. *)
+end
-(*
-Local Variables:
-compile-command: "make -C ../../../.."
-End:
-*)
+(** Creates the configuration according to the analysis parameters. *)
+val configure: unit -> Config.t
+
+(** Builds the abstractions according to a configuration. *)
+val make: Config.t -> (module S)
+
+(** Two abstractions are instantiated at compile time for the default and legacy
+ configurations (which may be the same). *)
+
+module Legacy : S
+module Default : S
diff --git a/src/plugins/value/engine/analysis.ml b/src/plugins/value/engine/analysis.ml
index 14728aa4d7eee27bada599f8273025a4b5c1925e..ee1b5680eeac44e2ad88489209edf6dbbb7fceb6 100644
--- a/src/plugins/value/engine/analysis.ml
+++ b/src/plugins/value/engine/analysis.ml
@@ -28,8 +28,8 @@ module type Results = sig
type value
type location
- val get_stmt_state : stmt -> state or_bottom
- val get_kinstr_state: kinstr -> 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_by_callstack:
@@ -67,15 +67,15 @@ module Make (Abstract: Abstractions.S) = struct
include Abstract
include Compute_functions.Make (Abstract)
- let get_stmt_state stmt =
+ 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 ()
- then Abstract.Dom.Store.get_stmt_state stmt
+ then Abstract.Dom.Store.get_stmt_state ~after stmt
else `Value Abstract.Dom.top
- let get_kinstr_state = function
+ let get_kinstr_state ~after = function
| Kglobal -> Abstract.Dom.Store.get_global_state ()
- | Kstmt stmt -> get_stmt_state stmt
+ | Kstmt stmt -> get_stmt_state ~after stmt
let get_stmt_state_by_callstack =
Abstract.Dom.Store.get_stmt_state_by_callstack
@@ -102,7 +102,7 @@ module Legacy = Make (Abstractions.Legacy)
module Default =
(val
- (if Abstractions.default_config = Abstractions.legacy_config
+ (if Abstractions.Config.(equal default legacy)
then (module Legacy)
else (module Make (Abstractions.Default)))
: Analyzer)
@@ -112,7 +112,7 @@ module Default =
the parameters of Eva regarding the abstractions used in the analysis) and
the current Analyzer module. *)
let ref_analyzer =
- ref (Abstractions.default_config, (module Default : Analyzer))
+ ref (Abstractions.Config.default, (module Default : Analyzer))
(* Returns the current Analyzer module. *)
let current_analyzer () = (module (val (snd !ref_analyzer)): S)
@@ -133,14 +133,14 @@ let set_current_analyzer config (analyzer: (module Analyzer)) =
let cvalue_initial_state () =
let module A = (val snd !ref_analyzer) in
let _, lib_entry = Globals.entry_point () in
- Cvalue_domain.extract A.Dom.get (A.initial_state ~lib_entry)
+ A.Dom.get_cvalue_or_bottom (A.initial_state ~lib_entry)
(* Builds the Analyzer module corresponding to a given configuration,
and sets it as the current analyzer. *)
let make_analyzer config =
let analyzer =
- if config = Abstractions.legacy_config then (module Legacy: Analyzer)
- else if config = Abstractions.default_config then (module Default)
+ if Abstractions.Config.(equal config legacy) then (module Legacy: Analyzer)
+ else if Abstractions.Config.(equal config default) then (module Default)
else
let module Abstract = (val Abstractions.make config) in
let module Analyzer = Make (Abstract) in
@@ -153,7 +153,7 @@ let reset_analyzer () =
let config = Abstractions.configure () in
(* If the configuration has not changed, do not reset the Analyzer but uses
the reference instead. *)
- if config <> fst !ref_analyzer
+ if not (Abstractions.Config.equal config (fst !ref_analyzer))
then make_analyzer config
(* Builds the analyzer if needed, and run the analysis. *)
diff --git a/src/plugins/value/engine/analysis.mli b/src/plugins/value/engine/analysis.mli
index 4ecfde378fd0c90f6ca56c0bb9c93909e95c18d6..89316e76c4cf49ddc2b26d495f46097f64517870 100644
--- a/src/plugins/value/engine/analysis.mli
+++ b/src/plugins/value/engine/analysis.mli
@@ -28,8 +28,8 @@ module type Results = sig
type value
type location
- val get_stmt_state : stmt -> state or_bottom
- val get_kinstr_state: kinstr -> 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_by_callstack:
diff --git a/src/plugins/value/engine/compute_functions.ml b/src/plugins/value/engine/compute_functions.ml
index d265352833e4dbbf7b2d88c7ed8483849670c57d..21a9876322a1e7dfe27fdc0a8c9d0dc8803ce778 100644
--- a/src/plugins/value/engine/compute_functions.ml
+++ b/src/plugins/value/engine/compute_functions.ml
@@ -148,18 +148,13 @@ module Make (Abstract: Abstractions.Eva) = struct
let initial_state = Init.initial_state
- let get_cvalue =
- match Abstract.Dom.get Cvalue_domain.key with
- | None -> fun _ -> Cvalue.Model.top
- | Some get -> fun state -> get state
-
let get_cval =
- match Abstract.Val.get Main_values.cvalue_key with
+ match Abstract.Val.get Main_values.CVal.key with
| None -> fun _ -> assert false
| Some get -> fun value -> get value
let get_ploc =
- match Abstract.Loc.get Main_locations.ploc_key with
+ match Abstract.Loc.get Main_locations.PLoc.key with
| None -> fun _ -> assert false
| Some get -> fun location -> get location
@@ -191,7 +186,7 @@ module Make (Abstract: Abstractions.Eva) = struct
then `Spec (Annotations.funspec kf)
else `Def def
in
- let cvalue_state = get_cvalue state in
+ let cvalue_state = Abstract.Dom.get_cvalue_or_top state in
let resulting_states, cacheable = match use_spec with
| `Spec spec ->
Db.Value.Call_Type_Value_Callbacks.apply
@@ -237,9 +232,9 @@ module Make (Abstract: Abstractions.Eva) = struct
in
call_result
| Some (states, i) ->
- let stack_with_call = Value_util.call_stack () in
- Db.Value.Call_Type_Value_Callbacks.apply
- (`Memexec, get_cvalue init_state, stack_with_call);
+ let stack = Value_util.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
@@ -300,7 +295,7 @@ module Make (Abstract: Abstractions.Eva) = struct
in
Locations.Location_Bytes.do_track_garbled_mix true;
let final_state = states >>- join_states in
- let cvalue_state = get_cvalue state in
+ let cvalue_state = Abstract.Dom.get_cvalue_or_top state in
match final_state with
| `Bottom ->
let cs = Value_util.call_stack () in
@@ -312,17 +307,16 @@ module Make (Abstract: Abstractions.Eva) = struct
let cvalue_states, cacheable =
Builtins.apply_builtin builtin cvalue_call cvalue_state
in
- let insert (cvalue_state, clobbered_set) =
- Abstract.Dom.set Locals_scoping.key clobbered_set
- (Abstract.Dom.set Cvalue_domain.key cvalue_state final_state)
+ let insert cvalue_state =
+ Abstract.Dom.set Cvalue_domain.State.key cvalue_state final_state
in
let states = Bottom.bot_of_list (List.map insert cvalue_states) in
Transfer.{states; cacheable; builtin=true}
let compute_call =
- if Abstract.Dom.mem Cvalue_domain.key
- && Abstract.Val.mem Main_values.cvalue_key
- && Abstract.Loc.mem Main_locations.ploc_key
+ if Abstract.Dom.mem Cvalue_domain.State.key
+ && Abstract.Val.mem Main_values.CVal.key
+ && Abstract.Loc.mem Main_locations.PLoc.key
then compute_call_or_builtin
else compute_and_cache_call
@@ -330,7 +324,7 @@ module Make (Abstract: Abstractions.Eva) = struct
let store_initial_state kf init_state =
Abstract.Dom.Store.register_initial_state (Value_util.call_stack ()) init_state;
- let cvalue_state = get_cvalue init_state in
+ 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 =
diff --git a/src/plugins/value/engine/evaluation.ml b/src/plugins/value/engine/evaluation.ml
index cc4018b105ace85d2ef41e338aede20e702b64bf..699f57b6e2443d8cbf912d37c306f30ddd3df2ba 100644
--- a/src/plugins/value/engine/evaluation.ml
+++ b/src/plugins/value/engine/evaluation.ml
@@ -52,8 +52,8 @@ open Eval
fuel than before, if needed. *)
(* Reductions may happen in the forward evaluation when:
- - a domain returns a value more precise than the one internally computed;
- - alarms are emitted by an operation on values. In particular, locations
+ – a domain returns a value more precise than the one internally computed;
+ – alarms are emitted by an operation on values. In particular, locations
are reduced to their valid part for a read or write operation.
These reductions are propagated to the sub-expressions by a backward
evaluation, after the forward evaluation has finished.
@@ -263,7 +263,7 @@ let indeterminate_copy lval result alarms =
module type Value = sig
- include Abstract_value.External
+ include Abstract.Value.External
val reduce : t -> t
end
diff --git a/src/plugins/value/engine/evaluation.mli b/src/plugins/value/engine/evaluation.mli
index ad8886669f22c25f17b0a08d404ba0c81efd8cec..b112178c2ac9cb2e021359f162731a2af1b9c2a3 100644
--- a/src/plugins/value/engine/evaluation.mli
+++ b/src/plugins/value/engine/evaluation.mli
@@ -46,6 +46,7 @@ module type S = sig
or `Value (valuation, value), where [value] is the numeric value computed
for the expression [expr], and [valuation] contains all the intermediate
results of the evaluation.
+
The [valuation] argument is a cache of already computed expressions.
It is empty by default.
The [reduction] argument allows deactivating the backward reduction
@@ -104,7 +105,7 @@ module type S = sig
end
module type Value = sig
- include Abstract_value.External
+ include Abstract.Value.External
(** Inter-reduction of values. Useful when the value module is a reduced
product of several abstraction.
diff --git a/src/plugins/value/engine/initialization.ml b/src/plugins/value/engine/initialization.ml
index 317446467c2dcd3b4e657f30019dc3407b098146..fd124a687b6a27f5c823130697fcad9ca2042a7a 100644
--- a/src/plugins/value/engine/initialization.ml
+++ b/src/plugins/value/engine/initialization.ml
@@ -80,7 +80,7 @@ let (>>>) t f = match t with
let counter = ref 0
module Make
- (Domain: Abstract_domain.External)
+ (Domain: Abstract.Domain.External)
(Eva: Evaluation.S with type state = Domain.state
and type loc = Domain.location)
(Transfer: Transfer_stmt.S with type state = Domain.t)
@@ -270,10 +270,9 @@ module Make
(* Use the values supplied in [actuals] for the formals of [kf], and
bind them in [state] *)
let add_supplied_main_formals kf actuals state =
- match Domain.get Cvalue_domain.key with
- | None ->
- Value_parameters.abort "Function Db.Value.fun_set_args cannot be used \
- without the Cvalue domain"
+ match Domain.get_cvalue with
+ | None -> Value_parameters.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
@@ -286,8 +285,8 @@ module Make
let cvalue_state =
List.fold_left2 add_actual cvalue_state actuals formals
in
- let set_domain = Domain.set Cvalue_domain.key in
- set_domain cvalue_state state
+ let set_domain = Domain.set Cvalue_domain.State.key in
+ set_domain (cvalue_state, Locals_scoping.bottom ()) state
let add_main_formals kf state =
match Db.Value.fun_get_args () with
@@ -354,7 +353,9 @@ module Make
let supplied_state () =
let cvalue_state = Db.Value.globals_state () in
if Cvalue.Model.is_reachable cvalue_state
- then `Value (Domain.set Cvalue_domain.key cvalue_state Domain.top)
+ then
+ let cvalue_state = cvalue_state, Locals_scoping.bottom () in
+ `Value (Domain.set Cvalue_domain.State.key cvalue_state Domain.top)
else `Bottom
let initial_state ~lib_entry =
@@ -363,7 +364,7 @@ module Make
else global_state ~lib_entry
let print_initial_cvalue_state state =
- let cvalue_state = Cvalue_domain.extract Domain.get state in
+ let cvalue_state = Domain.get_cvalue_or_bottom state in
(* Do not show variables from the frama-c libc specifications. *)
let print_base base =
try
diff --git a/src/plugins/value/engine/initialization.mli b/src/plugins/value/engine/initialization.mli
index d3bf03c164d12c1a524f8efffead3446eb2b17eb..f87a4799a8dabf85382536a3faf4beb8eb9deab9 100644
--- a/src/plugins/value/engine/initialization.mli
+++ b/src/plugins/value/engine/initialization.mli
@@ -44,7 +44,7 @@ module type S = sig
end
module Make
- (Domain: Abstract_domain.External)
+ (Domain: Abstract.Domain.External)
(Eva: Evaluation.S with type state = Domain.state
and type loc = Domain.location)
(Transfer: Transfer_stmt.S with type state = Domain.t)
diff --git a/src/plugins/value/engine/iterator.ml b/src/plugins/value/engine/iterator.ml
index 541d61dd21f62783f1efeb762824b51b4bb54b27..bae4fbcc7b35ec5ec246816cd8ab55f9f6bcfe47 100644
--- a/src/plugins/value/engine/iterator.ml
+++ b/src/plugins/value/engine/iterator.ml
@@ -433,9 +433,7 @@ module Make_Dataflow
edge_info.fireable <- true;
flow
- let get_cvalue = Domain.get Cvalue_domain.key
- let gather_cvalues states =
- match get_cvalue with
+ let gather_cvalues states = match Domain.get_cvalue with
| Some get -> List.map get states
| None -> []
@@ -633,9 +631,6 @@ module Make_Dataflow
G.iter_edges_e fill graph;
Db.Value.merge_conditions table
- let extract_cvalue (state : state) : 'a =
- Cvalue_domain.extract Domain.get (`Value state)
-
let is_instr s = match s.skind with Instr _ -> true | _ -> false
let states_after_stmt states_before states_after =
@@ -676,7 +671,7 @@ module Make_Dataflow
then VertexTable.memo merged_states v get_smashed_store
else `Bottom
and lift_to_cvalues table =
- StmtTable.map (fun _ s -> extract_cvalue s) (Lazy.force table)
+ StmtTable.map (fun _ s -> Domain.get_cvalue_or_top s) (Lazy.force table)
in
let merged_pre_states = lazy
(StmtTable.map' (fun s (v,_) -> get_merged_states ~all:true s v) automaton.stmt_table)
@@ -691,7 +686,7 @@ module Make_Dataflow
(StmtTable.map (fun _stmt (v,_) ->
let store = get_vertex_store v in
let states = Partition.expanded store in
- List.map (fun x -> extract_cvalue x) states)
+ List.map (fun x -> Domain.get_cvalue_or_top x) states)
automaton.stmt_table)
in
let merged_pre_cvalues = lazy (lift_to_cvalues merged_pre_states)
diff --git a/src/plugins/value/engine/mem_exec.ml b/src/plugins/value/engine/mem_exec.ml
index 85441fdeda5600eda20137d367788091b923b6e6..17adb02719337ef16ce67e9b106b1ac74647c4e8 100644
--- a/src/plugins/value/engine/mem_exec.ml
+++ b/src/plugins/value/engine/mem_exec.ml
@@ -148,7 +148,7 @@ module Make
if Base.Hptset.equal expanded_bases bases
then Base.SetLattice.inject expanded_bases
else if count <= 0 then Base.SetLattice.top
- else expand_inputs_with_relations (count - 1) kf new_bases state
+ else expand_inputs_with_relations (count - 1) kf expanded_bases state
let store_computed_call kf input_state args
(call_result: Domain.t list Bottom.or_bottom) =
diff --git a/src/plugins/value/engine/partition.ml b/src/plugins/value/engine/partition.ml
index 68686f72d14cc2cfa28af182e0714db28e980b5b..644e3bf20b5a617f34df40a686b12dadabab3bf4 100644
--- a/src/plugins/value/engine/partition.ml
+++ b/src/plugins/value/engine/partition.ml
@@ -245,7 +245,7 @@ struct
all states"
in
(* Get the cvalue *)
- let cvalue = match Abstract.Val.get Main_values.cvalue_key with
+ let cvalue = match Abstract.Val.get Main_values.CVal.key with
| Some get_cvalue -> get_cvalue value
| None -> fail ~exp "partitioning is disabled when the CValue domain is \
not active"
@@ -325,7 +325,7 @@ struct
(* --- Applying partitioning actions onto flows --------------------------- *)
- let stamp_by_value = match Abstract.Val.get Main_values.cvalue_key with
+ let stamp_by_value = match Abstract.Val.get Main_values.CVal.key with
| None -> fun _ _ _ -> None
| Some get -> fun expr expected_values state ->
let typ = Cil.typeOf expr in
diff --git a/src/plugins/value/engine/partition.mli b/src/plugins/value/engine/partition.mli
index 1a48bf6e154c36c54bd8cee64fba21cea2a7f1f7..2a5177c756849b8abeb1bebb32e939066a11374f 100644
--- a/src/plugins/value/engine/partition.mli
+++ b/src/plugins/value/engine/partition.mli
@@ -127,10 +127,10 @@ type action =
| Restrict of Cil_types.exp * Integer.t list
(** [Restrict (exp, list)] restricts the rationing according to the evaluation
of the expression [exp]:
- - for each integer [i] in [list], states in which [exp] evaluates exactly
+ – for each integer [i] in [list], states in which [exp] evaluates exactly
to the singleton [i] receive the same unique stamp, and will thus be
joined together but kept separate from other states;
- - all other states are joined together.
+ – all other states are joined together.
Previous rationing is erased and replaced by this new stamping.
Implementation of the option -eva-split-return. *)
| Split of Cil_types.exp * split_kind * split_monitor
diff --git a/src/plugins/value/engine/partitioning_index.ml b/src/plugins/value/engine/partitioning_index.ml
index 08a2f449cf02a90603131b2b7dca16623c10df5e..af4202973238a17d341109ddadd4f1ede3fe9319 100644
--- a/src/plugins/value/engine/partitioning_index.ml
+++ b/src/plugins/value/engine/partitioning_index.ml
@@ -23,7 +23,8 @@
module type Domain = sig
include Abstract_domain.Lattice
include Datatype.S_with_collections with type t = state
- include Abstract_domain.Interface with type t := state
+ include Abstract.Interface with type t := state
+ and type 'a key := 'a Abstract_domain.key
end
(** Partition of the abstract states, computed for each node by the
@@ -45,12 +46,12 @@ module Make
(* Optimizations relying on specific features of the cvalue domain. *)
- let distinct_subpart = match Domain.get Cvalue_domain.key with
+ let distinct_subpart = match Domain.get Cvalue_domain.State.key with
| None -> fun _ _ -> None
| Some get ->
fun s1 s2 -> Cvalue_domain.distinct_subpart (get s1) (get s2)
- let find_subpart = match Domain.get Cvalue_domain.key with
+ let find_subpart = match Domain.get Cvalue_domain.State.key with
| None -> fun _ _ -> None
| Some get ->
fun state prefix -> Cvalue_domain.find_subpart (get state) prefix
diff --git a/src/plugins/value/engine/partitioning_index.mli b/src/plugins/value/engine/partitioning_index.mli
index b4488a2eef755c6056994295834de7d54afba023..9a72e4b44bb7cde362196aebea23713899381e18 100644
--- a/src/plugins/value/engine/partitioning_index.mli
+++ b/src/plugins/value/engine/partitioning_index.mli
@@ -33,7 +33,8 @@
module type Domain = sig
include Abstract_domain.Lattice
include Datatype.S_with_collections with type t = state
- include Abstract_domain.Interface with type t := state
+ include Abstract.Interface with type t := state
+ and type 'a key := 'a Abstract_domain.key
end
module Make (Domain: Domain) : sig
diff --git a/src/plugins/value/engine/subdivided_evaluation.ml b/src/plugins/value/engine/subdivided_evaluation.ml
index ae1efe494c8c2dd823b6c5a7dd6b428795ecf024..965a8ca09342731b082c8da5f775ca3712178641 100644
--- a/src/plugins/value/engine/subdivided_evaluation.ml
+++ b/src/plugins/value/engine/subdivided_evaluation.ml
@@ -265,9 +265,9 @@ module Hypotheses = struct
let rec fold : type l. ('a -> 'b -> 'b) -> ('a, l) llist -> 'b -> 'b =
fun f list acc ->
- match list with
- | Nil -> acc
- | Cons (x, tl) -> fold f tl (f x acc)
+ match list with
+ | Nil -> acc
+ | Cons (x, tl) -> fold f tl (f x acc)
let rec fold2:
type l. ('a -> 'b -> 'c -> 'c) -> ('a, l) llist -> ('b, l) llist -> 'c -> 'c
@@ -298,19 +298,19 @@ module Hypotheses = struct
(* Pointwise comparison of two lists of subvalues. *)
let rec compare_subvalues: type l. l subvalues -> l subvalues -> int =
fun hyp1 hyp2 ->
- match hyp1, hyp2 with
- | Nil, Nil -> 0
- | Cons (v1, tail1), Cons (v2, tail2) ->
- let n = Cvalue.V.compare v1 v2 in
- if n = 0 then compare_subvalues tail1 tail2 else n
+ match hyp1, hyp2 with
+ | Nil, Nil -> 0
+ | Cons (v1, tail1), Cons (v2, tail2) ->
+ let n = Cvalue.V.compare v1 v2 in
+ if n = 0 then compare_subvalues tail1 tail2 else n
(* Pointwise join of two lists of subvalues. *)
let rec join_subvalues: type l. l subvalues -> l subvalues -> l subvalues =
fun l1 l2 ->
- match l1, l2 with
- | Nil, Nil -> Nil
- | Cons (x1, tl1), Cons (x2, tl2) ->
- Cons (Cvalue.V.join x1 x2, join_subvalues tl1 tl2)
+ match l1, l2 with
+ | Nil, Nil -> Nil
+ | Cons (x1, tl1), Cons (x2, tl2) ->
+ Cons (Cvalue.V.join x1 x2, join_subvalues tl1 tl2)
(* Extract the extremum of each subvalue of a list. Returns a list of lists
of values (one for each combination of extremum of the initial values). *)
@@ -368,7 +368,7 @@ module type Forward_Evaluation = sig
end
module Make
- (Value : Abstract_value.External)
+ (Value : Abstract.Value.External)
(Loc : Abstract_location.S with type value = Value.t)
(Valuation: Valuation with type value = Value.t
and type loc = Loc.location)
@@ -379,15 +379,15 @@ module Make
(* Values are converted to {!Cvalue.V.t}, because those are
currently the only values on which we can split. *)
- let get_cval = match Value.get Main_values.cvalue_key with
+ let get_cval = match Value.get Main_values.CVal.key with
| Some get -> get
| None -> fun _ -> Cvalue.V.top
let set_cval =
- let set = Value.set Main_values.cvalue_key in
+ let set = Value.set Main_values.CVal.key in
fun cval v -> set cval v
- let activated = Value.mem Main_values.cvalue_key
+ let activated = Value.mem Main_values.CVal.key
module Clear = Clear_Valuation (Valuation)
diff --git a/src/plugins/value/engine/subdivided_evaluation.mli b/src/plugins/value/engine/subdivided_evaluation.mli
index 745624c457517ac366c4f7734bd7960c9bb6d3d7..71d582bb70d8a4e1f6bda7d6d77b88051d08f994 100644
--- a/src/plugins/value/engine/subdivided_evaluation.mli
+++ b/src/plugins/value/engine/subdivided_evaluation.mli
@@ -36,7 +36,7 @@ module type Forward_Evaluation = sig
end
module Make
- (Value : Abstract_value.External)
+ (Value : Abstract.Value.External)
(Loc: Abstract_location.S with type value = Value.t)
(Valuation: Eval.Valuation with type value = Value.t
and type loc = Loc.location)
diff --git a/src/plugins/value/engine/transfer_specification.ml b/src/plugins/value/engine/transfer_specification.ml
index d5438b227de994181748fcdadfd7c43f3a49b05b..b3be9e6f908aa569bd360e6f002cde811ecc29a5 100644
--- a/src/plugins/value/engine/transfer_specification.ml
+++ b/src/plugins/value/engine/transfer_specification.ml
@@ -227,16 +227,13 @@ module Make
(* Extraction of the precise location and of the cvalue domain:
needed to evaluate the location of an assigns clause. *)
- let get_ploc = match Location.get Main_locations.ploc_key with
+ let get_ploc = match Location.get Main_locations.PLoc.key with
| None -> fun _ -> Main_locations.PLoc.top
| Some get -> get
- let set_ploc = Location.set Main_locations.ploc_key
+ let set_ploc = Location.set Main_locations.PLoc.key
let set_location loc = set_ploc (Main_locations.PLoc.make loc)
- let get_cvalue_state = match Domain.get Cvalue_domain.key with
- | None -> fun _ -> Cvalue.Model.top
- | Some get -> get
- let make_env state = Eval_terms.env_assigns (get_cvalue_state state)
+ let make_env state = Eval_terms.env_assigns (Domain.get_cvalue_or_top state)
let is_result = function
| Assigns (term, _)
@@ -299,7 +296,7 @@ module Make
end
in
let check_one_state state =
- let cvalue_state = get_cvalue_state state in
+ let cvalue_state = Domain.get_cvalue_or_top state in
List.iter (check_one_assign cvalue_state) assigns
in
States.iter check_one_state states
@@ -468,12 +465,12 @@ module Make
(* Sound over-approximations of the effects of a function can be computed
through its specification in three different ways:
- - the default behavior is always an over-approximation of the function
+ – the default behavior is always an over-approximation of the function
effects, but can be very imprecise. We use it only if the two other ways
are inapplicable (both are strictly more precise).
- - any behavior whose assumes clause is true in the current state is also a
+ – any behavior whose assumes clause is true in the current state is also a
sound approximation of the function effects applied to this state.
- - the union of any complete set of behaviors is an over-approximation of
+ – the union of any complete set of behaviors is an over-approximation of
the function effects.
To obtain the highest precision, the states resulting from the
interpretation of any true behavior and of any complete set should be
diff --git a/src/plugins/value/engine/transfer_stmt.ml b/src/plugins/value/engine/transfer_stmt.ml
index e7be6f8f5827d5e2172721c25c0a7529cc7e321a..24d5ca59ab6a103270a9c0a266cdc8499f7c24f6 100644
--- a/src/plugins/value/engine/transfer_stmt.ml
+++ b/src/plugins/value/engine/transfer_stmt.ml
@@ -318,7 +318,7 @@ module Make (Abstract: Abstractions.Eva) = struct
(* ------------------- Retro propagation on formals ----------------------- *)
- let get_precise_location = Location.get Main_locations.ploc_key
+ let get_precise_location = Location.get Main_locations.PLoc.key
(* [is_safe_argument valuation expr] is true iff the expression [expr] could
not have been written during the last call.
@@ -361,9 +361,9 @@ module Make (Abstract: Abstractions.Eva) = struct
(* At the end of a call, this function gathers the arguments whose value can
be reduced at the call site. These are the arguments such that:
- - the formal has not been written during the call, but its value has been
+ – the formal has not been written during the call, but its value has been
reduced;
- - no variable of the concrete argument has been written during the call
+ – no variable of the concrete argument has been written during the call
(thus the concrete argument is still equal to the formal).
[state] is the state at the return statement of the called function;
it is used to evaluate the formals; their values are then compared to the
@@ -559,10 +559,6 @@ module Make (Abstract: Abstractions.Eva) = struct
(* ----------------- show_each and dump_each directives ------------------- *)
- let extract_cvalue = match Domain.get Cvalue_domain.key with
- | None -> fun _ -> Cvalue.Model.top
- | Some get -> get
-
(* The product of domains formats the printing of each leaf domains, by
checking their log_category and adding their name before the dump. If the
domain is not a product, this needs to be done here. *)
@@ -609,7 +605,7 @@ module Make (Abstract: Abstractions.Eva) = struct
(* For non scalar expressions, prints the offsetmap of the cvalue domain. *)
let show_offsm =
- match Domain.get Cvalue_domain.key, Location.get Main_locations.ploc_key with
+ match Domain.get_cvalue, Location.get Main_locations.PLoc.key with
| None, _ | _, None ->
fun fmt _ _ -> Format.fprintf fmt "%s" (Unicode.top_string ())
| Some get_cvalue, Some get_ploc ->
@@ -621,9 +617,7 @@ module Make (Abstract: Abstractions.Eva) = struct
let offsm =
fst (Eval.lvaluate ~for_writing:false state lval)
>>- fun (_, loc, _) ->
- let ploc = get_ploc loc
- and cvalue_state = get_cvalue state in
- Eval_op.offsetmap_of_loc ploc cvalue_state
+ Eval_op.offsetmap_of_loc (get_ploc loc) (get_cvalue state)
in
let typ = Cil.typeOf expr in
(Bottom.pretty (Eval_op.pretty_offsetmap typ)) fmt offsm
@@ -634,7 +628,7 @@ module Make (Abstract: Abstractions.Eva) = struct
(* For scalar expressions, prints the cvalue component of their values. *)
let show_value =
- match Value.get Main_values.cvalue_key with
+ match Value.get Main_values.CVal.key with
| None -> fun fmt _ _ -> Format.fprintf fmt "%s" (Unicode.top_string ())
| Some get_cval ->
fun fmt expr state ->
@@ -707,7 +701,7 @@ module Make (Abstract: Abstractions.Eva) = struct
{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 cvalue_state = extract_cvalue state 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;
let result =
diff --git a/src/plugins/value/eval.mli b/src/plugins/value/eval.mli
index a00ef79939cf24710edc64b6b25d351f388e68ef..ce35bfe07f5ea405e13dd3ad98d6076aa8f89bf1 100644
--- a/src/plugins/value/eval.mli
+++ b/src/plugins/value/eval.mli
@@ -214,7 +214,9 @@ type ('loc, 'value) call = {
arguments: ('loc, 'value) argument list; (** The arguments of the call. *)
rest: (exp * ('loc, 'value) assigned) list; (** Extra-arguments. *)
return: varinfo option; (** Fake varinfo to store the
- return value of the call. *)
+ return value of the call.
+ Same varinfo for every
+ call to a given function. *)
recursive: bool;
}
diff --git a/src/plugins/value/gui_files/gui_eval.ml b/src/plugins/value/gui_files/gui_eval.ml
index 108079350d90481f0a0ec71c200f2a62b0d93443..8239f3974fe81a150ebdeaa53a488ec29935eb31 100644
--- a/src/plugins/value/gui_files/gui_eval.ml
+++ b/src/plugins/value/gui_files/gui_eval.ml
@@ -143,13 +143,8 @@ module Make (X: Analysis.S) = struct
module Analysis = X
- let get_cvalue_state =
- match X.Dom.get Cvalue_domain.key with
- | None -> fun _ -> Cvalue.Model.top
- | Some get -> fun state -> get state
-
let get_precise_loc =
- match X.Loc.get Main_locations.ploc_key with
+ match X.Loc.get Main_locations.PLoc.key with
| None -> fun _ -> Precise_locs.loc_top
| Some get -> fun loc -> get loc
@@ -210,7 +205,7 @@ module Make (X: Analysis.S) = struct
let lval_to_offsetmap state lv =
let loc, alarms = X.eval_lval_to_loc state lv in
let ok = Alarmset.is_empty alarms in
- let state = get_cvalue_state state in
+ let state = X.Dom.get_cvalue_or_top state in
let aux loc (acc_res, acc_ok) =
let res, ok =
match lv with (* catch simplest pattern *)
@@ -273,7 +268,7 @@ module Make (X: Analysis.S) = struct
}
let null_to_offsetmap state (_:unit) =
- let state = get_cvalue_state state in
+ let state = X.Dom.get_cvalue_or_top state in
match Cvalue.Model.find_base_or_default Base.null state with
| `Bottom -> GO_InvalidLoc, false, false
| `Top -> GO_Top, false, false
@@ -335,17 +330,17 @@ module Make (X: Analysis.S) = struct
let env_here kf here callstack =
let pre = pre_kf kf callstack in
- let here = get_cvalue_state here in
+ let here = X.Dom.get_cvalue_or_top here in
let c_labels = Eval_annots.c_labels kf callstack in
Eval_terms.env_annot ~c_labels ~pre ~here ()
let env_pre _kf here _callstack =
- let here = get_cvalue_state here in
+ let here = X.Dom.get_cvalue_or_top here in
Eval_terms.env_pre_f ~pre:here ()
let env_post kf post callstack =
let pre = pre_kf kf callstack in
- let post = get_cvalue_state post in
+ let post = X.Dom.get_cvalue_or_top post in
let result =
if !Db.Value.use_spec_instead_of_definition kf then
None
diff --git a/src/plugins/value/gui_files/gui_types.ml b/src/plugins/value/gui_files/gui_types.ml
index 683fa0398606aed22d2fafb21e85f26d2de82070..f4fad0001bcf153f14c432216195984d1da38804 100644
--- a/src/plugins/value/gui_files/gui_types.ml
+++ b/src/plugins/value/gui_files/gui_types.ml
@@ -167,8 +167,8 @@ module Make (V: Abstractions.Value) = struct
| GA_After r1, GA_After r2 -> equal_gui_res r1 r2
| (GA_After _ | GA_NA | GA_Unchanged | GA_Bottom), _ -> false
- let get_cvalue = V.get Main_values.cvalue_key
- let from_cvalue v = V.set Main_values.cvalue_key v V.top
+ let get_cvalue = V.get Main_values.CVal.key
+ let from_cvalue v = V.set Main_values.CVal.key v V.top
let var_of_base base acc =
try
diff --git a/src/plugins/value/gui_files/register_gui.ml b/src/plugins/value/gui_files/register_gui.ml
index d455fab0fdc74a67016f135cf4e9ccbb67be4738..7892476419f1a383686204648a6668674b6dbd21 100644
--- a/src/plugins/value/gui_files/register_gui.ml
+++ b/src/plugins/value/gui_files/register_gui.ml
@@ -519,7 +519,7 @@ module Select (Eval: Eval) = struct
(* 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 ki with
+ match Eval.Analysis.get_kinstr_state ~after:false ki with
| `Bottom -> ()
| `Value state ->
let funs, _ = Eval.Analysis.eval_function_exp state e in
diff --git a/src/plugins/value/legacy/eval_op.ml b/src/plugins/value/legacy/eval_op.ml
index 207409c22900ce3e4105492ac3a6af47da41b382..03b3185c5769643921278386c05c1da5c31775e6 100644
--- a/src/plugins/value/legacy/eval_op.ml
+++ b/src/plugins/value/legacy/eval_op.ml
@@ -103,9 +103,9 @@ let reduce_by_initialized_defined f loc state =
(* il and ih are the bounds of the interval to reduce.
We change the initialized flags in the following cases:
- either we overwrite entire values, or the partly overwritten
- value is at the beginning or at the end of the subrange
+ value is at the beginning or at the end of the subrange
- or we do not lose information on misaligned or partial values:
- the result is a singleton *)
+ the result is a singleton *)
if V_Or_Uninitialized.(cardinal_zero_or_one v' || is_isotropic v') ||
((Int.equal offl il || Int.equal (Int.e_rem ll modu) abs_shift) &&
(Int.equal offh ih ||
diff --git a/src/plugins/value/legacy/eval_terms.ml b/src/plugins/value/legacy/eval_terms.ml
index ce9a20a55a312fa437321e4c9a52affec6a9aa2e..35f3c5c6ac8f1294f13ae513e625884ac38f6d30 100644
--- a/src/plugins/value/legacy/eval_terms.ml
+++ b/src/plugins/value/legacy/eval_terms.ml
@@ -1198,26 +1198,26 @@ and eval_tlval ~alarm_mode env t =
and eval_tif : 'a. (alarm_mode:_ -> _ -> _ -> 'a eval_result) -> ('a -> 'a -> 'a) -> ('a -> 'a -> 'a) -> alarm_mode:_ -> _ -> _ -> _ -> _ -> 'a eval_result =
fun eval join meet ~alarm_mode env tcond ttrue tfalse ->
- let r = eval_term ~alarm_mode env tcond in
- let ctrue = Cvalue.V.contains_non_zero r.eover
- and cfalse = Cvalue.V.contains_zero r.eover in
- match ctrue, cfalse with
- | true, true ->
- 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
- "Incoherent types in conditional: %a vs. %a. \
- Please report"
- Printer.pp_typ vtrue.etype Printer.pp_typ vfalse.etype;
- let eover = join vtrue.eover vfalse.eover in
- let eunder = meet vtrue.eunder vfalse.eunder in
- { etype = vtrue.etype;
- ldeps = join_logic_deps vtrue.ldeps vfalse.ldeps;
- eunder; eover }
- | true, false -> eval ~alarm_mode env ttrue
- | false, true -> eval ~alarm_mode env tfalse
- | false, false -> assert false (* a logic alarm would have been raised*)
+ let r = eval_term ~alarm_mode env tcond in
+ let ctrue = Cvalue.V.contains_non_zero r.eover
+ and cfalse = Cvalue.V.contains_zero r.eover in
+ match ctrue, cfalse with
+ | true, true ->
+ 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
+ "Incoherent types in conditional: %a vs. %a. \
+ Please report"
+ Printer.pp_typ vtrue.etype Printer.pp_typ vfalse.etype;
+ let eover = join vtrue.eover vfalse.eover in
+ let eunder = meet vtrue.eunder vfalse.eunder in
+ { etype = vtrue.etype;
+ ldeps = join_logic_deps vtrue.ldeps vfalse.ldeps;
+ eunder; eover }
+ | true, false -> eval ~alarm_mode env ttrue
+ | false, true -> eval ~alarm_mode env tfalse
+ | false, false -> assert false (* a logic alarm would have been raised*)
(* if you add something here, update known_logic_funs above also *)
and eval_known_logic_function ~alarm_mode env li labels args =
diff --git a/src/plugins/value/register.ml b/src/plugins/value/register.ml
index b7198f212195417767e50c26497c272c0026b8c5..f8617e5ad4eb5c0b021ed543a5102af398231f72 100644
--- a/src/plugins/value/register.ml
+++ b/src/plugins/value/register.ml
@@ -169,9 +169,14 @@ let () =
open Eval
-module Val = struct
+module CVal = struct
include Main_values.CVal
- include Structure.Open (Structure.Key_Value) (Main_values.CVal)
+ let structure = Abstract.Value.Leaf (key, (module Main_values.CVal))
+end
+
+module Val = struct
+ include CVal
+ include Structure.Open (Abstract.Value) (CVal)
let reduce t = t
end
@@ -183,6 +188,8 @@ module Eva =
module Transfer = Cvalue_domain.State.Transfer (Eva.Valuation)
+let inject_cvalue state = state, Locals_scoping.bottom ()
+
let bot_value = function
| `Bottom -> Cvalue.V.bottom
| `Value v -> v
@@ -192,7 +199,7 @@ let bot_state = function
| `Value s -> s
let update valuation state =
- bot_state (Transfer.update valuation state >>-: Cvalue_domain.project)
+ bot_state (Transfer.update valuation state >>-: fst)
let rec eval_deps state e =
match e.enode with
@@ -231,7 +238,7 @@ let notify_opt with_alarms alarms =
Extlib.may (fun mode -> Alarmset.notify mode alarms) with_alarms
let eval_expr_with_valuation ?with_alarms deps state expr=
- let state = Cvalue_domain.inject state in
+ let state = inject_cvalue state in
let deps = match deps with
| None -> None
| Some deps ->
@@ -251,7 +258,7 @@ let eval_expr_with_valuation ?with_alarms deps state expr=
module Eval = struct
let eval_expr ?with_alarms state expr =
- let state = Cvalue_domain.inject state in
+ let state = inject_cvalue state in
let eval, alarms = Eva.evaluate ~reduction:false state expr in
notify_opt with_alarms alarms;
bot_value (eval >>-: snd)
@@ -273,7 +280,7 @@ module Eval = struct
let reduce_by_cond state expr positive =
- let state = Cvalue_domain.inject state in
+ let state = inject_cvalue state in
let eval, _alarms =
Eva.reduce state expr positive
in
@@ -284,7 +291,7 @@ module Eval = struct
if not (Cvalue.Model.is_reachable state)
then state, deps, Precise_locs.loc_bottom, (Cil.typeOfLval lval)
else
- let state = Cvalue_domain.inject state in
+ let state = inject_cvalue state in
let deps = match deps with
| None -> None
| Some deps ->
@@ -333,7 +340,7 @@ module Eval = struct
let resolv_func_vinfo ?with_alarms deps state funcexp =
let open Cil_types in
- let state = Cvalue_domain.inject state in
+ let state = inject_cvalue state in
let deps = match funcexp.enode with
| Lval (Var _, NoOffset) -> deps
| Lval (Mem v, _) ->
diff --git a/src/plugins/value/utils/abstract.ml b/src/plugins/value/utils/abstract.ml
new file mode 100644
index 0000000000000000000000000000000000000000..e5153a5241bcbd0682795eb13ee79fbe48976499
--- /dev/null
+++ b/src/plugins/value/utils/abstract.ml
@@ -0,0 +1,94 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(** External interface of an abstraction, built by {!Structure.Open}. *)
+module type Interface = sig
+ type t
+ type 'a key
+ val mem : 'a key -> bool
+ val get : 'a key -> (t -> 'a) option
+ val set : 'a key -> 'a -> t -> t
+end
+
+module Value = struct
+
+ module V = struct
+ type 'a t = (module Abstract_value.S with type t = 'a)
+ end
+
+ include Structure.Shape (Structure.Key_Value) (V)
+
+ module type Internal = sig
+ include Abstract_value.S
+ val structure: t structure
+ end
+
+ module type External = sig
+ include Internal
+ include Structure.External with type t := t
+ and type 'a key := 'a key
+ end
+end
+
+module Location = struct
+
+ module L = struct
+ type 'a t = (module Abstract_location.S with type location = 'a)
+ end
+
+ include Structure.Shape (Structure.Key_Location) (L)
+
+ module type Internal = sig
+ include Abstract_location.S
+ val structure: location structure
+ end
+
+ module type External = sig
+ include Internal
+ include Structure.External with type t := location
+ and type 'a key := 'a key
+ end
+end
+
+module Domain = struct
+
+ module D = struct
+ type 'a t = (module Abstract_domain.Internal with type state = 'a)
+ end
+
+ include Structure.Shape (Structure.Key_Domain) (D)
+
+ module type Internal = sig
+ include Abstract_domain.Internal
+ val structure: t structure
+ end
+
+ module type External = sig
+ include Internal
+ include Structure.External with type t := t
+ and type 'a key := 'a key
+
+ val get_cvalue: (t -> Cvalue.Model.t) option
+ val get_cvalue_or_top: t -> Cvalue.Model.t
+ val get_cvalue_or_bottom: t Bottom.or_bottom -> Cvalue.Model.t
+ end
+end
diff --git a/src/plugins/value/utils/abstract.mli b/src/plugins/value/utils/abstract.mli
new file mode 100644
index 0000000000000000000000000000000000000000..3e797f8eddba95cddfa69765f3097ac7a3081ffa
--- /dev/null
+++ b/src/plugins/value/utils/abstract.mli
@@ -0,0 +1,118 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(** Internal and External signature of abstractions used in the Eva engine. *)
+
+(** Internal modules contains a [structure] value that describes the internal
+ structure of the abstraction. This structure is used to automatically
+ generate efficient accessors from a generic compound abstraction to specific
+ leaf abstractions. *)
+
+(** External modules export direct accessors to their leaf components.
+ When a generic abstraction is a product of several specific abstractions,
+ they allow interacting with each leaf abstraction identified by a key.
+ Note that their behavior is undefined if an abstraction contains
+ several times the same leaf module. *)
+
+(** External interface of an abstraction, built by {!Structure.Open}. *)
+module type Interface = sig
+ type t
+ type 'a key
+
+ (** Tests whether a key belongs to the module. *)
+ val mem : 'a key -> bool
+
+ (** For a key of type [k key]:
+ - if the values of type [t] contain a subpart of type [k] from a module
+ identified by the key, then [get key] returns an accessor for it.
+ - otherwise, [get key] returns None. *)
+ val get : 'a key -> (t -> 'a) option
+
+ (** For a key of type [k key]:
+ - if the values of type [t] contain a subpart of type [k] from a module
+ identified by the key, then [set key v t] returns the value [t] in which
+ this subpart has been replaced by [v].
+ - otherwise, [set key _] is the identity function. *)
+ val set : 'a key -> 'a -> t -> t
+end
+
+(** Key and structure for abstract values.
+ See {structure.mli} for more details. *)
+module Value : sig
+ include Structure.Shape
+ with type 'a key = 'a Structure.Key_Value.key
+ and type 'a data = (module Abstract_value.S with type t = 'a)
+
+ module type Internal = sig
+ include Abstract_value.S
+ val structure: t structure
+ end
+
+ module type External = sig
+ include Internal
+ include Interface with type t := t
+ and type 'a key := 'a key
+ end
+end
+
+(** Key and structure for abstract locations.
+ See {structure.mli} for more details. *)
+module Location : sig
+ include Structure.Shape
+ with type 'a key = 'a Structure.Key_Location.key
+ and type 'a data = (module Abstract_location.S with type location = 'a)
+
+ module type Internal = sig
+ include Abstract_location.S
+ val structure: location structure
+ end
+
+ module type External = sig
+ include Internal
+ include Interface with type t := location
+ and type 'a key := 'a key
+ end
+end
+
+(** Key and structure for abstract domains.
+ See {structure.mli} for more details. *)
+module Domain : sig
+ include Structure.Shape
+ with type 'a key = 'a Structure.Key_Domain.key
+ and type 'a data = (module Abstract_domain.Internal with type state = 'a)
+
+ module type Internal = sig
+ include Abstract_domain.Internal
+ val structure: t structure
+ end
+
+ module type External = sig
+ include Internal
+ include Interface with type t := t
+ and type 'a key := 'a key
+
+ (** Special accessors for the main cvalue domain. *)
+ val get_cvalue: (t -> Cvalue.Model.t) option
+ val get_cvalue_or_top: t -> Cvalue.Model.t
+ val get_cvalue_or_bottom: t Bottom.or_bottom -> Cvalue.Model.t
+ end
+end
diff --git a/src/plugins/value/utils/eval_typ.mli b/src/plugins/value/utils/eval_typ.mli
index ed2cdd50fecc1b0df0244d3ea86bad8db0d38fe3..35c9ed3578a9bd9c9ca8165bced3039d8eeca83e 100644
--- a/src/plugins/value/utils/eval_typ.mli
+++ b/src/plugins/value/utils/eval_typ.mli
@@ -34,7 +34,7 @@ val sizeof_lval_typ: typ -> Int_Base.t
(** [offsetmap_matches_type t o] returns true if either:
- [o] contains a single scalar binding, of the expected scalar type [t]
- (float or integer)
+ (float or integer)
- [o] contains multiple bindings, pointers, etc.
- [t] is not a scalar type. *)
val offsetmap_matches_type: typ -> Cvalue.V_Offsetmap.t -> bool
diff --git a/src/plugins/value/utils/structure.ml b/src/plugins/value/utils/structure.ml
index 30f4b3c38637a85fc888f4e7541ed9cf7b89f51d..c6dd04ab1c1280da7ee2927723be8bf6493c7f85 100644
--- a/src/plugins/value/utils/structure.ml
+++ b/src/plugins/value/utils/structure.ml
@@ -24,32 +24,22 @@
type (_,_) eq = Eq : ('a,'a) eq
module type Key = sig
- type 'a k
-
- val create_key: string -> 'a k
- val eq_type : 'a k -> 'b k -> ('a, 'b) eq option
+ type 'a key
- val print: 'a k Pretty_utils.formatter
- val compare: 'a k -> 'b k -> int
- val equal: 'a k -> 'b k -> bool
- val hash : 'a k -> int
- val tag: 'a k -> int
-end
+ val create_key: string -> 'a key
+ val eq_type : 'a key -> 'b key -> ('a, 'b) eq option
-module type Shape = sig
- include Key
-
- type 'a structure =
- | Void : 'a structure
- | Leaf : 'a k -> 'a structure
- | Node : 'a structure * 'b structure -> ('a * 'b) structure
+ val print: 'a key Pretty_utils.formatter
+ val compare: 'a key -> 'b key -> int
+ val equal: 'a key -> 'b key -> bool
+ val hash : 'a key -> int
+ val tag: 'a key -> int
end
-
module Make (X : sig end) = struct
- type 'a k = { tag: int;
- name: string }
+ type 'a key = { tag: int;
+ name: string }
let c = ref (-1)
let id () = incr c; !c
@@ -57,7 +47,7 @@ module Make (X : sig end) = struct
let create_key name = { tag = id (); name }
let equal x y = x.tag = y.tag
- let eq_type : type a b. a k -> b k -> (a,b) eq option = fun a b ->
+ let eq_type : type a b. a key -> b key -> (a,b) eq option = fun a b ->
if equal a b
then Some ((Obj.magic (Eq : (a,a) eq)) : (a,b) eq)
else None
@@ -67,17 +57,46 @@ module Make (X : sig end) = struct
let tag x = x.tag
let print fmt x = Format.pp_print_string fmt x.name
-
- type 'a structure =
- | Void : 'a structure
- | Leaf : 'a k -> 'a structure
- | Node : 'a structure * 'b structure -> ('a * 'b) structure
end
module Key_Value = Make (struct end)
module Key_Location = Make (struct end)
module Key_Domain = Make (struct end)
+module type Shape = sig
+ include Key
+ type 'a data
+
+ type 'a structure =
+ | Unit : unit structure
+ | Leaf : 'a key * 'a data -> 'a structure
+ | Node : 'a structure * 'b structure -> ('a * 'b) structure
+
+ val eq_structure: 'a structure -> 'b structure -> ('a, 'b) eq option
+end
+
+module Shape (Key: Key) (Data: sig type 'a t end) = struct
+ include Key
+ type 'a data = 'a Data.t
+
+ type 'a structure =
+ | Unit : unit structure
+ | Leaf : 'a key * 'a data -> 'a structure
+ | Node : 'a structure * 'b structure -> ('a * 'b) structure
+
+ let rec eq_structure : type a b. a structure -> b structure -> (a, b) eq option
+ = fun a b ->
+ match a, b with
+ | Leaf (key1, _), Leaf (key2, _) -> Key.eq_type key1 key2
+ | Node (l1, r1), Node (l2, r2) ->
+ begin
+ match eq_structure l1 l2, eq_structure r1 r2 with
+ | Some Eq, Some Eq -> Some Eq
+ | _, _ -> None
+ end
+ | Unit, Unit -> Some Eq
+ | _, _ -> None
+end
module type Internal = sig
type t
@@ -93,7 +112,6 @@ module type External = sig
val set : 'a key -> 'a -> t -> t
end
-
module Open
(Shape : Shape)
(M : sig type t val structure : t Shape.structure end)
@@ -110,15 +128,15 @@ module Open
open Shape
- let rec mem : type a. 'v Shape.k -> a structure -> bool = fun key -> function
- | Void -> false
- | Leaf k -> Shape.equal key k
+ let rec mem : type a. 'v Shape.key -> a structure -> bool = fun key -> function
+ | Unit -> false
+ | Leaf (k, _) -> Shape.equal key k
| Node (left, right) -> mem key left || mem key right
let mem key = mem key M.structure
- type ('a, 'b) get = 'b Shape.k * ('a -> 'b)
+ type ('a, 'b) get = 'b Shape.key * ('a -> 'b)
type 'a getter = Get : ('a, 'b) get -> 'a getter
@@ -130,15 +148,15 @@ module Open
let lift_get f (Get (key, get)) = Get (key, fun t -> get (f t))
let rec compute_getters : type a. a structure -> (a getter) KMap.t = function
- | Void -> KMap.empty
- | Leaf key -> KMap.singleton key (Get (key, fun (t : a) -> t))
+ | Unit -> KMap.empty
+ | Leaf (key, _) -> KMap.singleton key (Get (key, fun (t : a) -> t))
| Node (left, right) ->
let l = compute_getters left and r = compute_getters right in
let l = KMap.map (lift_get fst) l and r = KMap.map (lift_get snd) r in
KMap.merge merge l r
let getters = compute_getters M.structure
- let get (type a) (key: a Shape.k) : (M.t -> a) option =
+ let get (type a) (key: a Shape.key) : (M.t -> a) option =
match KMap.find key getters with
| None -> None
| Some (Get (k, get)) -> match Shape.eq_type key k with
@@ -146,15 +164,15 @@ module Open
| Some Eq -> Some get
- type ('a, 'b) set = 'b Shape.k * ('b -> 'a -> 'a)
+ type ('a, 'b) set = 'b Shape.key * ('b -> 'a -> 'a)
type 'a setter = Set : ('a, 'b) set -> 'a setter
let lift_set f (Set (key, set)) = Set (key, fun v b -> f (fun a -> set v a) b)
let rec compute_setters : type a. a structure -> (a setter) KMap.t = function
- | Void -> KMap.empty
- | Leaf key -> KMap.singleton key (Set (key, fun v _t -> v))
+ | Unit -> KMap.empty
+ | Leaf (key, _) -> KMap.singleton key (Set (key, fun v _t -> v))
| Node (left, right) ->
let l = compute_setters left and r = compute_setters right in
let l = KMap.map (lift_set (fun set (l, r) -> set l, r)) l
@@ -162,7 +180,7 @@ module Open
KMap.merge merge l r
let setters = compute_setters M.structure
- let set (type a) (key: a Shape.k) : (a -> M.t -> M.t) =
+ let set (type a) (key: a Shape.key) : (a -> M.t -> M.t) =
match KMap.find key setters with
| None -> fun _ t -> t
| Some (Set (k, set)) -> match Shape.eq_type key k with
diff --git a/src/plugins/value/utils/structure.mli b/src/plugins/value/utils/structure.mli
index 9d52978f6930c2a52e2231c8bb41468ce4ca24e6..c04eb8cda7bb222f5b24d2bdfc1a63de1e6214f5 100644
--- a/src/plugins/value/utils/structure.mli
+++ b/src/plugins/value/utils/structure.mli
@@ -29,43 +29,48 @@ type (_,_) eq = Eq : ('a,'a) eq
(** Keys identifying datatypes. *)
module type Key = sig
- type 'a k
+ type 'a key
- val create_key: string -> 'a k
- val eq_type : 'a k -> 'b k -> ('a, 'b) eq option
+ val create_key: string -> 'a key
+ val eq_type : 'a key -> 'b key -> ('a, 'b) eq option
- val print: 'a k Pretty_utils.formatter
- val compare: 'a k -> 'b k -> int
- val equal: 'a k -> 'b k -> bool
- val hash : 'a k -> int
- val tag: 'a k -> int
+ val print: 'a key Pretty_utils.formatter
+ val compare: 'a key -> 'b key -> int
+ val equal: 'a key -> 'b key -> bool
+ val hash : 'a key -> int
+ val tag: 'a key -> int
end
+module Make (X : sig end) : Key
+
+(** Keys module for the abstract values of Eva. *)
+module Key_Value : Key
+
+(** Keys module for the abstract locations of Eva. *)
+module Key_Location : Key
+
+(** Keys module for the abstract domains of Eva. *)
+module Key_Domain : Key
+
(** A Key module with its structure type. *)
module type Shape = sig
include Key
+ type 'a data
(** The gadt, based on keys giving the type of each node.
Describes the internal structure of a data type.
Used internally to automatically generate efficient accessors of its nodes. *)
type 'a structure =
- | Void : 'a structure
- | Leaf : 'a k -> 'a structure
+ | Unit : unit structure
+ | Leaf : 'a key * 'a data -> 'a structure
| Node : 'a structure * 'b structure -> ('a * 'b) structure
-end
-module Make (X : sig end) : Shape
-
-
-(** Keys module for the abstract values of Eva. *)
-module Key_Value : Shape
-
-(** Keys module for the abstract locations of Eva. *)
-module Key_Location : Shape
-
-(** Keys module for the abstract domains of Eva. *)
-module Key_Domain : Shape
+ val eq_structure: 'a structure -> 'b structure -> ('a, 'b) eq option
+end
+module Shape (Key: Key) (Data: sig type 'a t end) :
+ Shape with type 'a key = 'a Key.key
+ and type 'a data = 'a Data.t
(** Internal view of the tree, with the structure. *)
module type Internal = sig
@@ -92,4 +97,4 @@ module Open
(Shape : Shape)
(Data : Internal with type 'a structure := 'a Shape.structure)
: External with type t := Data.t
- and type 'a key := 'a Shape.k
+ and type 'a key := 'a Shape.key
diff --git a/src/plugins/value/value_parameters.ml b/src/plugins/value/value_parameters.ml
index 5d65031bc02d5ba7b3298f6854685338bab3c708..1de1430a7c101b4894bd7aa0176476f575738ee8 100644
--- a/src/plugins/value/value_parameters.ml
+++ b/src/plugins/value/value_parameters.ml
@@ -77,6 +77,8 @@ 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_experimental = register_category "experimental-ok"
+
let () =
let activate dkey = add_debug_keys dkey in
@@ -172,6 +174,18 @@ module BitwiseOffsmDomain = Domain_Parameter
let default = false
end)
+let numerors_available = ref false
+let register_numerors () = numerors_available := true
+
+let numerors_hook _ _ =
+ if not !numerors_available
+ then
+ abort
+ "The numerors domain has been requested but is not available,@ \
+ as Frama-C did not found the MPFR library. The analysis is aborted."
+ else if not (is_debug_key_enabled dkey_experimental) then
+ warning "The numerors domain is experimental.";
+
module NumerorsDomain = Domain_Parameter
(struct
let option_name = "-eva-numerors-domain"
@@ -180,16 +194,28 @@ module NumerorsDomain = Domain_Parameter
computations"
let default = false
end)
+let () = NumerorsDomain.add_set_hook numerors_hook
let apron_help = "Experimental binding of the numerical domains provided \
by the APRON library: http://apron.cri.ensmp.fr/library \n"
+let apron_available = ref false
+let register_apron () = apron_available := true
+
+let apron_hook _ _ =
+ if not !apron_available
+ then
+ abort "an Apron domain is requested but the apron binding is not available."
+ else if not (is_debug_key_enabled dkey_experimental) then
+ warning "The Apron domains binding is experimental.";
+
module ApronOctagon = Domain_Parameter
(struct
let option_name = "-eva-apron-oct"
let help = apron_help ^ "Use the octagon domain of apron."
let default = false
end)
+let () = ApronOctagon.add_set_hook apron_hook
module ApronBox = Domain_Parameter
(struct
@@ -197,6 +223,7 @@ module ApronBox = Domain_Parameter
let help = apron_help ^ "Use the box domain of apron."
let default = false
end)
+let () = ApronBox.add_set_hook apron_hook
module PolkaLoose = Domain_Parameter
(struct
@@ -204,6 +231,7 @@ module PolkaLoose = Domain_Parameter
let help = apron_help ^ "Use the loose polyhedra domain of apron."
let default = false
end)
+let () = PolkaLoose.add_set_hook apron_hook
module PolkaStrict = Domain_Parameter
(struct
@@ -211,6 +239,7 @@ module PolkaStrict = Domain_Parameter
let help = apron_help ^ "Use the strict polyhedra domain of apron."
let default = false
end)
+let () = PolkaStrict.add_set_hook apron_hook
module PolkaEqualities = Domain_Parameter
(struct
@@ -218,6 +247,7 @@ module PolkaEqualities = Domain_Parameter
let help = apron_help ^ "Use the linear equalities domain of apron."
let default = false
end)
+let () = PolkaEqualities.add_set_hook apron_hook
module InoutDomain = Domain_Parameter
(struct
@@ -233,6 +263,13 @@ module SignDomain = Domain_Parameter
let default = false
end)
+module TracesDomain = Domain_Parameter
+ (struct
+ let option_name = "-eva-traces-domain"
+ let help = "Use a domain to record traces of Eva. Experimental."
+ let default = false
+ end)
+
module PrinterDomain = Domain_Parameter
(struct
let option_name = "-eva-printer-domain"
@@ -306,6 +343,43 @@ let () =
Numerors_Mode.set_possible_values ["relative"; "absolute"; "none"; "both"]
let () = add_precision_dep Numerors_Mode.parameter
+let () = Parameter_customize.set_group domains
+module TracesUnrollLoop =
+ Bool
+ (struct
+ let option_name = "-eva-traces-unroll-loop"
+ let help = "Specify if the traces domain should unroll the loops."
+ let default = true
+ end)
+let () = add_precision_dep TracesUnrollLoop.parameter
+
+let () = Parameter_customize.set_group domains
+module TracesUnifyLoop =
+ Bool
+ (struct
+ let option_name = "-eva-traces-unify-loop"
+ let help = "Specify if all the instances of a loop should try \
+ to share theirs traces."
+ let default = false
+ end)
+let () = add_precision_dep TracesUnifyLoop.parameter
+
+let () = Parameter_customize.set_group domains
+module TracesDot = Empty_string
+ (struct
+ let option_name = "-eva-traces-dot"
+ let help = "Output to the given filename the Cfg in dot format."
+ let arg_name = "FILENAME"
+ end)
+
+let () = Parameter_customize.set_group domains
+module TracesProject = Bool
+ (struct
+ let option_name = "-eva-traces-project"
+ let help = "Try to convert the Cfg into a program in a new project."
+ let default = false
+ end)
+
(* -------------------------------------------------------------------------- *)
(* --- Performance options --- *)
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/value/value_parameters.mli b/src/plugins/value/value_parameters.mli
index a5f62e9cff6d10c4d4ebaef1a4dae9da8b8294f2..3e0fb860496b052159093bf18d4239e97379081a 100644
--- a/src/plugins/value/value_parameters.mli
+++ b/src/plugins/value/value_parameters.mli
@@ -37,6 +37,7 @@ module InoutDomain: Parameter_sig.Bool
module SignDomain: Parameter_sig.Bool
module PrinterDomain: Parameter_sig.Bool
module NumerorsDomain: Parameter_sig.Bool
+module TracesDomain: Parameter_sig.Bool
module ApronOctagon: Parameter_sig.Bool
module ApronBox: Parameter_sig.Bool
@@ -49,13 +50,17 @@ module EqualityCallFunction:
Parameter_sig.Map with type key = Cil_types.kernel_function
and type value = string
+module TracesUnrollLoop: Parameter_sig.Bool
+module TracesUnifyLoop: Parameter_sig.Bool
+module TracesDot: Parameter_sig.String
+module TracesProject: Parameter_sig.Bool
+
module EqualityStorage: Parameter_sig.Bool
module SymbolicLocsStorage: Parameter_sig.Bool
module GaugesStorage: Parameter_sig.Bool
module ApronStorage: Parameter_sig.Bool
module BitwiseOffsmStorage: Parameter_sig.Bool
-
module AutomaticContextMaxDepth: Parameter_sig.Int
module AutomaticContextMaxWidth: Parameter_sig.Int
@@ -229,6 +234,11 @@ val dkey_callbacks : category
val dkey_widening : category
+(** Notifies that the binding to Apron domains is available. *)
+val register_apron: unit -> unit
+
+(** Notifies that the numerors domain is available. *)
+val register_numerors: unit -> unit
(*
Local Variables:
diff --git a/src/plugins/value/values/abstract_location.mli b/src/plugins/value/values/abstract_location.mli
index 2c7266aa87353cdcf86e012121bc23f026d2d010..6242ecc18d1f1b3df5d183dbccc6b59aeeb41cf2 100644
--- a/src/plugins/value/values/abstract_location.mli
+++ b/src/plugins/value/values/abstract_location.mli
@@ -119,21 +119,14 @@ module type S = sig
typ -> index:value -> remaining:offset -> offset -> (value * offset) or_bottom
end
-(** Key and structure for locations. See {structure.mli},
- and {domain.mli} where the mechanism is explained in detail.*)
+type 'loc key = 'loc Structure.Key_Location.key
-type 'a key = 'a Structure.Key_Location.k
-type 'a structure = 'a Structure.Key_Location.structure
-
-module type Internal = sig
+(** Signature for a leaf module of abstract locations. *)
+module type Leaf = sig
include S
- val structure : location structure
-end
-module type External = sig
- include S
- include Structure.External with type t := location
- and type 'a key := 'a key
+ (** The key identifies the module and the type [t] of abstract locations. *)
+ val key: location key
end
(*
diff --git a/src/plugins/value/values/abstract_value.mli b/src/plugins/value/values/abstract_value.mli
index 28fec80b0e53acad4535b0655b86601a5e0b690d..c6efd63271876b27d54960adc4f32e5697b3d139 100644
--- a/src/plugins/value/values/abstract_value.mli
+++ b/src/plugins/value/values/abstract_value.mli
@@ -181,21 +181,14 @@ module type S = sig
end
-(** Key and structure for values. See {structure.mli},
- and {domain.mli} where the mechanism is explained in detail.*)
+type 'v key = 'v Structure.Key_Value.key
-type 'a key = 'a Structure.Key_Value.k
-type 'a structure = 'a Structure.Key_Value.structure
-
-module type Internal = sig
+(** Signature for a leaf module of abstract values. *)
+module type Leaf = sig
include S
- val structure : t structure
-end
-module type External = sig
- include S
- include Structure.External with type t := t
- and type 'a key := 'a key
+ (** The key identifies the module and the type [t] of abstract values. *)
+ val key: t key
end
diff --git a/src/plugins/value/values/location_lift.ml b/src/plugins/value/values/location_lift.ml
index ce5ae27c8641259ef90652d9d36dffffee6ad2bf..f02568133bbbfd282a44abb8b20cf7f70f5e51af 100644
--- a/src/plugins/value/values/location_lift.ml
+++ b/src/plugins/value/values/location_lift.ml
@@ -32,17 +32,19 @@ module type Conversion = sig
end
module Make
- (Loc: Abstract_location.Internal)
+ (Loc: Abstract_location.Leaf)
(Convert : Conversion with type internal_value := Loc.value)
= struct
(* Import most of [Loc] *)
- include (Loc: Abstract_location.Internal
+ include (Loc: Abstract_location.S
with type value := Loc.value (* we are converting this type *)
and type location = Loc.location
and type offset = Loc.offset)
type value = Convert.extended_value
+ let structure = Abstract.Location.Leaf (Loc.key, (module Loc))
+
(* Now lift the functions that contain {!value} in their type. *)
let to_value loc = Convert.extend_val (Loc.to_value loc)
diff --git a/src/plugins/value/values/location_lift.mli b/src/plugins/value/values/location_lift.mli
index 1eb2d98d38c1da61d05b0891f7e6f88cda650e87..cd5b46cafaf7143981d76060b05f4be48b656f4d 100644
--- a/src/plugins/value/values/location_lift.mli
+++ b/src/plugins/value/values/location_lift.mli
@@ -30,9 +30,9 @@ module type Conversion = sig
end
module Make
- (Loc: Abstract_location.Internal)
+ (Loc: Abstract_location.Leaf)
(Convert : Conversion with type internal_value := Loc.value)
- : Abstract_location.Internal with type location = Loc.location
+ : Abstract.Location.Internal with type location = Loc.location
and type offset = Loc.offset
and type value = Convert.extended_value
diff --git a/src/plugins/value/values/main_locations.ml b/src/plugins/value/values/main_locations.ml
index f98119eab16be0479dd44dbd92e7c66bb668296d..8722ef3517205bc1e9d53b74c754e44cc6a87292 100644
--- a/src/plugins/value/values/main_locations.ml
+++ b/src/plugins/value/values/main_locations.ml
@@ -22,8 +22,6 @@
open Cil_types
-let ploc_key = Structure.Key_Location.create_key "precise_locs"
-
module PLoc = struct
type value = Cvalue.V.t
@@ -32,7 +30,7 @@ module PLoc = struct
| Precise of Precise_locs.precise_offset
| Imprecise of Cvalue.V.t (* when the offset contains addresses *)
- let structure = Structure.Key_Location.Leaf ploc_key
+ let key = Structure.Key_Location.create_key "precise_locs"
let equal_loc = Precise_locs.equal_loc
let equal_offset o1 o2 = match o1, o2 with
diff --git a/src/plugins/value/values/main_locations.mli b/src/plugins/value/values/main_locations.mli
index 28d11c16b762f742bdcc3364c4d01de67d6ca0c3..7701838d407cb735e23a76bd8de2a1f74bdb558a 100644
--- a/src/plugins/value/values/main_locations.mli
+++ b/src/plugins/value/values/main_locations.mli
@@ -25,7 +25,7 @@
(** Abstract locations built over Precise_locs. *)
module PLoc : sig
- include Abstract_location.Internal
+ include Abstract_location.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
@@ -33,10 +33,6 @@ module PLoc : sig
end
-(** Key for precise locs. *)
-val ploc_key : PLoc.location Abstract_location.key
-
-
(*
Local Variables:
compile-command: "make -C ../../../.."
diff --git a/src/plugins/value/values/main_values.ml b/src/plugins/value/values/main_values.ml
index f5bec06d977060be6fd796cedaea8bfde736f059..83b93bbfb6321503ef84c4d54421936a7e2cd2b1 100644
--- a/src/plugins/value/values/main_values.ml
+++ b/src/plugins/value/values/main_values.ml
@@ -22,12 +22,10 @@
open Cil_types
-let cvalue_key = Structure.Key_Value.create_key "cvalue"
-
module CVal = struct
include Cvalue.V
- let structure = Structure.Key_Value.Leaf cvalue_key
+ let key = Structure.Key_Value.create_key "cvalue"
let zero = Cvalue.V.singleton_zero
let one = Cvalue.V.singleton_one
@@ -135,12 +133,10 @@ module CVal = struct
with Abstract_interp.Error_Top -> `Top, true
end
-let interval_key = Structure.Key_Value.create_key "interval"
-
module Interval = struct
include Datatype.Option (Ival)
- let structure = Structure.Key_Value.Leaf interval_key
+ let key = Structure.Key_Value.create_key "interval"
let pretty_typ _ = pretty
diff --git a/src/plugins/value/values/main_values.mli b/src/plugins/value/values/main_values.mli
index fd148fcfcc5208e58353e0a847249b4d715a3c14..4923f3182ed2e685eaefa4653bae7a840b9b0fb8 100644
--- a/src/plugins/value/values/main_values.mli
+++ b/src/plugins/value/values/main_values.mli
@@ -23,17 +23,11 @@
(** Main numeric values of Eva. *)
(** Abstract values built over Cvalue.V *)
-module CVal : Abstract_value.Internal with type t = Cvalue.V.t
-
-(** Key for cvalues. *)
-val cvalue_key : CVal.t Abstract_value.key
+module CVal : Abstract_value.Leaf with type t = Cvalue.V.t
(** Dummy interval: no forward nor backward propagations.
[None] is top. *)
-module Interval : Abstract_value.Internal with type t = Ival.t option
-
-(** Key for intervals. *)
-val interval_key : Interval.t Abstract_value.key
+module Interval : Abstract_value.Leaf with type t = Ival.t option
(*
Local Variables:
diff --git a/src/plugins/value/values/numerors/numerors_float.ml b/src/plugins/value/values/numerors/numerors_float.ml
index 9100f86425bfa2d17ac047aea38a3f655111af64..0dd24be71dba8e3b6e1bf62cb1beff96d5cba442 100644
--- a/src/plugins/value/values/numerors/numerors_float.ml
+++ b/src/plugins/value/values/numerors/numerors_float.ml
@@ -83,8 +83,8 @@ let unary_mpfrf f =
calling the binary function f on two inputs of type t *)
let binary_mpfrf f =
fun ?(rnd = Rounding.Near) ?(prec = P.Real) x y ->
- prec >>- fun () ->
- f (change_prec prec x) (change_prec prec y) (rounding rnd)
+ prec >>- fun () ->
+ f (change_prec prec x) (change_prec prec y) (rounding rnd)
(*-----------------------------------------------------------------------------
@@ -196,7 +196,7 @@ let div = binary_mpfrf Mpfrf.div
let pow = binary_mpfrf Mpfrf.pow
let pow_int =
fun ?(rnd = Rounding.Near) ?(prec = P.Real) x n ->
- prec >>- fun () -> Mpfrf.pow_int (change_prec prec x) n (rounding rnd)
+ prec >>- fun () -> Mpfrf.pow_int (change_prec prec x) n (rounding rnd)
(*-----------------------------------------------------------------------------
diff --git a/src/plugins/value/values/numerors/numerors_value.ml b/src/plugins/value/values/numerors/numerors_value.ml
index 8fa47dc923f6337a7a09483991e497cb2d08da7f..6ef7042aa6964c78ea5a70bfac37a58a5fb76955 100644
--- a/src/plugins/value/values/numerors/numerors_value.ml
+++ b/src/plugins/value/values/numerors/numerors_value.ml
@@ -116,8 +116,7 @@ end
include Datatype.Make(T)
let pretty_debug = pretty
let pretty_typ _ = pretty
-let error_key = Structure.Key_Value.create_key "numerors_values"
-let structure = Structure.Key_Value.Leaf error_key
+let key = Structure.Key_Value.create_key "numerors_values"
(*-----------------------------------------------------------------------------
diff --git a/src/plugins/value/values/numerors/numerors_value.mli b/src/plugins/value/values/numerors/numerors_value.mli
index d73b689cd75ca60a4fe10a2cb2eaad9bc625d97a..3c87147b3e30abae9d15aa503bf164147ddaf18c 100644
--- a/src/plugins/value/values/numerors/numerors_value.mli
+++ b/src/plugins/value/values/numerors/numerors_value.mli
@@ -20,15 +20,13 @@
(* *)
(**************************************************************************)
-include Abstract_value.Internal
+include Abstract_value.Leaf
val pretty_debug : t Pretty_utils.formatter
(** Reduction of an error value according to a floating-point interval. *)
val reduce: Fval.t -> t -> t Eval.or_bottom
-val error_key : t Structure.Key_Value.k
-
val set_absolute_to_top : t -> t
val set_relative_to_top : t -> t
diff --git a/src/plugins/value/values/offsm_value.ml b/src/plugins/value/values/offsm_value.ml
index a447493695dcb04a94297946066499e67a8c077c..1465804854fcd34cab00ffe0d572657ea2951c7b 100644
--- a/src/plugins/value/values/offsm_value.ml
+++ b/src/plugins/value/values/offsm_value.ml
@@ -381,12 +381,10 @@ module Datatype_Offsm_or_top = Datatype.Make_with_collections(struct
end)
-let offsm_key = Structure.Key_Value.create_key "offsetmap_value"
-
-module Offsm : Abstract_value.Internal with type t = offsm_or_top = struct
+module Offsm : Abstract_value.Leaf with type t = offsm_or_top = struct
include Datatype_Offsm_or_top
- let structure = Structure.Key_Value.Leaf offsm_key
+ let key = Structure.Key_Value.create_key "offsetmap_value"
let pretty_typ typ fmt = function
| Top as o -> pretty fmt o
@@ -480,10 +478,14 @@ module Offsm : Abstract_value.Internal with type t = offsm_or_top = struct
end
-module CvalueOffsm : Abstract_value.Internal with type t = V.t * offsm_or_top
+module CvalueOffsm : Abstract.Value.Internal with type t = V.t * offsm_or_top
= struct
include Value_product.Make (Main_values.CVal) (Offsm)
+ let structure =
+ Abstract.Value.(Node (Leaf (Main_values.CVal.key, (module Main_values.CVal)),
+ Leaf (Offsm.key, (module Offsm))))
+
let size typ = Integer.of_int (Cil.bitsSizeOf typ)
(* Extract an offsetmap from a pair, by converting the value when needed. *)
diff --git a/src/plugins/value/values/offsm_value.mli b/src/plugins/value/values/offsm_value.mli
index 1ad67480937996b32bffb54068b50d30ec4ef640..6465583c14eac05255723276ac81be8d94f5cafb 100644
--- a/src/plugins/value/values/offsm_value.mli
+++ b/src/plugins/value/values/offsm_value.mli
@@ -22,13 +22,10 @@
type offsm_or_top = O of Cvalue.V_Offsetmap.t | Top
-val offsm_key : offsm_or_top Structure.Key_Value.k
-
val cast :
old_size: Integer.t -> new_size: Integer.t -> signed: bool ->
Cvalue.V_Offsetmap.t -> Cvalue.V_Offsetmap.t
+module Offsm : Abstract_value.Leaf with type t = offsm_or_top
-module Offsm : Abstract_value.Internal with type t = offsm_or_top
-
-module CvalueOffsm : Abstract_value.Internal with type t = Cvalue.V.t * offsm_or_top
+module CvalueOffsm : Abstract.Value.Internal with type t = Cvalue.V.t * offsm_or_top
diff --git a/src/plugins/value/values/sign_value.ml b/src/plugins/value/values/sign_value.ml
index 211ce3cd5b2891d14d9a44a6e6f5862aed9eb762..66ebbb989c5bd9fd1fe05f9c2d258e59e66feaff 100644
--- a/src/plugins/value/values/sign_value.ml
+++ b/src/plugins/value/values/sign_value.ml
@@ -271,5 +271,4 @@ let backward_cast ~src_typ:_ ~dst_typ:_ ~src_val:_ ~dst_val:_ = `Value None
(** {2 Misc} *)
(* Eva boilerplate, used to retrieve the domain. *)
-let sign_key = Structure.Key_Value.create_key "sign_values"
-let structure = Structure.Key_Value.Leaf sign_key
+let key = Structure.Key_Value.create_key "sign_values"
diff --git a/src/plugins/value/values/sign_value.mli b/src/plugins/value/values/sign_value.mli
index 14deeda643e120747070f6106980b9acb1d5494f..44b761fb982e26370f6bc2f85c71e0618c85150b 100644
--- a/src/plugins/value/values/sign_value.mli
+++ b/src/plugins/value/values/sign_value.mli
@@ -22,8 +22,6 @@
(** Sign domain: abstraction of integer numerical values by their signs. *)
-include Abstract_value.Internal
+include Abstract_value.Leaf
val pretty_debug: t Pretty_utils.formatter
-
-val sign_key : t Structure.Key_Value.k
diff --git a/src/plugins/value/values/value_product.ml b/src/plugins/value/values/value_product.ml
index 131d47bfa680cd438e8146e4de79bcf1a3b99d29..5a088c5283873e658f87f003c5766d010bf1dda8 100644
--- a/src/plugins/value/values/value_product.ml
+++ b/src/plugins/value/values/value_product.ml
@@ -23,14 +23,12 @@
open Eval
module Make
- (Left: Abstract_value.Internal)
- (Right: Abstract_value.Internal)
+ (Left: Abstract_value.S)
+ (Right: Abstract_value.S)
= struct
include Datatype.Pair (Left) (Right)
- let structure = Structure.Key_Value.Node (Left.structure, Right.structure)
-
let pretty_typ typ =
Pretty_utils.pp_pair ~pre:"@[" ~sep:",@ " ~suf:"@]"
(Left.pretty_typ typ) (Right.pretty_typ typ)
diff --git a/src/plugins/value/values/value_product.mli b/src/plugins/value/values/value_product.mli
index f6369ee2efd75c5241cb13ca4243de875428f610..c24505d85e3f7e748301f1d05570e6df56b137d5 100644
--- a/src/plugins/value/values/value_product.mli
+++ b/src/plugins/value/values/value_product.mli
@@ -23,9 +23,9 @@
(** Cartesian product of two value abstractions. *)
module Make
- (Left: Abstract_value.Internal)
- (Right: Abstract_value.Internal)
- : Abstract_value.Internal with type t = Left.t * Right.t
+ (Left: Abstract_value.S)
+ (Right: Abstract_value.S)
+ : Abstract_value.S with type t = Left.t * Right.t
(*
diff --git a/src/plugins/wp/Auto.ml b/src/plugins/wp/Auto.ml
index 86d62474d957176721e555f38477e58f3346b108..eafe23bd7bae4684b87673ef80e6e94e983cdde6 100644
--- a/src/plugins/wp/Auto.ml
+++ b/src/plugins/wp/Auto.ml
@@ -57,20 +57,20 @@ let t_cut ?(by="") (p : F.pred) (pi : Tactical.process) (hs,g) =
let t_case (p : F.pred) (a : Tactical.process) (b : Tactical.process) =
fun (hs,g) ->
- List.append
- (a (hs,F.p_imply p g))
- (b (hs,F.p_imply (F.p_not p) g))
+ List.append
+ (a (hs,F.p_imply p g))
+ (b (hs,F.p_imply (F.p_not p) g))
let t_cases ?(complete = "complete") (dps : (pred * Tactical.process) list) =
fun (hs,g) ->
- let pool = ref [] in
- List.iter
- (fun (p,pi) ->
- List.iter
- (fun u -> pool := u :: !pool)
- (pi (hs , p_imply p g))
- ) dps ;
- ( complete , (hs , p_any fst dps) ) :: List.rev !pool
+ let pool = ref [] in
+ List.iter
+ (fun (p,pi) ->
+ List.iter
+ (fun u -> pool := u :: !pool)
+ (pi (hs , p_imply p g))
+ ) dps ;
+ ( complete , (hs , p_any fst dps) ) :: List.rev !pool
let t_range e a b ~upper ~lower ~range s =
if (not (a <= b)) then raise (Invalid_argument "Wp.Auto.t_range") ;
diff --git a/src/plugins/wp/CfgCompiler.ml b/src/plugins/wp/CfgCompiler.ml
index f270951710659edcae6417637815e41af5da9dce..9b2eea8e009c153a13631e8b88cea6b3d0f4ef9c 100644
--- a/src/plugins/wp/CfgCompiler.ml
+++ b/src/plugins/wp/CfgCompiler.ml
@@ -333,16 +333,16 @@ struct
let succs : type a b. (a,b) env -> Node.t -> Node.t list =
fun cfg n ->
- match Node.Map.find n cfg.succs with
- | exception Not_found -> []
- | Goto n2 | Effect(_,n2) | Havoc(_,n2)
- | Branch(_,Some n2,None)
- | Branch(_,None,Some n2) -> [n2]
- | Binding (_,n2) -> [n2]
- | Branch(_,Some n1,Some n2) -> [n1;n2]
- | Branch(_,None,None) -> []
- | Either l -> l
- | Implies l -> List.map snd l
+ match Node.Map.find n cfg.succs with
+ | exception Not_found -> []
+ | Goto n2 | Effect(_,n2) | Havoc(_,n2)
+ | Branch(_,Some n2,None)
+ | Branch(_,None,Some n2) -> [n2]
+ | Binding (_,n2) -> [n2]
+ | Branch(_,Some n1,Some n2) -> [n1;n2]
+ | Branch(_,None,None) -> []
+ | Either l -> l
+ | Implies l -> List.map snd l
let pretty_edge : type a. Format.formatter -> (_,a) edge -> unit = fun fmt edge ->
match edge with
@@ -366,42 +366,42 @@ struct
let pretty_env : type a. Format.formatter -> (_,a) env -> unit =
fun fmt env ->
- Context.bind Lang.F.context_pp (Lang.F.env Lang.F.Vars.empty) (fun () ->
- Format.fprintf fmt
- "@[<v>@[<3>@[succs:@]@ %a@]@,@[<3>@[datas:@]@ %a@]@,@[<3>@[assumes:@]@ %a@]@]@."
- (Pretty_utils.pp_iter2 ~between:"->@," ~sep:",@ " Node.Map.iter Node.pp pretty_edge) env.succs
- (Pretty_utils.pp_iter2 ~between:"->@," ~sep:",@ " Node.Map.iter Node.pp
- (Pretty_utils.pp_iter Bag.iter pretty_data)) env.datas
- (Pretty_utils.pp_iter ~sep:",@ " Bag.iter P.pretty) env.assumes
- ) ()
+ Context.bind Lang.F.context_pp (Lang.F.env Lang.F.Vars.empty) (fun () ->
+ Format.fprintf fmt
+ "@[<v>@[<3>@[succs:@]@ %a@]@,@[<3>@[datas:@]@ %a@]@,@[<3>@[assumes:@]@ %a@]@]@."
+ (Pretty_utils.pp_iter2 ~between:"->@," ~sep:",@ " Node.Map.iter Node.pp pretty_edge) env.succs
+ (Pretty_utils.pp_iter2 ~between:"->@," ~sep:",@ " Node.Map.iter Node.pp
+ (Pretty_utils.pp_iter Bag.iter pretty_data)) env.datas
+ (Pretty_utils.pp_iter ~sep:",@ " Bag.iter P.pretty) env.assumes
+ ) ()
let dump_edge : type a. node -> Format.formatter -> (_, a) edge -> unit =
fun n fmt edge ->
- let pp_edge ?(label="") n' =
- Format.fprintf fmt " %a -> %a [ label=\"%s\" ] ;@." Node.pp n Node.pp n' label
- in
- begin match edge with
- | Goto n1 -> pp_edge n1
- | Branch (_, n1, n2)->
- Extlib.may pp_edge n1;
- Extlib.may 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'
- | Havoc (_, n') -> pp_edge ~label:"havoc" n'
- | Binding (_,n') -> pp_edge ~label:"binding" n'
- end
+ let pp_edge ?(label="") n' =
+ Format.fprintf fmt " %a -> %a [ label=\"%s\" ] ;@." Node.pp n Node.pp n' label
+ in
+ begin match edge with
+ | Goto n1 -> pp_edge n1
+ | Branch (_, n1, n2)->
+ Extlib.may pp_edge n1;
+ Extlib.may 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'
+ | Havoc (_, n') -> pp_edge ~label:"havoc" n'
+ | Binding (_,n') -> pp_edge ~label:"binding" n'
+ end
let dump_node : data Bag.t -> Format.formatter -> node -> unit =
fun datas fmt n ->
- Format.fprintf fmt " %a [ label=\"%a\n%a\" ] ;@."
- Node.pp n Node.pp n (Pretty_utils.pp_iter ~sep:"\n" Bag.iter pretty_data) datas
+ Format.fprintf fmt " %a [ label=\"%a\n%a\" ] ;@."
+ Node.pp n Node.pp n (Pretty_utils.pp_iter ~sep:"\n" Bag.iter pretty_data) datas
let dump_succ : type a. (_, a) env -> Format.formatter -> node -> (_, a) edge -> unit =
fun env fmt n e ->
- let datas = try Node.Map.find n env.datas with Not_found -> Bag.empty in
- Format.fprintf fmt "%a\n%a@\n" (dump_node datas) n (dump_edge n) e
+ let datas = try Node.Map.find n env.datas with Not_found -> Bag.empty in
+ Format.fprintf fmt "%a\n%a@\n" (dump_node datas) n (dump_edge n) e
let dump_assume : Format.formatter -> P.t -> unit =
let count = ref 0 in
@@ -420,72 +420,72 @@ struct
let output_dot : type a b. out_channel -> ?checks:_ -> (a,b) env -> unit =
fun cout ?(checks=Bag.empty) env ->
- let count = let c = ref max_int in fun () -> decr c; !c in
- let module E = struct
- type t = Graph.Graphviz.DotAttributes.edge list
- let default = []
- let compare x y = assert (x == y); 0
- end
- in
- let module V = struct
- type t =
- | Node of Node.t
- | Assume of int * Lang.F.pred
- | Check of int * Lang.F.pred
- (* todo better saner comparison *)
- let tag = function | Node i -> Node.tag i | Assume (i,_) -> i | Check (i,_) -> i
- let pp fmt = function | Node i -> Node.pp fmt i | Assume (i,_) -> Format.fprintf fmt "ass%i" i
- | Check (i,_) -> Format.fprintf fmt "chk%i" i
- let equal x y = (tag x) = (tag y)
- let compare x y = Transitioning.Stdlib.compare (tag x) (tag y)
- let hash x = tag x
- end in
- let module G = Graph.Imperative.Digraph.ConcreteBidirectionalLabeled (V)(E) in
- let module Dot = Graph.Graphviz.Dot(struct
- let graph_attributes _g = [`Fontname "fixed"]
- let default_vertex_attributes _g = (* [`Shape `Point] *) [`Shape `Circle]
- let vertex_name v = Format.asprintf "cp%a" V.pp v
- let vertex_attributes = function
- | V.Node n -> [`Label (escape "%a" Node.pp n)]
- | V.Assume (_,p) -> [`Style `Dashed; `Label (escape "%a" Lang.F.pp_pred p)]
- | V.Check (_,p) -> [`Style `Dotted; `Label (escape "%a" Lang.F.pp_pred p)]
- let get_subgraph _ = None
- let default_edge_attributes _g = []
- let edge_attributes ((_,e,_):G.E.t) : Graph.Graphviz.DotAttributes.edge list = e
- include G
- end) in
- let g = G.create () in
- let add_edge n1 l n2 = G.add_edge_e g (V.Node n1,l,V.Node n2) in
- 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'
- | 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
- | Effect ((_,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
- Node.Map.iter add_edges env.succs;
- (** assumes *)
- Bag.iter (fun (m,p) ->
- let n1 = V.Assume(count (), p) in
- let assume_label = [`Style `Dashed ] in
- Node.Map.iter (fun n2 _ -> G.add_edge_e g (n1,assume_label,V.Node n2)) m
- ) env.assumes;
- (** checks *)
- Bag.iter (fun (m,p) ->
- let n1 = V.Check(count (), p) in
- let label = [`Style `Dotted ] in
- Node.Map.iter (fun n2 _ -> G.add_edge_e g (V.Node n2,label,n1)) m
- ) checks;
- Dot.output_graph cout g
+ let count = let c = ref max_int in fun () -> decr c; !c in
+ let module E = struct
+ type t = Graph.Graphviz.DotAttributes.edge list
+ let default = []
+ let compare x y = assert (x == y); 0
+ end
+ in
+ let module V = struct
+ type t =
+ | Node of Node.t
+ | Assume of int * Lang.F.pred
+ | Check of int * Lang.F.pred
+ (* todo better saner comparison *)
+ let tag = function | Node i -> Node.tag i | Assume (i,_) -> i | Check (i,_) -> i
+ let pp fmt = function | Node i -> Node.pp fmt i | Assume (i,_) -> Format.fprintf fmt "ass%i" i
+ | Check (i,_) -> Format.fprintf fmt "chk%i" i
+ let equal x y = (tag x) = (tag y)
+ let compare x y = Transitioning.Stdlib.compare (tag x) (tag y)
+ let hash x = tag x
+ end in
+ let module G = Graph.Imperative.Digraph.ConcreteBidirectionalLabeled (V)(E) in
+ let module Dot = Graph.Graphviz.Dot(struct
+ let graph_attributes _g = [`Fontname "fixed"]
+ let default_vertex_attributes _g = (* [`Shape `Point] *) [`Shape `Circle]
+ let vertex_name v = Format.asprintf "cp%a" V.pp v
+ let vertex_attributes = function
+ | V.Node n -> [`Label (escape "%a" Node.pp n)]
+ | V.Assume (_,p) -> [`Style `Dashed; `Label (escape "%a" Lang.F.pp_pred p)]
+ | V.Check (_,p) -> [`Style `Dotted; `Label (escape "%a" Lang.F.pp_pred p)]
+ let get_subgraph _ = None
+ let default_edge_attributes _g = []
+ let edge_attributes ((_,e,_):G.E.t) : Graph.Graphviz.DotAttributes.edge list = e
+ include G
+ end) in
+ let g = G.create () in
+ let add_edge n1 l n2 = G.add_edge_e g (V.Node n1,l,V.Node n2) in
+ 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'
+ | 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
+ | Effect ((_,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
+ Node.Map.iter add_edges env.succs;
+ (** assumes *)
+ Bag.iter (fun (m,p) ->
+ let n1 = V.Assume(count (), p) in
+ let assume_label = [`Style `Dashed ] in
+ Node.Map.iter (fun n2 _ -> G.add_edge_e g (n1,assume_label,V.Node n2)) m
+ ) env.assumes;
+ (** checks *)
+ Bag.iter (fun (m,p) ->
+ let n1 = V.Check(count (), p) in
+ let label = [`Style `Dotted ] in
+ Node.Map.iter (fun n2 _ -> G.add_edge_e g (V.Node n2,label,n1)) m
+ ) checks;
+ Dot.output_graph cout g
let dump_env : type a. name:string -> (_, a) env -> unit = fun ~name env ->
let file = (Filename.get_temp_dir_name ()) ^ "/cfg_" ^ name in
@@ -596,37 +596,37 @@ struct
(** return None when post is not accessible from this node *)
let rec effects : type a. (_,a) env -> node -> node -> S.domain option =
fun env post node ->
- if node = post
- then Some S.empty
- else
- match Node.Map.find node env.succs with
- | exception Not_found -> None
- | Goto (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)
- | Either (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)
- | Effect (effect , 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)
- | Binding (_,node2) ->
- effects env post node2
+ if node = post
+ then Some S.empty
+ else
+ match Node.Map.find node env.succs with
+ | exception Not_found -> None
+ | Goto (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)
+ | Either (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)
+ | Effect (effect , 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)
+ | Binding (_,node2) ->
+ effects env post node2
(** restrict a cfg to the nodes accessible from the pre post given,
and compute havoc effect *)
@@ -1369,85 +1369,85 @@ struct
let compile : ?name:string -> ?mode:mode -> node -> Node.Set.t -> S.domain Node.Map.t ->
cfg -> F.pred Node.Map.t * S.t Node.Map.t * Conditions.sequence =
fun ?(name="cfg") ?(mode=`Bool_Forward) pre posts user_reads env ->
+ if Wp_parameters.has_dkey dkey then
+ Format.printf "@[0) pre:%a post:%a@]@."
+ Node.pp pre (Pretty_utils.pp_iter ~sep:"@ " Node.Set.iter Node.pp) posts;
+ if Wp_parameters.has_dkey dkey then
+ Format.printf "@[1) %a@]@." pretty_env env;
+ (** restrict environment to useful node and compute havoc effects *)
+ let env = restrict env pre posts in
+ if Wp_parameters.has_dkey dkey then
+ Format.printf "@[2) %a@]@." pretty_env env;
+ if Node.Map.is_empty env.succs then
+ Node.Map.empty,Node.Map.empty,
+ Conditions.sequence [Conditions.step (Conditions.Have(F.p_false))]
+ else
+ (** Simplify *)
+ let subst,env =
+ if true
+ then remove_dumb_gotos env
+ else Node.Map.empty, env
+ in
+ let pre = find_def ~def:pre pre subst in
+ (** Substitute in user_reads *)
+ let user_reads =
+ Node.Map.fold
+ (fun n n' acc ->
+ 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)
+ subst user_reads
+ in
+ (** For each node what must be read for assumes *)
+ let reads =
+ Bag.fold_left (fun acc e ->
+ Node.Map.union
+ (fun _ -> S.union) acc
+ (P.reads e))
+ user_reads env.assumes in
+ (** compute sigmas and relocate them *)
+ let env, sigmas = domains env reads pre in
if Wp_parameters.has_dkey dkey then
- Format.printf "@[0) pre:%a post:%a@]@."
- Node.pp pre (Pretty_utils.pp_iter ~sep:"@ " Node.Set.iter Node.pp) posts;
- if Wp_parameters.has_dkey dkey then
- Format.printf "@[1) %a@]@." pretty_env env;
- (** restrict environment to useful node and compute havoc effects *)
- let env = restrict env pre posts in
- if Wp_parameters.has_dkey dkey then
- Format.printf "@[2) %a@]@." pretty_env env;
- if Node.Map.is_empty env.succs then
- Node.Map.empty,Node.Map.empty,
- Conditions.sequence [Conditions.step (Conditions.Have(F.p_false))]
- else
- (** Simplify *)
- let subst,env =
- if true
- then remove_dumb_gotos env
- else Node.Map.empty, env
- in
- let pre = find_def ~def:pre pre subst in
- (** Substitute in user_reads *)
- let user_reads =
- Node.Map.fold
- (fun n n' acc ->
- 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)
- subst user_reads
- in
- (** For each node what must be read for assumes *)
- let reads =
- Bag.fold_left (fun acc e ->
- Node.Map.union
- (fun _ -> S.union) acc
- (P.reads e))
- user_reads env.assumes in
- (** compute sigmas and relocate them *)
- let env, sigmas = domains env reads pre in
- if Wp_parameters.has_dkey dkey then
- Format.printf "@[3) %a@]@." pretty_env env;
- if Wp_parameters.has_dkey dumpkey then
- dump_env ~name env;
- 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
- | (`Bool_Backward | `Bool_Forward) as mode ->
- to_sequence_bool ~mode pre posts env in
- let predssigmas =
- Node.Map.merge
- (fun _ p s -> Some (Extlib.opt_conv F.p_false p, Extlib.opt_conv (S.create ()) s))
- preds sigmas in
- (** readd simplified nodes *)
- let predssigmas =
- Node.Map.fold (fun n n' acc -> Node.Map.add n (Node.Map.find n' predssigmas) acc )
- subst predssigmas
- in
- let preds =
- Node.Map.map(fun _ (x,_) -> x) predssigmas
- in
- let sigmas =
- Node.Map.map(fun _ (_,x) -> x) predssigmas
- in
- preds,sigmas,f
+ Format.printf "@[3) %a@]@." pretty_env env;
+ if Wp_parameters.has_dkey dumpkey then
+ dump_env ~name env;
+ 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
+ | (`Bool_Backward | `Bool_Forward) as mode ->
+ to_sequence_bool ~mode pre posts env in
+ let predssigmas =
+ Node.Map.merge
+ (fun _ p s -> Some (Extlib.opt_conv F.p_false p, Extlib.opt_conv (S.create ()) s))
+ preds sigmas in
+ (** readd simplified nodes *)
+ let predssigmas =
+ Node.Map.fold (fun n n' acc -> Node.Map.add n (Node.Map.find n' predssigmas) acc )
+ subst predssigmas
+ in
+ let preds =
+ Node.Map.map(fun _ (x,_) -> x) predssigmas
+ in
+ let sigmas =
+ Node.Map.map(fun _ (_,x) -> x) predssigmas
+ in
+ preds,sigmas,f
end
diff --git a/src/plugins/wp/Cint.ml b/src/plugins/wp/Cint.ml
index 7664ac4a71c16c2cbea578e7fb592303485412ae..c6d48f85cc31f16c9983b13534f09e9e6c629f93 100644
--- a/src/plugins/wp/Cint.ml
+++ b/src/plugins/wp/Cint.ml
@@ -257,8 +257,8 @@ let match_binop_one_extraction binop = match_list_extraction (match_binop_one_ar
(* to_iota(e) where e = to_iota'(e'), only ranges for iota *)
let simplify_range_comp f iota e conv e' =
let iota' = to_cint conv in
- let size' = Ctypes.range iota' in
- let size = Ctypes.range iota in
+ let size' = Ctypes.i_bits iota' in
+ let size = Ctypes.i_bits iota in
if size <= size'
then e_fun f [e']
(* rule B:
@@ -288,7 +288,7 @@ let configure_to_int iota =
begin
try match F.repr e with
| Logic.Kint value ->
- let size = Integer.of_int (Ctypes.range iota) in
+ let size = Integer.of_int (Ctypes.i_bits iota) in
let signed = Ctypes.signed iota in
F.e_zint (Integer.cast ~size ~signed ~value)
| Logic.Fun( fland , es )
@@ -518,7 +518,7 @@ let smp_bitk_positive = function
F.e_not (bitk_positive k a)
| Logic.Fun( conv , [a] ) (* when is_to_c_int conv *) ->
let iota = to_cint conv in
- let range = Ctypes.range iota in
+ let range = Ctypes.i_bits iota in
let signed = Ctypes.signed iota in
if signed then (* beware of sign-bit *)
begin match is_leq k (e_int (range-2)) with
@@ -858,14 +858,15 @@ module Dom = struct
let top = Tmap.empty
[@@@ warning "-32"]
- let print fmt dom =
+ let pretty fmt dom =
Tmap.iter (fun k v ->
Format.fprintf fmt "%a: %a,@ " Lang.F.pp_term k Ival.pretty v)
dom
- [@@@ warning "+32"]
let find t dom = Tmap.find t dom
+ let get t dom = try find t dom with Not_found -> Ival.top
+
let narrow t v dom =
if Ival.is_bottom v then raise Lang.Contradiction
else if is_top_ival v then dom
@@ -930,7 +931,7 @@ module Dom = struct
| Fun(g,[a]) -> begin try (* just checks for a contraction *)
let ubound =
c_int_bounds_ival (is_cint g) (* may raise Not_found *) in
- let v = find a dom (* may raise Not_found *) in
+ let v = Tmap.find a dom (* may raise Not_found *) in
if Ival.is_included v ubound then raise Lang.Contradiction;
dom
with Not_found -> dom
diff --git a/src/plugins/wp/CodeSemantics.ml b/src/plugins/wp/CodeSemantics.ml
index 44e1686bff264800432a447e2dc2069f62f16e8a..f0ab0e892febe8e3999020e6fc9fbb515025410d 100644
--- a/src/plugins/wp/CodeSemantics.ml
+++ b/src/plugins/wp/CodeSemantics.ml
@@ -315,7 +315,11 @@ struct
Lang.assume (Cvalues.is_object obj data) ;
data
- | AddrOf lv | StartOf lv -> Loc (lval env lv)
+ | AddrOf lv ->
+ Loc (lval env lv)
+
+ | StartOf 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
diff --git a/src/plugins/wp/Cvalues.ml b/src/plugins/wp/Cvalues.ml
index 01bf83ca952940afa1c339d9914766de164ad86a..ea121cb9b8cedcff35a8a6114e312eca1d205ab0 100644
--- a/src/plugins/wp/Cvalues.ml
+++ b/src/plugins/wp/Cvalues.ml
@@ -356,6 +356,42 @@ let plain lt e =
else
Vexp e
+(* -------------------------------------------------------------------------- *)
+(* --- Printing Values --- *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a printer = Format.formatter -> 'a -> unit
+
+let pp_bound fmt = function None -> () | Some p -> F.pp_term fmt p
+
+let pp_value pp fmt = function
+ | Loc l -> pp fmt l
+ | Val v -> F.pp_term fmt v
+
+let pp_logic pp fmt = function
+ | Vexp e -> F.pp_term fmt e
+ | Vloc l -> pp fmt l
+ | Lset _ | Vset _ -> Format.pp_print_string fmt "<set>"
+
+let pp_rloc pp fmt = function
+ | Rloc(obj,l) ->
+ 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
+
+let pp_sloc pp fmt = function
+ | Sloc l -> pp fmt l
+ | Sarray(l,_,n) ->
+ 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
+ | Sdescr(xs,l,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
+
(* -------------------------------------------------------------------------- *)
(* --- Int-As-Booleans --- *)
(* -------------------------------------------------------------------------- *)
@@ -370,6 +406,16 @@ let bool_val e = e_if e e_one e_zero
let is_true p = e_if (e_prop p) e_one e_zero
let is_false p = e_if (e_prop p) e_zero e_one
+(* -------------------------------------------------------------------------- *)
+(* --- Start Of Arrays --- *)
+(* -------------------------------------------------------------------------- *)
+
+let startof ~shift loc typ =
+ if Cil.isArrayType typ then
+ let t_elt = Cil.typeOf_array_elem typ in
+ shift loc (Ctypes.object_of t_elt) e_zero
+ else loc
+
(* -------------------------------------------------------------------------- *)
(* --- Lifting Memory Model to Values --- *)
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/Cvalues.mli b/src/plugins/wp/Cvalues.mli
index e7a09ec5b78fa01ef642bb1fe717cff19ffddfa1..102255f1c0465fe84322dc84d93da68a522eb475 100644
--- a/src/plugins/wp/Cvalues.mli
+++ b/src/plugins/wp/Cvalues.mli
@@ -31,6 +31,17 @@ open Lang.F
val equation : Sigs.equation -> pred
+(** {2 Pretty Printing} *)
+
+type 'a printer = Format.formatter -> 'a -> unit
+
+val pp_bound : term option printer
+val pp_value : 'a printer -> 'a value printer
+val pp_logic : 'a printer -> 'a logic printer
+val pp_region : 'a printer -> 'a region printer
+val pp_sloc : 'a printer -> 'a sloc printer
+val pp_rloc : 'a printer -> 'a rloc printer
+
(** {2 Int-As-Booleans} *)
val bool_val : unop
@@ -49,6 +60,11 @@ val null : (term -> pred) Context.value (** test for null pointer value *)
val is_null : c_object -> term -> pred
+(** {2 Start of Arrays} *)
+
+(** Shift a location with 0-indices wrt to its array type *)
+val startof : shift:('a -> c_object -> term -> 'a) -> 'a -> typ -> 'a
+
(** {2 Typing and Sub-Typing for C and ACSL Types} *)
val is_object : c_object -> 'a value -> pred
diff --git a/src/plugins/wp/Factory.ml b/src/plugins/wp/Factory.ml
index 45339f9fa7496a9d2b2dca9d7cc28e3f20245792..f0c8ce79b900acaa5eeca69ce0fc64a75fb0bbb8 100644
--- a/src/plugins/wp/Factory.ml
+++ b/src/plugins/wp/Factory.ml
@@ -24,7 +24,7 @@
(* --- Model Factory --- *)
(* -------------------------------------------------------------------------- *)
-type mheap = Hoare | ZeroAlias | Typed of MemTyped.pointer
+type mheap = Hoare | ZeroAlias | Region | Typed of MemTyped.pointer
type mvar = Raw | Var | Ref | Caveat
type setup = {
@@ -64,6 +64,7 @@ let descr_mtyped d = function
| MemTyped.Fits -> ()
let descr_mheap d = function
+ | Region -> main d "region"
| ZeroAlias -> main d "zeroalias"
| Hoare -> main d "hoare"
| Typed p -> main d "typed" ; descr_mtyped d p
@@ -157,31 +158,47 @@ struct
end
end
+module Static : Proxy =
+struct
+ let datatype = "Static"
+ let param x =
+ let open Cil_types in
+ if x.vaddrof || Cil.isArrayType x.vtype || Cil.isPointerType x.vtype
+ then MemoryContext.ByAddr else MemoryContext.ByValue
+ let iter = Raw.iter
+end
+
(* -------------------------------------------------------------------------- *)
(* --- RefUsage-based Proxies --- *)
(* -------------------------------------------------------------------------- *)
-let is_formal_ptr x =
- let open Cil_types in
- x.vformal && Cil.isPointerType x.vtype
+let is_ptr x = Cil.isPointerType x.Cil_types.vtype
+let is_fun_ptr x = Cil.isFunctionType x.Cil_types.vtype
+let is_formal_ptr x = x.Cil_types.vformal && is_ptr x
+let is_init kf x =
+ WpStrategy.is_main_init kf ||
+ Wp_parameters.AliasInit.get () ||
+ ( WpStrategy.isInitConst () && WpStrategy.isGlobalInitConst x )
let refusage_param ~byref ~context x =
let kf,init = match WpContext.get_scope () with
- | WpContext.Global -> None,false
- | WpContext.Kf f ->
- Some f ,
- WpStrategy.is_main_init f ||
- Wp_parameters.AliasInit.get () ||
- ( WpStrategy.isInitConst () &&
- WpStrategy.isGlobalInitConst x ) in
+ | WpContext.Global -> None , false
+ | WpContext.Kf kf -> Some kf , is_init kf x in
match RefUsage.get ?kf ~init x with
| RefUsage.NoAccess -> MemoryContext.NotUsed
| RefUsage.ByAddr -> MemoryContext.ByAddr
- | RefUsage.ByRef when byref -> MemoryContext.ByRef
- | RefUsage.ByArray when context && is_formal_ptr x -> MemoryContext.InArray
- | RefUsage.ByValue when context && is_formal_ptr x -> MemoryContext.InContext
- | RefUsage.ByRef | RefUsage.ByValue -> MemoryContext.ByValue
- | RefUsage.ByArray -> MemoryContext.ByShift
+ | RefUsage.ByValue ->
+ if context && is_formal_ptr x then MemoryContext.InContext
+ else if is_ptr x && not (is_fun_ptr x) then MemoryContext.ByShift
+ else MemoryContext.ByValue
+ | RefUsage.ByRef ->
+ if byref
+ then MemoryContext.ByRef
+ else MemoryContext.ByValue
+ | RefUsage.ByArray ->
+ if context && is_formal_ptr x
+ then MemoryContext.InArray
+ else MemoryContext.ByShift
let refusage_iter ?kf ~init f = RefUsage.iter ?kf ~init (fun x _usage -> f x)
@@ -228,6 +245,7 @@ module MakeCompiler(M:Sigs.Model) = struct
module A = LogicAssigns.Make(M)(C)(L)
end
+module Comp_Region = MakeCompiler(Register(Static)(MemRegion))
module Comp_MemZeroAlias = MakeCompiler(MemZeroAlias)
module Comp_Hoare_Raw = MakeCompiler(Model_Hoare_Raw)
module Comp_Hoare_Ref = MakeCompiler(Model_Hoare_Ref)
@@ -240,6 +258,7 @@ module Comp_Caveat = MakeCompiler(Model_Caveat)
let compiler mheap mvar : (module Sigs.Compiler) =
match mheap , mvar with
| ZeroAlias , _ -> (module Comp_MemZeroAlias)
+ | Region , _ -> (module Comp_Region)
| _ , Caveat -> (module Comp_Caveat)
| Hoare , (Raw|Var) -> (module Comp_Hoare_Raw)
| Hoare , Ref -> (module Comp_Hoare_Ref)
@@ -254,6 +273,7 @@ let compiler mheap mvar : (module Sigs.Compiler) =
let configure_mheap = function
| Hoare -> MemEmpty.configure ()
| ZeroAlias -> MemZeroAlias.configure ()
+ | Region -> MemRegion.configure ()
| Typed p -> MemTyped.configure () ; Context.set MemTyped.pointer p
let configure (s:setup) (d:driver) () =
@@ -320,6 +340,7 @@ let split ~warning (m:string) : string list =
let update_config ~warning m s = function
| "ZEROALIAS" -> { s with mheap = ZeroAlias }
+ | "REGION" -> { s with mheap = Region }
| "HOARE" -> { s with mheap = Hoare }
| "TYPED" -> { s with mheap = Typed MemTyped.Fits }
| "CAST" -> { s with mheap = Typed MemTyped.Unsafe }
diff --git a/src/plugins/wp/Factory.mli b/src/plugins/wp/Factory.mli
index b430af8263e69035c50e25a3808e1874baad50de..973daad343f83e449867c99592f1d3719573a678 100644
--- a/src/plugins/wp/Factory.mli
+++ b/src/plugins/wp/Factory.mli
@@ -24,7 +24,7 @@
(* --- Model Factory --- *)
(* -------------------------------------------------------------------------- *)
-type mheap = Hoare | ZeroAlias | Typed of MemTyped.pointer
+type mheap = Hoare | ZeroAlias | Region | Typed of MemTyped.pointer
type mvar = Raw | Var | Ref | Caveat
type setup = {
diff --git a/src/plugins/wp/Filtering.ml b/src/plugins/wp/Filtering.ml
index adf5bbd31779b2ab6a62b9f9f1ffcfd97ce8d63f..09db94091f3affe53151ca1e5936934ca18359b4 100644
--- a/src/plugins/wp/Filtering.ml
+++ b/src/plugins/wp/Filtering.ml
@@ -29,8 +29,8 @@ open Lang
open Lang.F
(* Inductive Properties:
- - filter ~polarity:true p ==> p
- - p ==> filter ~polarity:false p
+ - filter ~polarity:true p ==> p
+ - p ==> filter ~polarity:false p
*)
let rec filter ~polarity f p =
match F.p_expr p with
diff --git a/src/plugins/wp/Filtering.mli b/src/plugins/wp/Filtering.mli
index 7a0944c37bc7ff689e70e5703a565121d655e275..a84a1baa1e3cc1a0e64c3b1639dd57dd6627ca87 100644
--- a/src/plugins/wp/Filtering.mli
+++ b/src/plugins/wp/Filtering.mli
@@ -29,12 +29,12 @@ open Lang
(**
Erase parts of a predicate that do not satisfies the condition.
The erased parts are replaced by:
- - [true] when [~polarity:false] (for hypotheses)
- - [false] when [~polarity:true] (for goals)
+ - [true] when [~polarity:false] (for hypotheses)
+ - [false] when [~polarity:true] (for goals)
Hence, we have:
- - [filter ~polarity:true f p ==> p]
- - [p ==> filter ~polarity:false f p]
+ - [filter ~polarity:true f p ==> p]
+ - [p ==> filter ~polarity:false f p]
See [theory/filtering.why] for proofs.
*)
diff --git a/src/plugins/wp/Generator.ml b/src/plugins/wp/Generator.ml
index 19d7566bd9e479187ddf4b71a8c69daaee38aeaf..1423602f463b8a50526ed8032a5698846cb3a2da 100644
--- a/src/plugins/wp/Generator.ml
+++ b/src/plugins/wp/Generator.ml
@@ -86,63 +86,42 @@ let compute_ip cc ip =
(* --- Annotations Entry Point --- *)
(* -------------------------------------------------------------------------- *)
-type functions =
- | F_All
- | F_List of Cil_datatype.Kf.Set.t
- | F_Skip of Cil_datatype.Kf.Set.t
-
-let iter_kf phi = function
- | None -> Globals.Functions.iter phi
- | Some kf -> phi kf
-
-let iter_fct phi = function
- | F_All -> Globals.Functions.iter phi
- | F_Skip fs ->
- Globals.Functions.iter
- (fun kf -> if not (Cil_datatype.Kf.Set.mem kf fs) then phi kf)
- | F_List fs -> Cil_datatype.Kf.Set.iter phi fs
-
let add_kf cc ?bhv ?prop kf =
let model = cc#model in
let assigns = WpAnnot.WithAssigns in
List.iter cc#add_strategy
(WpAnnot.get_function_strategies ~model ~assigns ?bhv ?prop kf)
+let add_lemmas cc = function
+ | None | Some[] ->
+ LogicUsage.iter_lemmas
+ (fun lem ->
+ let idp = WpPropId.mk_lemma_id lem in
+ if WpAnnot.filter_status idp then cc#add_lemma lem)
+ | Some ps ->
+ if List.mem "-@lemmas" ps then ()
+ else LogicUsage.iter_lemmas
+ (fun lem ->
+ let idp = WpPropId.mk_lemma_id lem in
+ if WpAnnot.filter_status idp && WpPropId.select_by_name ps idp
+ then cc#add_lemma lem)
+
let compute_kf cc ?kf ?bhv ?prop () =
begin
- iter_kf (add_kf cc ?bhv ?prop) kf ;
+ Extlib.may (add_kf cc ?bhv ?prop) kf ;
cc#compute
end
-let do_lemmas = function F_All | F_Skip _ -> true | F_List _ -> false
-
-let compute_selection cc ?(fct=F_All) ?bhv ?prop () =
+let compute_selection cc ?(fct=Wp_parameters.Fct_all) ?bhv ?prop () =
begin
- if do_lemmas fct then
- begin
- match prop with
- | None | Some[] ->
- LogicUsage.iter_lemmas
- (fun lem ->
- let idp = WpPropId.mk_lemma_id lem in
- if WpAnnot.filter_status idp then cc#add_lemma lem)
- | Some ps ->
- if List.mem "-@lemmas" ps then ()
- else LogicUsage.iter_lemmas
- (fun lem ->
- let idp = WpPropId.mk_lemma_id lem in
- if WpAnnot.filter_status idp && WpPropId.select_by_name ps idp
- then cc#add_lemma lem)
- end ;
- iter_fct (add_kf cc ?bhv ?prop) fct ;
+ add_lemmas cc prop ;
+ Wp_parameters.iter_fct (add_kf cc ?bhv ?prop) fct ;
cc#compute
end
-(* -------------------------------------------------------------------------- *)
-(* --- Calls Entry Point --- *)
-(* -------------------------------------------------------------------------- *)
-
let compute_call cc stmt =
let model = cc#model in
List.iter cc#add_strategy (WpAnnot.get_call_pre_strategies ~model stmt) ;
cc#compute
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/Generator.mli b/src/plugins/wp/Generator.mli
index 123691fc02993f51c74b6a207e0cddffb30b48f9..72e40d4b919d7178a905b829292b572bdc4e42e1 100644
--- a/src/plugins/wp/Generator.mli
+++ b/src/plugins/wp/Generator.mli
@@ -33,18 +33,17 @@ class type computer =
method compute : Wpo.t Bag.t
end
-type functions =
- | F_All
- | F_List of Cil_datatype.Kf.Set.t
- | F_Skip of Cil_datatype.Kf.Set.t
+open Wp_parameters
val compute_ip : computer -> Property.t -> Wpo.t Bag.t
val compute_call : computer -> Cil_types.stmt -> Wpo.t Bag.t
+
val compute_kf : computer ->
?kf:Kernel_function.t ->
?bhv:string list ->
?prop:string list ->
unit -> Wpo.t Bag.t
+
val compute_selection : computer ->
?fct:functions ->
?bhv:string list ->
diff --git a/src/plugins/wp/GuiPanel.ml b/src/plugins/wp/GuiPanel.ml
index 67fa7d1e74fbbaa9a6acf5c2d9f137dd4db483b6..078ddb311e1076078b80095c5e563604a33bf05b 100644
--- a/src/plugins/wp/GuiPanel.ml
+++ b/src/plugins/wp/GuiPanel.ml
@@ -87,7 +87,7 @@ let run_and_prove
(* --- Model Panel --- *)
(* ------------------------------------------------------------------------ *)
-type memory = TREE | HOARE | TYPED
+type memory = TREE | HOARE | TYPED | REGION
class model_selector (main : Design.main_window_extension_points) =
let dialog = new Wpane.dialog
@@ -131,6 +131,7 @@ class model_selector (main : Design.main_window_extension_points) =
begin
(match s.mheap with
| ZeroAlias -> memory#set TREE
+ | Region -> memory#set REGION
| Hoare -> memory#set HOARE
| Typed m -> memory#set TYPED ; c_casts#set (m = MemTyped.Unsafe)) ;
c_byref#set (s.mvar = Ref) ;
@@ -142,6 +143,7 @@ class model_selector (main : Design.main_window_extension_points) =
method get : setup =
let m = match memory#get with
| TREE -> ZeroAlias
+ | REGION -> Region
| HOARE -> Hoare
| TYPED -> Typed
(if c_casts#get then MemTyped.Unsafe else MemTyped.Fits)
diff --git a/src/plugins/wp/GuiTactic.ml b/src/plugins/wp/GuiTactic.ml
index 34caa9678c84ef3a4f2440bd10486eb258b1d350..d5e58431b2aa38feee1a0bb8259d1af17cc4f092 100644
--- a/src/plugins/wp/GuiTactic.ml
+++ b/src/plugins/wp/GuiTactic.ml
@@ -408,10 +408,10 @@ class tactic
?range:bool -> ?vmin:int -> ?vmax:int ->
?filter:(Lang.F.term -> bool) -> 'a field -> unit =
fun ?enabled ?title ?tooltip ?range ?vmin ?vmax ?filter field ->
- let id = Tactical.ident field in
- List.iter (fun (fd : wfield) ->
- fd#update ?enabled ?title ?tooltip ?range ?vmin ?vmax ?filter id
- ) wfields
+ let id = Tactical.ident field in
+ List.iter (fun (fd : wfield) ->
+ fd#update ?enabled ?title ?tooltip ?range ?vmin ?vmax ?filter id
+ ) wfields
(* -------------------------------------------------------------------------- *)
(* --- Widget Behavior --- *)
diff --git a/src/plugins/wp/Lang.ml b/src/plugins/wp/Lang.ml
index 8e3198ad1a8ddd7d9b8a597fa72efbf1ef740b87..a1cd8c082965e828251e992e1f7d4ec8990ea82c 100644
--- a/src/plugins/wp/Lang.ml
+++ b/src/plugins/wp/Lang.ml
@@ -176,7 +176,7 @@ let t_int = Logic.Int
let t_bool = Logic.Bool
let t_real = Logic.Real
let t_prop = Logic.Prop
-let t_addr () = Context.get pointer (Cil_types.TVoid [])
+let t_addr () = Context.get pointer Cil.voidType
let t_array a = Logic.Array(Logic.Int,a)
let t_farray a b = Logic.Array(a,b)
let t_datatype adt ts = Logic.Data(adt,ts)
diff --git a/src/plugins/wp/Lang.mli b/src/plugins/wp/Lang.mli
index ed8866cc4a1de4ac1c7b4dc05b410a7943e88383..7f1f0f1a35815877a55c4a4cbc9d9f9a4effebeb 100644
--- a/src/plugins/wp/Lang.mli
+++ b/src/plugins/wp/Lang.mli
@@ -31,7 +31,10 @@ open Qed.Logic
type library = string
+(** Name for external prover.
+ In case a Qed.Engine.link is used, [F_subst] patterns
+ are not supported for Why-3. *)
type 'a infoprover = {
altergo: 'a;
why3 : 'a;
@@ -161,7 +164,7 @@ val t_int : tau
val t_real : tau
val t_bool : tau
val t_prop : tau
-val t_addr : unit -> tau
+val t_addr : unit -> tau (** pointer on Void *)
val t_array : tau -> tau
val t_farray : tau -> tau -> tau
val t_datatype : adt -> tau list -> tau
diff --git a/src/plugins/wp/Layout.ml b/src/plugins/wp/Layout.ml
new file mode 100644
index 0000000000000000000000000000000000000000..d71aa0bb8cc132e7a844d95f7d671948f6ac56e8
--- /dev/null
+++ b/src/plugins/wp/Layout.ml
@@ -0,0 +1,701 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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 Pretty_utils
+open Cil_datatype
+open Cil_types
+
+module Wp = Wp_parameters
+
+module type Data =
+sig
+ type t
+ val equal : t -> t -> bool
+ val compare : t -> t -> int
+ val pretty : t formatter
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Offsets --- *)
+(* -------------------------------------------------------------------------- *)
+
+type offset =
+ | Field of fieldinfo
+ | Index of typ * int
+
+module Offset =
+struct
+ type t = offset
+ let compare a b =
+ if a == b then 0 else match a,b with
+ | Field f, Field g -> Fieldinfo.compare f g
+ | Field _ , _ -> (-1)
+ | _ , Field _ -> 1
+ | Index(ta,n) , Index(tb,m) ->
+ let cmp = Typ.compare ta tb in
+ if cmp <> 0 then cmp else Pervasives.compare n m
+
+ let equal a b = (compare a b = 0)
+
+ let pretty fmt = function
+ | Field fd -> Format.fprintf fmt "{%s}.%a" fd.fcomp.cname Fieldinfo.pretty fd
+ | Index(ty,n) -> Format.fprintf fmt "{%a}[%d]" Typ.pretty ty n
+
+ let typeof = function
+ | Field f -> f.ftype
+ | Index(ty,_) -> ty
+
+ let field fd = Field fd
+
+ let index ty =
+ match Cil.unrollType ty with
+ | TArray(te,n,_,_) ->
+ begin
+ match Extlib.opt_bind Ctypes.get_int n 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
+
+ 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
+
+ module H = Compinfo.Hashtbl
+
+ type cache = typ H.t
+ let cache () : cache = H.create 0
+
+ let typ_of_comp cache comp =
+ try H.find cache comp with Not_found ->
+ let typ = TComp(comp,Cil.empty_size_cache (),[]) in
+ H.add cache comp typ ; typ
+
+ let field_offset cache fd =
+ let typ = typ_of_comp cache fd.fcomp in
+ let offset = Cil_types.(Field(fd,NoOffset)) in
+ Cil.bitsOffset typ offset
+
+ let range_field cache fd =
+ let typ = typ_of_comp cache fd.fcomp in
+ let offset = Cil_types.(Field(fd,NoOffset)) in
+ Cil.bitsOffset typ offset , Cil.bitsSizeOf typ
+
+ let range_index typ n =
+ let len = Cil.bitsSizeOf typ * n in (0 , len) , len
+
+ let range cache = function
+ | Field fd -> range_field cache fd
+ | Index(typ,n) -> range_index typ n
+
+ let sizeof = function
+ | Field fd -> Cil.bitsSizeOf fd.ftype
+ | Index(ty,n) -> Cil.bitsSizeOf ty * n
+
+ let container cache = function
+ | Index(ty,n) -> Cil.bitsSizeOf ty * n
+ | Field fd -> Cil.bitsSizeOf (typ_of_comp cache fd.fcomp)
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Deref --- *)
+(* -------------------------------------------------------------------------- *)
+
+type alias = NotUsed | NotAliased | Aliased
+type usage = Value | Deref | Array
+type deref = usage * typ
+
+module Alias =
+struct
+ let use = function NotUsed | NotAliased -> NotAliased | Aliased -> Aliased
+ let is_aliased = function NotUsed | NotAliased -> false | Aliased -> true
+ let merge a b =
+ match a,b with
+ | Aliased,_ | _,Aliased -> Aliased
+ | NotAliased,NotAliased -> NotAliased
+ | NotUsed,c | c,NotUsed -> c
+ let alias a b =
+ match a,b with
+ | NotUsed,c | c,NotUsed -> c
+ | _ -> Aliased
+ let to_string = function
+ | NotUsed -> "not used"
+ | NotAliased -> "not aliased"
+ | Aliased -> "aliased"
+ let pretty fmt a = Format.pp_print_string fmt (to_string a)
+end
+
+module Usage =
+struct
+ let pretty fmt = function
+ | Value -> ()
+ | Deref -> Format.pp_print_char fmt '*'
+ | Array -> Format.pp_print_string fmt "[]"
+ let order = function Value -> 0 | Deref -> 1 | Array -> 2
+ let merge a b = if order a < order b then b else a
+ let is_aliased = function Value -> false | Deref | Array -> true
+ let is_shifted = function Value | Deref -> false | Array -> true
+end
+
+module Deref =
+struct
+ type t = deref
+
+ let pretty fmt (usage,typ) =
+ Format.fprintf fmt "{%a}" Typ.pretty typ ;
+ Usage.pretty fmt usage
+
+ let compare ((da,ta):t) ((db,tb):t) =
+ let cmp = Pervasives.compare da db in
+ if cmp <> 0 then cmp else Typ.compare ta tb
+
+ let equal a b = (compare a b = 0)
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Access --- *)
+(* -------------------------------------------------------------------------- *)
+
+type lvalue =
+ | Eval of exp
+ | Tval of term
+ | Assigned of stmt
+
+module Lvalue =
+struct
+
+ type t = lvalue
+
+ let order = function Eval _ -> 0 | Tval _ -> 1 | Assigned _ -> 2
+
+ let compare a b = if a == b then 0 else match a,b with
+ | Eval x , Eval y -> Exp.compare x y
+ | Tval x , Tval y -> Term.compare x y
+ | Assigned a , Assigned b -> Stmt.compare a b
+ | _ -> order a - order b
+
+ let equal a b = a == b || match a,b with
+ | Eval x , Eval y -> Exp.equal x y
+ | Tval x , Tval y -> Term.equal x y
+ | Assigned a , Assigned b -> Stmt.equal a b
+ | _ -> false
+
+ let pretty fmt = function
+ | Eval x -> Exp.pretty fmt x
+ | Tval t -> Term.pretty fmt t
+ | Assigned { skind = Instr(Set(lv,_,_)) }
+ | Assigned { skind = Instr(Call(Some lv,_,_,_)) } -> Lval.pretty fmt lv
+ | Assigned { skind = Instr(Local_init(x,_,_)) } -> Varinfo.pretty fmt x
+ | Assigned stmt -> Format.fprintf fmt "stmt:s%d" stmt.sid
+
+end
+
+module Mode(OPT : sig val get : unit -> bool end) =
+struct
+ let default = OPT.get
+ let merge a b = if default () then a && b else a || b
+end
+
+module RW = Mode(Wp.Region_rw)
+module Flat = Mode(Wp.Region_flat)
+module Pack = Mode(Wp.Region_pack)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Data Layout --- *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a value =
+ | Int of Ctypes.c_int
+ | Float of Ctypes.c_float
+ | Pointer of 'a
+
+module Value =
+struct
+
+ let compare phi u v =
+ if u == v then 0 else match u,v with
+ | Int a , Int b -> Ctypes.compare_c_int a b
+ | Int _ , _ -> (-1)
+ | _ , Int _ -> 1
+ | Float a , Float b -> Ctypes.compare_c_float a b
+ | Float _ , _ -> (-1)
+ | _ , Float _ -> 1
+ | Pointer ra , Pointer rb -> phi ra rb
+
+ let equal phi a b =
+ match a,b with
+ | Pointer ra , Pointer rb -> phi ra rb
+ | Int a , Int b -> a = b
+ | Float a , Float b -> a = b
+ | _ -> false
+
+ let pretty pp fmt = function
+ | Int iota -> Ctypes.pp_int fmt iota
+ | Float flt -> Ctypes.pp_float fmt flt
+ | Pointer r -> Format.fprintf fmt "ptr(%a)" pp r
+
+ let sizeof = function
+ | Int iota -> Ctypes.i_bits iota
+ | Float flt -> Ctypes.f_bits flt
+ | Pointer _ -> Ctypes.p_bits ()
+
+ let pointed = function
+ | Int _ | Float _ -> None
+ | Pointer r -> Some r
+
+ let merge mu a b =
+ match a,b with
+ | Int i , Int j when i = j -> Some a
+ | Float f , Float g when f = g -> Some a
+ | Pointer r , Pointer r' -> Some(Pointer(mu r r'))
+ | _ -> None
+
+end
+
+module Matrix =
+struct
+
+ let rec gcd a b = if b = 0 then a else gcd b (a mod b)
+
+ 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 "]@]"
+
+ let rec sizeof n = function [] -> n | d::ds -> sizeof (n*d) ds
+
+ let array ds n = if n = 1 then ds else ds @ [n]
+
+ (* Assumes s divides len *)
+ let join_array s len = let n = len / s in if n = 1 then [] else [n]
+
+ (* Assumes s divides len , computes (s,ds) that fits exactly in len
+ with ds maximal prefix of da and db *)
+ 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
+ | _ -> join_array s len
+
+ let rec merge d1 d2 =
+ match d1 , d2 with
+ | n::d1 , n'::d2 when n=n' -> n :: merge d1 d2
+ | _ -> []
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Range & Overlays --- *)
+(* -------------------------------------------------------------------------- *)
+
+let garbled_key = Wp.register_category "garbled"
+
+type dim = Raw of int | Dim of int * int list
+
+type 'a range = {
+ ofs : int ; (* in bits, start from 0 *)
+ len : int ;
+ reg : 'a ;
+ dim : dim ;
+}
+
+type 'a overlay = 'a range list
+
+type 'a merger = raw:bool -> 'a -> 'a -> 'a
+
+module Range =
+struct
+
+ let pp_dim fmt = function
+ | Raw _ -> Format.pp_print_string fmt "raw"
+ | Dim(s,ds) -> Format.fprintf fmt "{%d}%a" s Matrix.pretty ds
+
+ let pretty pp fmt { ofs ; len ; reg ; dim } =
+ Format.fprintf fmt "%d..%d: %a#%a" ofs (ofs+len-1) pp reg pp_dim dim
+
+ let overlap (type a) (_ : a formatter) (mu : a merger) ra rb =
+ let aligned = ref None in
+ let ofs = min ra.ofs rb.ofs in
+ 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 }
+ | _ -> ()
+ end ;
+ match !aligned with
+ | Some rg -> rg
+ | None -> { ofs ; len ; reg = mu ~raw:true ra.reg rb.reg ; dim = Raw len }
+
+ let shift ofs rg = { rg with ofs = rg.ofs + ofs }
+
+ 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) }
+ | _ -> rg
+
+ let included p n { ofs ; len } =
+ ofs <= p && p + n <= ofs + len
+
+end
+
+module Overlay =
+struct
+
+ let pretty ?title pp fmt rs =
+ begin
+ Format.fprintf fmt "@[<hv 0>" ;
+ Extlib.may (fun pp -> pp fmt) title ;
+ Format.fprintf fmt "@[<hov 2>{" ;
+ List.iter
+ (fun rg ->
+ Format.fprintf fmt "@ @[<hov 2>%a@];" (Range.pretty pp) rg
+ ) rs ;
+ Format.fprintf fmt "@]@ }@]" ;
+ end
+
+ let rec merge (pp : 'a formatter) (mu : _ merger) ova ovb =
+ 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 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)
+ | rg :: ovl ->
+ rg :: pack eq ovl
+ | [] -> []
+
+ let flatten ovl = List.map Range.flatten ovl
+
+ let once reg overlay =
+ match List.filter (fun rg -> rg.reg == reg) overlay with
+ | [] | [_] -> true | _ -> false
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Layout --- *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a layout = {
+ sizeof : int ;
+ layout : 'a overlay ;
+}
+
+module Compound =
+struct
+
+ let garbled cache offset reg =
+ let (ofs,len),sizeof = Offset.range cache offset in
+ { sizeof ; layout = [ { ofs ; len ; reg ; dim = Raw len } ] }
+
+ let field cache fd reg dim =
+ let (ofs,len),sizeof = Offset.range_field cache fd in
+ { sizeof ; layout = [ { ofs ; len ; reg ; dim } ] }
+
+ let index te n reg dim =
+ let len = Cil.bitsSizeOf te * n in
+ { sizeof = len ; layout = [ { ofs = 0 ; len ; reg ; dim } ] }
+
+ let reshape ~eq ~flat ~pack { sizeof ; layout } =
+ let ovl = if flat then Overlay.flatten layout else layout in
+ let ovl = if pack then Overlay.pack eq ovl else ovl in
+ { sizeof ; layout = ovl }
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Clustering --- *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a cluster =
+ | Empty
+ | Garbled
+ | Chunk of 'a value
+ | Layout of 'a layout
+
+module Cluster =
+struct
+
+ let is_empty = function Empty -> true | _ -> false
+ let is_garbled = function Garbled -> true | _ -> false
+
+ let pretty pp fmt = function
+ | Empty -> Format.pp_print_string fmt "empty"
+ | 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
+
+ let deref ~pointed (_,typ) =
+ match Cil.unrollType typ with
+ | TInt(ti,_) | TEnum({ ekind = ti },_) -> Chunk (Int (Ctypes.c_int ti))
+ | TFloat(tf,_) -> Chunk (Float (Ctypes.c_float tf))
+ | TPtr _ | TFun _ -> Chunk(Pointer(Lazy.force pointed))
+ | TVoid _ | TNamed _ | TComp _ | TArray _ | TBuiltin_va_list _ -> Empty
+
+ let rec get_dim s rds typ =
+ 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
+ | _ -> 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 = [] }
+ | 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
+ | 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
+ | 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
+ | 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)
+ | 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 shift cache pp offset reg ~inline cluster =
+ match shift_may cache pp offset reg ~inline cluster
+ with Some ovl -> ovl
+ | None -> Compound.garbled cache offset reg
+
+ let do_merge pp (mu : 'a merger) (a : 'a cluster) (b : 'a cluster) =
+ 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
+ | 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 }
+ | Layout { sizeof ; layout = la } ,
+ Layout { sizeof = s ; layout = lb }
+ when s = sizeof ->
+ let layout = Overlay.merge pp mu la lb in
+ Layout { sizeof ; layout }
+ | _ -> Garbled
+
+ let merge pp mu a b =
+ let result = do_merge pp mu a b in
+ if result = Garbled && Wp.has_dkey garbled_key then
+ Wp.debug ~dkey:garbled_key
+ "@[<hv 0>Garbled Clusters:@ A=%a@ B=%a@]"
+ (pretty pp) a (pretty pp) b ;
+ result
+
+ let reshape ~eq ~flat ~pack = function
+ | Layout layout when flat || pack ->
+ Layout (Compound.reshape ~eq ~flat ~pack layout)
+ | cluster -> cluster
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Roots --- *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a from =
+ | Fvar of varinfo
+ | Ffield of 'a * int
+ | Findex of 'a
+ | Fderef of 'a
+ | Farray of 'a
+
+type root =
+ | Rnone
+ | Rfield of varinfo * int (* static offset *)
+ | Rindex of varinfo (* any offset rooted at var *)
+ | Rtop
+
+module Root =
+struct
+
+ let pretty fmt = function
+ | Rtop -> Format.pp_print_string fmt "*"
+ | Rnone -> Format.pp_print_string fmt "-"
+ | Rfield(x,0) -> Format.fprintf fmt "&%a" Varinfo.pretty x
+ | Rfield(x,ofs) -> Format.fprintf fmt "&%a+%d" Varinfo.pretty x ofs
+ | Rindex(x) -> Format.fprintf fmt "&%a+(..)" Varinfo.pretty x
+
+ let field ofs = function
+ | Rfield(x,p) -> Rfield(x,p+ofs)
+ | (Rindex _ | Rnone | Rtop) as r -> r
+
+ let index = function
+ | Rfield(x,_) -> Rindex x
+ | (Rindex _ | Rnone | Rtop) as r -> r
+
+ let from ~root = function
+ | Fvar x -> Rfield(x,0)
+ | Ffield(r,ofs) -> field ofs (root r)
+ | Findex r -> index (root r)
+ | Fderef r -> root r
+ | Farray _ -> Rtop
+
+ let merge_var a b = match a,b with
+ | (Rfield(x,_) | Rindex x) ,
+ (Rfield(y,_) | Rindex y)
+ when Varinfo.equal x y -> Some x
+ | _ -> None
+
+ let merge_field x a b = match a,b with
+ | Rfield(_,p) , Rfield(_,q) when p = q -> a
+ | _ -> Rindex x
+
+ let merge a b =
+ if a == b then a else
+ match a,b with
+ | Rnone,s | s,Rnone -> s
+ | Rtop,_ | _,Rtop -> Rtop
+ | _ ->
+ match merge_var a b with
+ | Some x -> merge_field x a b
+ | None -> Rtop
+
+ let indexed = function
+ | Rnone | Rfield _ -> false
+ | Rindex _ | Rtop -> true
+
+ let framed = function
+ | Rfield(x,_) | Rindex x -> not x.vglob && not x.vaddrof (* Cf. MemVar *)
+ | Rnone -> true
+ | Rtop -> false
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Chunks --- *)
+(* -------------------------------------------------------------------------- *)
+
+module R = Qed.Intset
+
+type chunks = R.t
+
+type 'a chunk =
+ | Mref of 'a
+ | Mmem of root * 'a value
+ | Mraw of root * 'a option
+ | Mcomp of chunks * 'a overlay
+
+module Chunk =
+struct
+ let mem = R.mem
+ let empty = R.empty
+ let singleton = R.singleton
+ let union = R.union
+ let union_map f es = List.fold_left (fun w e -> R.union w @@ f e) R.empty es
+ let disjoint a b = not (R.intersect a b)
+ let pretty pp fmt es =
+ begin
+ Format.fprintf fmt "@[<hov 2>{" ;
+ R.iter (fun e -> Format.fprintf fmt "@ %a" pp e) es ;
+ Format.fprintf fmt " }@]" ;
+ end
+end
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/Layout.mli b/src/plugins/wp/Layout.mli
new file mode 100644
index 0000000000000000000000000000000000000000..afb433b20663d8a8cb7970bd70a1049be1906fb2
--- /dev/null
+++ b/src/plugins/wp/Layout.mli
@@ -0,0 +1,284 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(** Region Utilities *)
+
+open Pretty_utils
+open Cil_types
+
+module type Data =
+sig
+ type t
+ val equal : t -> t -> bool
+ val compare : t -> t -> int
+ val pretty : t formatter
+end
+
+(* -------------------------------------------------------------------------- *)
+(** {2 L-Path} *)
+(* -------------------------------------------------------------------------- *)
+
+type offset =
+ | Field of fieldinfo
+ | Index of typ * int
+
+type lvalue = (** Generalized l-values *)
+ | Eval of exp
+ | Tval of term
+ | Assigned of stmt
+
+module Offset :
+sig
+ include Data with type t = offset
+ val index : typ -> offset
+ val field : fieldinfo -> offset
+ val typeof : offset -> typ
+ val typeof_chain : typ -> offset list -> typ
+ val pp_chain : typ -> offset list formatter
+
+ type cache
+ val cache : unit -> cache
+ val field_offset : cache -> fieldinfo -> int * int (* in bits *)
+ val range : cache -> offset -> (int * int) * int (* in bits *)
+ val sizeof : offset -> int (* in bits *)
+end
+
+module Lvalue : Data with type t = lvalue
+
+(* -------------------------------------------------------------------------- *)
+(** {2 Access} *)
+(* -------------------------------------------------------------------------- *)
+
+type alias = NotUsed | NotAliased | Aliased
+type usage = Value | Deref | Array
+type deref = usage * typ
+
+module Alias :
+sig
+ val use : alias -> alias
+ val merge : alias -> alias -> alias
+ val alias : alias -> alias -> alias
+ val is_aliased : alias -> bool
+ val pretty : alias formatter
+end
+
+module Usage :
+sig
+ val pretty : usage formatter
+ val merge : usage -> usage -> usage
+ val is_shifted : usage -> bool
+ val is_aliased : usage -> bool
+end
+
+module Deref : Data with type t = deref
+
+(* -------------------------------------------------------------------------- *)
+(** {2 R-Values} *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a value =
+ | Int of Ctypes.c_int
+ | Float of Ctypes.c_float
+ | Pointer of 'a
+
+module Value :
+sig
+
+ val compare : ('a -> 'a -> int) -> 'a value -> 'a value -> int
+ val equal : ('a -> 'a -> bool) -> 'a value -> 'a value -> bool
+ val pretty : 'a formatter -> 'a value formatter
+
+ val sizeof : 'a value -> int
+ val pointed : 'a value -> 'a option
+
+ val merge : ('a -> 'a -> 'a) -> 'a value -> 'a value -> 'a value option
+
+end
+
+module Matrix :
+sig
+
+ val gcd : int -> int -> int
+ val pretty : int list formatter
+ val sizeof : int -> int list -> int
+ val merge : int list -> int list -> int list
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(** {2 Overlays} *)
+(* -------------------------------------------------------------------------- *)
+
+type dim = Raw of int | Dim of int * int list
+
+type 'a range = private {
+ ofs : int ; (* in bits, start from 0 *)
+ len : int ;
+ reg : 'a ;
+ dim : dim ;
+}
+
+type 'a overlay = 'a range list
+
+type 'a merger = raw:bool -> 'a -> 'a -> 'a
+
+module Range :
+sig
+
+ val pretty : 'a formatter -> 'a range formatter
+ val overlap : 'a formatter -> 'a merger -> 'a range -> 'a range -> 'a range
+ val included : int -> int -> 'a range -> bool
+
+end
+
+module Overlay :
+sig
+
+ val pretty : ?title:(Format.formatter -> unit) ->
+ 'a formatter -> 'a overlay formatter
+ val merge : 'a formatter ->
+ 'a merger -> 'a overlay -> 'a overlay -> 'a overlay
+
+ val once : 'a -> 'a overlay -> bool
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(** {2 Compound Layout} *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a layout = {
+ sizeof : int ;
+ layout : 'a overlay ;
+}
+
+module Compound :
+sig
+
+ val garbled : Offset.cache -> offset -> 'a -> 'a layout
+ val reshape : eq:('a -> 'a -> bool) -> flat:bool -> pack:bool ->
+ 'a layout -> 'a layout
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(** {2 Clustering} *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a cluster =
+ | Empty
+ | Garbled
+ | Chunk of 'a value
+ | Layout of 'a layout
+
+module Cluster :
+sig
+
+ val pretty : 'a formatter -> 'a cluster formatter
+ val deref : pointed:'a Lazy.t -> deref -> 'a cluster
+ val shift : Offset.cache -> 'a formatter ->
+ offset -> 'a -> inline:bool -> 'a cluster -> 'a layout
+ val merge : 'a formatter -> 'a merger -> 'a cluster -> 'a cluster -> 'a cluster
+ val is_empty : 'a cluster -> bool
+ val is_garbled : 'a cluster -> bool
+ val reshape : eq:('a -> 'a -> bool) -> flat:bool -> pack:bool ->
+ 'a cluster -> 'a cluster
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(** {2 Roots} *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a from =
+ | Fvar of varinfo
+ | Ffield of 'a * int
+ | Findex of 'a
+ | Fderef of 'a
+ | Farray of 'a
+
+type root =
+ | Rnone
+ | Rfield of varinfo * int (* static offset *)
+ | Rindex of varinfo (* any offset rooted at var *)
+ | Rtop
+
+module Root :
+sig
+
+ val pretty : root formatter
+ val from : root:('a -> root) -> 'a from -> root
+ val merge : root -> root -> root
+ val indexed : root -> bool
+ val framed : root -> bool
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(** {2 Chunks} *)
+(* -------------------------------------------------------------------------- *)
+
+type chunks = Qed.Intset.t
+
+type 'a chunk =
+ | Mref of 'a (** Constant pointers to region *)
+ | Mmem of root * 'a value (** Aliased values *)
+ | Mraw of root * 'a option (** Bits that may points-to *)
+ | Mcomp of chunks * 'a overlay (** Aliased chunks & overlay *)
+
+module Chunk :
+sig
+ val empty : chunks
+ val singleton : int -> chunks
+ val union : chunks -> chunks -> chunks
+ val disjoint : chunks -> chunks -> bool
+ val union_map : ('a -> chunks) -> 'a list -> chunks
+ val mem : int -> chunks -> bool
+ val pretty : int formatter -> chunks formatter
+end
+
+(* -------------------------------------------------------------------------- *)
+(** {2 Options} *)
+(* -------------------------------------------------------------------------- *)
+
+(** Read-Write access *)
+module RW :
+sig
+ val default : unit -> bool
+ val merge : bool -> bool -> bool
+end
+
+(** Flatten arrays *)
+module Flat :
+sig
+ val default : unit -> bool
+ val merge : bool -> bool -> bool
+end
+
+(** Pack fields *)
+module Pack :
+sig
+ val default : unit -> bool
+ val merge : bool -> bool -> bool
+end
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/LogicAssigns.ml b/src/plugins/wp/LogicAssigns.ml
index 024797e31770826ea1a2ef947e00793690f57e50..8da52bbfe3284f24683773458023027af7e55c15 100644
--- a/src/plugins/wp/LogicAssigns.ml
+++ b/src/plugins/wp/LogicAssigns.ml
@@ -53,7 +53,8 @@ struct
| [] -> Bag.concat (M.Sigma.assigned ~pre:s.pre ~post:s.post D.empty) hs
| [obj,sloc] ->
- let hs_sloc = Bag.list (M.assigned s obj sloc) in
+ 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
@@ -61,7 +62,8 @@ struct
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 hs_sloc = Bag.list (M.assigned s_local obj sloc) 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) =
diff --git a/src/plugins/wp/LogicBuiltins.ml b/src/plugins/wp/LogicBuiltins.ml
index 7e0b7b17c2b8a2a4fbe785bf7110f4950f15e443..fff1b748fed5e2ca7d55c098b84beb803e30639b 100644
--- a/src/plugins/wp/LogicBuiltins.ml
+++ b/src/plugins/wp/LogicBuiltins.ml
@@ -264,7 +264,7 @@ let add_option ~driver_dir group name ~library value =
let find_lib file =
if Sys.file_exists file then file else
let rec lookup file = function
- | [] -> Wp_parameters.abort "File '%s' not found (see -wp-include)" file
+ | [] -> 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
diff --git a/src/plugins/wp/LogicSemantics.ml b/src/plugins/wp/LogicSemantics.ml
index 52ad3beab41cc463a048aa1743a95bb55a318b2f..146dc9732866d70dadffce752605936ea23045af 100644
--- a/src/plugins/wp/LogicSemantics.ml
+++ b/src/plugins/wp/LogicSemantics.ml
@@ -77,29 +77,6 @@ struct
let status = C.status
let guards = C.guards
- (* -------------------------------------------------------------------------- *)
- (* --- Debugging --- *)
- (* -------------------------------------------------------------------------- *)
-
- let pp_logic fmt = function
- | Vexp e -> F.pp_term fmt e
- | Vloc l -> M.pretty fmt l
- | Lset _ | Vset _ -> Format.pp_print_string fmt "<set>"
-
- let pp_bound fmt = function None -> () | Some p -> F.pp_term fmt p
-
- let pp_sloc fmt = function
- | Sloc l -> M.pretty fmt l
- | Sarray(l,_,n) -> Format.fprintf fmt "@[<hov2>%a@,.(..%d)@]"
- M.pretty l (n-1)
- | Srange(l,_,a,b) -> Format.fprintf fmt "@[<hov2>%a@,.(%a@,..%a)@]"
- M.pretty l pp_bound a pp_bound b
- | Sdescr(xs,l,p) -> Format.fprintf fmt "@[<hov2>{ %a | %a }@]"
- M.pretty l F.pp_pred (F.p_forall xs p)
-
- let pp_region fmt sloc =
- List.iter (fun (_,s) -> Format.fprintf fmt "@ %a" pp_sloc s) sloc
-
(* -------------------------------------------------------------------------- *)
(* --- Translation Environment & Recursion --- *)
(* -------------------------------------------------------------------------- *)
@@ -261,7 +238,7 @@ struct
match logic_var env lv with
| VAL v ->
Wp_parameters.abort ~current:true
- "Address of logic value (%a)@." pp_logic v
+ "Address of logic value (%a)@." (Cvalues.pp_logic M.pretty) v
| VAR x ->
logic_offset env x.vtype (Vloc (M.cvar x)) loffset
end
@@ -663,6 +640,7 @@ struct
(* -------------------------------------------------------------------------- *)
(* --- Term Nodes --- *)
(* -------------------------------------------------------------------------- *)
+
let term_node (env:env) t =
match t.term_node with
| TConst c -> Vexp (Cvalues.logic_constant c)
@@ -674,7 +652,16 @@ struct
Cvalues.volatile ~warn:"unsafe volatile access to (term) l-value" ()
then term_undefined t
else term_lval env lval
- | TAddrOf lval | TStartOf lval -> addr_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
| TUnOp(Neg,t) when not (Logic_typing.is_integral_type t.term_type) ->
L.map F.e_opp (C.logic env t)
diff --git a/src/plugins/wp/Makefile.in b/src/plugins/wp/Makefile.in
index 700675e62b85cd73ce33bf43d4dad80af0525a23..c4d82ec1ddebe78e7601bcfaebcb2a6a3d6487a3 100644
--- a/src/plugins/wp/Makefile.in
+++ b/src/plugins/wp/Makefile.in
@@ -65,10 +65,12 @@ PLUGIN_CMO:= \
Why3Provers \
Context Warning MemoryContext wpContext \
LogicUsage RefUsage \
+ Layout Region \
+ RegionAnnot RegionAccess RegionDump RegionAnalysis \
cil2cfg normAtLabels wpPropId mcfg \
Lang Repr Matrix Passive Splitter \
LogicBuiltins Definitions \
- Cmath Cint Cfloat Vset Vlist Region Cstring Cvalues \
+ Cmath Cint Cfloat Vset Vlist Cstring Cvalues \
Letify Cleaning \
Sigs Mstate Conditions \
Filtering \
@@ -76,7 +78,9 @@ PLUGIN_CMO:= \
CodeSemantics \
LogicCompiler \
LogicSemantics LogicAssigns \
- Sigma MemEmpty MemZeroAlias MemVar MemTyped \
+ Sigma MemLoader \
+ MemEmpty MemZeroAlias MemVar \
+ MemMemory MemTyped MemRegion \
wpStrategy wpRTE wpAnnot \
CfgCompiler StmtSemantics \
VCS script proof wpo wpReport \
@@ -126,7 +130,8 @@ CEA_WP_GENEREATED= script.ml rformat.ml driver.ml
PLUGIN_TESTS_DIRS:= \
wp wp_plugin wp_acsl wp_bts \
wp_store wp_hoare wp_typed wp_usage \
- wp_gallery wp_manual wp_tip
+ wp_gallery wp_manual wp_tip \
+ wp_region
ifeq ($(FRAMAC_INTERNAL),yes)
Wp_DEFAULT_TESTS: create_share_link
diff --git a/src/plugins/wp/MemLoader.ml b/src/plugins/wp/MemLoader.ml
new file mode 100644
index 0000000000000000000000000000000000000000..b9fb6bf805e2fe03b3a70e43473957ac2fc9fbb7
--- /dev/null
+++ b/src/plugins/wp/MemLoader.ml
@@ -0,0 +1,370 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Memory Model --- *)
+(* -------------------------------------------------------------------------- *)
+
+open Cil_types
+open Cil_datatype
+open Definitions
+open Ctypes
+open Lang
+open Lang.F
+open Sigs
+
+(* -------------------------------------------------------------------------- *)
+(* --- Compound Loader --- *)
+(* -------------------------------------------------------------------------- *)
+
+let cluster () =
+ Definitions.cluster ~id:"Compound" ~title:"Memory Compound Loader" ()
+
+module type Model =
+sig
+
+ module Chunk : Chunk
+ module Sigma : Sigma with type chunk = Chunk.t
+
+ val name : string
+
+ type loc
+ val sizeof : c_object -> int
+ val field : loc -> fieldinfo -> loc
+ val shift : loc -> c_object -> term -> loc
+
+ val to_addr : loc -> term
+ val to_region_pointer : loc -> int * term
+ val of_region_pointer : int -> c_object -> term -> loc
+
+ val domain : c_object -> loc -> Sigma.domain
+ val frames : c_object -> loc -> Chunk.t -> frame list
+
+ val last : Sigma.t -> c_object -> loc -> term
+
+ val havoc : c_object -> loc -> length:term ->
+ Chunk.t -> fresh:term -> current:term -> term
+
+ val eqmem : c_object -> loc -> Chunk.t -> term -> term -> pred
+
+ val eqmem_forall :
+ c_object -> loc -> Chunk.t -> term -> term -> var list * pred * pred
+
+ val load_int : Sigma.t -> c_int -> loc -> term
+ val load_float : Sigma.t -> c_float -> loc -> term
+ val load_pointer : Sigma.t -> typ -> loc -> loc
+
+ val store_int : Sigma.t -> c_int -> loc -> term -> Chunk.t * term
+ val store_float : Sigma.t -> c_float -> loc -> term -> Chunk.t * term
+ val store_pointer : Sigma.t -> typ -> loc -> term -> Chunk.t * term
+
+end
+
+module Make (M : Model) =
+struct
+
+ type chunk = M.Chunk.t
+
+ module Chunk = M.Chunk
+ module Sigma = M.Sigma
+ module Domain = M.Sigma.Chunk.Set
+
+ let signature ft =
+ let s = Sigma.create () in
+ let xs = ref [] in
+ let cs = ref [] in
+ Domain.iter
+ (fun c ->
+ cs := c :: !cs ;
+ xs := (Sigma.get s c) :: !xs ;
+ ) ft ;
+ List.rev !xs , List.rev !cs , s
+
+ let pp_rid fmt r = if r <> 0 then Format.fprintf fmt "_R%03d" r
+
+ let loadrec = ref (fun _ _ _ -> assert false)
+
+ (* -------------------------------------------------------------------------- *)
+ (* --- Frame Lemmas for Compound Access --- *)
+ (* -------------------------------------------------------------------------- *)
+
+ let memories sigma chunks = List.map (Sigma.value sigma) chunks
+ let assigned sigma c m chunks =
+ List.map
+ (fun c0 -> if Chunk.equal c0 c then m else Sigma.value sigma c0)
+ chunks
+
+ let frame_lemmas phi obj loc params chunks =
+ begin
+ let prefix = Fun.debug phi in
+ let sigma = Sigma.create () in
+ List.iter
+ (fun chunk ->
+ List.iter
+ (fun (name,triggers,conditions,m1,m2) ->
+ let mem1 = assigned sigma chunk m1 chunks in
+ let mem2 = assigned sigma chunk m2 chunks in
+ let value1 = e_fun phi (params @ mem1) in
+ let value2 = e_fun phi (params @ mem2) in
+ let vars1 = F.vars value1 in
+ let vars2 = F.vars value2 in
+ let l_triggers =
+ if Vars.subset vars1 vars2 then
+ [ (Trigger.of_term value2 :: triggers ) ]
+ else
+ if Vars.subset vars2 vars1 then
+ [ (Trigger.of_term value1 :: triggers ) ]
+ else
+ [ (Trigger.of_term value1 :: triggers );
+ (Trigger.of_term value2 :: triggers ) ]
+ in
+ let l_name = Pretty_utils.sfprintf "%s_%s_%a"
+ prefix name Chunk.pretty chunk in
+ let l_lemma = F.p_hyps conditions (p_equal value1 value2) in
+ Definitions.define_lemma {
+ l_assumed = true ;
+ l_name ; l_types = 0 ;
+ l_triggers ;
+ l_forall = F.p_vars l_lemma ;
+ l_lemma = l_lemma ;
+ l_cluster = cluster () ;
+ }
+ ) (M.frames obj loc chunk)
+ ) chunks
+ end
+
+ (* -------------------------------------------------------------------------- *)
+ (* --- Compound Loader --- *)
+ (* -------------------------------------------------------------------------- *)
+
+ module COMP_KEY =
+ struct
+ type t = int * compinfo
+ let compare (r,c) (r',c') = if r=r' then Compinfo.compare c c' else r-r'
+ let pretty fmt (r,c) = Format.fprintf fmt "%d:%a" r Compinfo.pretty c
+ end
+
+ module COMP = WpContext.Generator(COMP_KEY)
+ (struct
+ let name = M.name ^ ".COMP"
+ type key = int * compinfo
+ type data = lfun * chunk list
+
+ let generate (r,c) =
+ let x = Lang.freshvar ~basename:"p" (Lang.t_addr()) in
+ let v = e_var x in
+ let obj = C_comp c in
+ let loc = M.of_region_pointer r obj v in (* t_pointer -> loc *)
+ let domain = M.domain obj loc in
+ let result = Lang.tau_of_comp c in
+ let lfun = Lang.generated_f ~result "Load%a_%s" pp_rid r (Lang.comp_id c) in
+ (* Since its a generated it is the unique name given *)
+ let xms,chunks,sigma = signature domain in
+ let def = List.map
+ (fun f ->
+ Cfield f , !loadrec sigma (object_of f.ftype) (M.field loc f)
+ ) c.cfields in
+ let dfun = Definitions.Function( result , Def , e_record def ) in
+ Definitions.define_symbol {
+ d_lfun = lfun ; d_types = 0 ;
+ d_params = x :: xms ;
+ d_definition = dfun ;
+ d_cluster = cluster () ;
+ } ;
+ frame_lemmas lfun obj loc [v] chunks ;
+ lfun , chunks
+
+ let compile = Lang.local generate
+ end)
+
+ (* -------------------------------------------------------------------------- *)
+ (* --- Array Loader --- *)
+ (* -------------------------------------------------------------------------- *)
+
+ module ARRAY_KEY =
+ struct
+ type t = int * arrayinfo * Matrix.matrix
+ let pretty fmt (r,_,m) =
+ Format.fprintf fmt "%d:%a" r Matrix.NATURAL.pretty m
+ let compare (r1,_,m1) (r2,_,m2) =
+ if r1 = r2 then Matrix.NATURAL.compare m1 m2 else r1-r2
+ end
+
+ module ARRAY = WpContext.Generator(ARRAY_KEY)
+ (struct
+ open Matrix
+ let name = M.name ^ ".ARRAY"
+ type key = int * arrayinfo * Matrix.matrix
+ type data = lfun * chunk list
+
+ let generate (r,ainfo,(obj_e,ds)) =
+ let x = Lang.freshvar ~basename:"p" (Lang.t_addr()) in
+ let v = e_var x in
+ let obj_a = C_array ainfo in
+ let loc = M.of_region_pointer r obj_a v in (* t_pointer -> loc *)
+ let domain = M.domain obj_a loc in
+ let result = Matrix.tau obj_e ds in
+ let lfun = Lang.generated_f ~result "Array%a%s_%s" pp_rid r
+ (Matrix.id ds) (Matrix.natural_id obj_e) in
+ let prefix = Lang.Fun.debug lfun in
+ let axiom = prefix ^ "_access" in
+ let xmem,chunks,sigma = signature domain in
+ let denv = Matrix.denv ds in
+ let phi = e_fun lfun (v :: denv.size_val @ List.map e_var xmem) in
+ let va = List.fold_left e_get phi denv.index_val in
+ let ofs = e_sum denv.index_offset in
+ let vm = !loadrec sigma obj_e (M.shift loc obj_e ofs) in
+ let lemma = p_hyps denv.index_range (p_equal va vm) in
+ let cluster = cluster () in
+ Definitions.define_symbol {
+ d_lfun = lfun ; d_types = 0 ;
+ d_params = x :: denv.size_var @ xmem ;
+ d_definition = Logic result ;
+ d_cluster = cluster ;
+ } ;
+ Definitions.define_lemma {
+ l_assumed = true ;
+ l_name = axiom ; l_types = 0 ;
+ l_forall = F.p_vars lemma ;
+ l_triggers = [[Trigger.of_term va]] ;
+ l_lemma = lemma ;
+ l_cluster = cluster ;
+ } ;
+ if denv.monotonic then
+ begin
+ let ns = List.map F.e_var denv.size_var in
+ frame_lemmas lfun obj_a loc (v::ns) chunks
+ end ;
+ lfun , chunks
+
+ let compile = Lang.local generate
+ end)
+
+ (* -------------------------------------------------------------------------- *)
+ (* --- Loader --- *)
+ (* -------------------------------------------------------------------------- *)
+
+ let load_comp sigma comp loc =
+ let r , p = M.to_region_pointer loc in
+ let f , m = COMP.get (r,comp) in
+ F.e_fun f (p :: memories sigma m)
+
+ let load_array sigma a loc =
+ let d = Matrix.of_array a in
+ let r , p = M.to_region_pointer loc in
+ let f , m = ARRAY.get (r,a,d) in
+ F.e_fun f (p :: Matrix.size d @ memories sigma m)
+
+ let loadvalue sigma obj loc =
+ match obj with
+ | C_int i -> M.load_int sigma i loc
+ | C_float f -> M.load_float sigma f loc
+ | C_pointer t -> snd @@ M.to_region_pointer @@ M.load_pointer sigma t loc
+ | C_comp c -> load_comp sigma c loc
+ | C_array a -> load_array sigma a loc
+
+ let load sigma obj loc =
+ let open Sigs in
+ match obj with
+ | C_int i -> Val (M.load_int sigma i loc)
+ | C_float f -> Val (M.load_float sigma f loc)
+ | C_pointer t -> Loc (M.load_pointer sigma t loc)
+ | C_comp c -> Val (load_comp sigma c loc)
+ | C_array a -> Val (load_array sigma a loc)
+
+ let () = loadrec := loadvalue
+
+ (* -------------------------------------------------------------------------- *)
+ (* --- Havocs --- *)
+ (* -------------------------------------------------------------------------- *)
+
+ let havoc_length s obj loc length =
+ let ps = ref [] in
+ Domain.iter
+ (fun chunk ->
+ let pre = Sigma.value s.pre chunk in
+ let post = Sigma.value s.post chunk in
+ let tau = Chunk.tau_of_chunk chunk in
+ let basename = Chunk.basename_of_chunk chunk ^ "_undef" in
+ let fresh = F.e_var (Lang.freshvar ~basename tau) in
+ let havoc = M.havoc obj loc ~length chunk ~fresh ~current:pre in
+ ps := Set(post,havoc) :: !ps
+ ) (M.domain obj loc) ; !ps
+
+ let havoc seq obj loc = havoc_length seq obj loc F.e_one
+
+ (* -------------------------------------------------------------------------- *)
+ (* --- Stored & Copied --- *)
+ (* -------------------------------------------------------------------------- *)
+
+ let updated seq phi alpha loc value =
+ let chunk,mem = phi seq.pre alpha loc value in
+ [Set(Sigma.value seq.post chunk,mem)]
+
+ let stored seq obj loc value =
+ match obj with
+ | C_int i -> updated seq M.store_int i loc value
+ | C_float f -> updated seq M.store_float f loc value
+ | C_pointer ty -> updated seq M.store_pointer ty loc value
+ | C_comp _ | C_array _ ->
+ Set(loadvalue seq.post obj loc, value) :: havoc seq obj loc
+
+ let copied s obj p q = stored s obj p (loadvalue s.pre obj q)
+
+ (* -------------------------------------------------------------------------- *)
+ (* --- Assigned --- *)
+ (* -------------------------------------------------------------------------- *)
+
+ let assigned_loc seq obj loc =
+ match obj with
+ | C_int _ | C_float _ | C_pointer _ ->
+ let x = Lang.freshvar ~basename:"v" (Lang.tau_of_object obj) in
+ stored seq obj loc (e_var x)
+ | C_comp _ | C_array _ ->
+ havoc seq obj loc
+
+ let assigned_range s obj l a b =
+ havoc_length s obj (M.shift l obj a) (e_range a b)
+
+ let assigned seq obj = function
+ | 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
+ ) (M.domain obj loc) ; !ps
+ | Sarray(loc,obj,n) ->
+ 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
+
+ (* -------------------------------------------------------------------------- *)
+
+end
diff --git a/src/plugins/wp/MemLoader.mli b/src/plugins/wp/MemLoader.mli
new file mode 100644
index 0000000000000000000000000000000000000000..ddc2677cbc01eff8c56b345c59582ab40f103109
--- /dev/null
+++ b/src/plugins/wp/MemLoader.mli
@@ -0,0 +1,95 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+
+(** Compound Loader *)
+
+open Cil_types
+open Definitions
+open Ctypes
+open Lang.F
+open Sigs
+
+val cluster : unit -> cluster
+
+(** Loader Model for Atomic Values *)
+module type Model =
+sig
+
+ module Chunk : Chunk
+ module Sigma : Sigma with type chunk = Chunk.t
+
+ val name : string
+
+ type loc
+ val sizeof : c_object -> int
+ val field : loc -> fieldinfo -> loc
+ val shift : loc -> c_object -> term -> loc
+
+ (** Conversion among loc, t_pointer terms and t_addr terms *)
+
+ val to_addr : loc -> term
+ val to_region_pointer : loc -> int * term
+ val of_region_pointer : int -> c_object -> term -> loc
+
+ val domain : c_object -> loc -> Sigma.domain
+ val frames : c_object -> loc -> Chunk.t -> frame list
+
+ val last : Sigma.t -> c_object -> loc -> term
+
+ val havoc : c_object -> loc -> length:term ->
+ Chunk.t -> fresh:term -> current:term -> term
+
+ val eqmem : c_object -> loc -> Chunk.t -> term -> term -> pred
+
+ val eqmem_forall :
+ c_object -> loc -> Chunk.t -> term -> term -> var list * pred * pred
+
+ val load_int : Sigma.t -> c_int -> loc -> term
+ val load_float : Sigma.t -> c_float -> loc -> term
+ val load_pointer : Sigma.t -> typ -> loc -> loc
+
+ val store_int : Sigma.t -> c_int -> loc -> term -> Chunk.t * term
+ val store_float : Sigma.t -> c_float -> loc -> term -> Chunk.t * term
+ val store_pointer : Sigma.t -> typ -> loc -> term -> Chunk.t * term
+
+end
+
+(** Generates Loader for Compound Values *)
+module Make (M : Model) :
+sig
+
+ val load : M.Sigma.t -> c_object -> M.loc -> M.loc Sigs.value
+ val loadvalue : M.Sigma.t -> c_object -> M.loc -> term
+
+ val havoc : M.Sigma.t sequence -> c_object -> M.loc -> equation list
+ val havoc_length : M.Sigma.t sequence -> c_object -> M.loc -> term -> equation list
+
+ val stored : M.Sigma.t sequence -> c_object -> M.loc -> term -> equation list
+ val copied : M.Sigma.t sequence -> c_object -> M.loc -> M.loc -> equation list
+
+ val assigned : M.Sigma.t sequence -> c_object -> M.loc sloc -> equation list
+
+end
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/MemMemory.ml b/src/plugins/wp/MemMemory.ml
new file mode 100644
index 0000000000000000000000000000000000000000..3297bfdd33e5d765bec98e4957292dc31982f31a
--- /dev/null
+++ b/src/plugins/wp/MemMemory.ml
@@ -0,0 +1,427 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Memory Model --- *)
+(* -------------------------------------------------------------------------- *)
+
+open Lang
+open Lang.F
+
+module L = Qed.Logic
+
+let library = "memory"
+
+let a_addr = Lang.datatype ~library "addr"
+let t_addr = L.Data(a_addr,[])
+let f_base = Lang.extern_f ~library ~result:L.Int
+ ~link:{altergo = Qed.Engine.F_subst("%1.base");
+ why3 = Qed.Engine.F_call "base";
+ coq = Qed.Engine.F_subst("(base %1)");
+ } "base"
+let f_offset = Lang.extern_f ~library ~result:L.Int
+ ~link:{altergo = Qed.Engine.F_subst("%1.offset");
+ why3 = Qed.Engine.F_call "offset";
+ coq = Qed.Engine.F_subst("(offset %1)");
+ } "offset"
+let f_shift = Lang.extern_f ~library ~result:t_addr "shift"
+let f_global = Lang.extern_f ~library ~result:t_addr ~category:L.Injection "global"
+let f_null = Lang.extern_f ~library ~result:t_addr "null"
+
+let f_base_offset = Lang.extern_f ~library
+ ~category:Qed.Logic.Injection ~result:L.Int "base_offset"
+
+let ty_havoc = function
+ | Some l :: _ -> l
+ | _ -> raise Not_found
+
+let l_havoc = Qed.Engine.{
+ coq = F_call "fhavoc" ;
+ altergo = F_call "havoc" ;
+ why3 = F_call "havoc" ;
+ }
+
+let p_valid_rd = Lang.extern_fp ~library "valid_rd"
+let p_valid_rw = Lang.extern_fp ~library "valid_rw"
+let p_invalid = Lang.extern_fp ~library "invalid"
+let p_separated = Lang.extern_fp ~library "separated"
+let p_included = Lang.extern_fp ~library "included"
+let p_eqmem = Lang.extern_fp ~library "eqmem"
+let f_havoc = Lang.extern_f ~library ~typecheck:ty_havoc ~link:l_havoc "havoc"
+let f_region = Lang.extern_f ~library ~result:L.Int "region" (* base -> region *)
+let p_framed = Lang.extern_fp ~library "framed" (* m-pointer -> prop *)
+let p_linked = Lang.extern_fp ~library "linked" (* allocation-table -> prop *)
+let p_sconst = Lang.extern_fp ~library "sconst" (* int-memory -> prop *)
+let p_addr_lt = Lang.extern_p ~library ~bool:"addr_lt_bool" ~prop:"addr_lt" ()
+let p_addr_le = Lang.extern_p ~library ~bool:"addr_le_bool" ~prop:"addr_le" ()
+
+let f_addr_of_int = Lang.extern_f
+ ~category:L.Injection
+ ~library ~result:t_addr "addr_of_int"
+
+let f_int_of_addr = Lang.extern_f
+ ~category:L.Injection
+ ~library ~result:L.Int "int_of_addr"
+
+(* -------------------------------------------------------------------------- *)
+(* --- Utilities --- *)
+(* -------------------------------------------------------------------------- *)
+
+let t_mem t = L.Array(t_addr,t)
+let t_malloc = L.Array(L.Int,L.Int)
+
+let a_null = F.constant (e_fun f_null [])
+let a_base p = e_fun f_base [p]
+let a_offset p = e_fun f_offset [p]
+let a_global b = e_fun f_global [b]
+let a_shift l k = e_fun f_shift [l;k]
+let a_addr b k = a_shift (a_global b) k
+let a_base_offset k = e_fun f_base_offset [k]
+
+(* -------------------------------------------------------------------------- *)
+(* --- Qed Simplifiers --- *)
+(* -------------------------------------------------------------------------- *)
+
+(*
+ Pointer arithmetic for structure access and array access could be
+ defined directly using the record [{ base = p.base; offset = p.offset
+ + c*i + c' }]. However that gives very bad triggers for the memory
+ model axiomatization, so `shift p (c*i+c')` was used instead. It is
+ not sufficient for user axiomatisation because memory access in
+ axioms require trigger with arithmetic operators which is badly
+ handled by provers. So for each c and c', ie for each kind of
+ structure access and array access a specific function is used
+ `shift_xxx`.
+
+ Moreover no simplification of `shift_xxx` is done for keeping the
+ same terms in axioms and the goal. `base` and `offset` function
+ simplify all the `shift_xxx` because it seems they don't appear
+ often in axioms and they are useful for simplifying `separated`,
+ `assigns` and pointer comparisons in goals.
+
+ To sum up memory access should match, but not `\base`, `\offset`,
+ `\separated`, ...
+*)
+
+type addr_builtin = {
+ base: term list -> term ;
+ offset: term list -> term ;
+}
+
+module ADDR_BUILTIN = WpContext.Static
+ (struct
+ type key = lfun
+ type data = addr_builtin
+ let name = "MemMemory.ADDR_BUILTIN"
+ include Lang.Fun
+ end)
+
+let phi_base l =
+ match F.repr l with
+ | L.Fun(f,[p;_]) when f==f_shift -> a_base p
+ | L.Fun(f,[b]) when f==f_global -> b
+ | L.Fun(f,[]) when f==f_null -> e_zero
+ | L.Fun(f,args) -> (ADDR_BUILTIN.find f).base args
+ | _ -> raise Not_found
+
+let phi_offset l = match F.repr l with
+ | L.Fun(f,[p;k]) when f==f_shift -> e_add (a_offset p) k
+ | L.Fun(f,_) when f==f_global || f==f_null -> F.e_zero
+ | L.Fun(f,args) -> (ADDR_BUILTIN.find f).offset args
+ | _ -> raise Not_found
+
+let phi_shift f p i =
+ match F.repr p with
+ | L.Fun(g,[q;j]) when f == g -> F.e_fun f [q;F.e_add i j]
+ | _ -> raise Not_found
+
+let eq_shift a b =
+ let p = a_base a in
+ let q = a_base b in
+ let i = a_offset a in
+ let j = a_offset b in
+ if i==j then F.p_equal p q else
+ match F.is_equal p q with
+ | L.No -> F.p_false
+ | L.Yes -> F.p_equal i j
+ | L.Maybe -> raise Not_found
+
+let eq_shift_gen phi a b =
+ try phi a b with Not_found -> eq_shift a b
+
+let nop _ = raise Not_found
+
+let register ?(base=nop) ?(offset=nop) ?equal ?(linear=false) lfun =
+ begin
+ if base != nop || offset != nop then
+ ADDR_BUILTIN.define lfun { base ; offset } ;
+ if linear then
+ F.set_builtin_2 lfun (phi_shift lfun) ;
+ let phi_equal = match equal with
+ | None -> eq_shift
+ | Some phi -> eq_shift_gen phi
+ in
+ F.set_builtin_eqp lfun phi_equal ;
+ end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Simplifier for 'separated' --- *)
+(* -------------------------------------------------------------------------- *)
+
+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
+ | _ -> raise Not_found
+
+let is_separated args = F.is_true (r_separated args)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Simplifier for 'included' --- *)
+(* -------------------------------------------------------------------------- *)
+
+(*
+logic a : int
+logic b : int
+
+predicate R = p.base = q.base
+ /\ (q.offset <= p.offset)
+ /\ (p.offset + a <= q.offset + b)
+
+predicate included = 0 < a -> ( 0 <= b and R )
+predicate a_empty = a <= 0
+predicate b_negative = b < 0
+
+lemma SAME_P: p=q -> (R <-> a<=b)
+lemma SAME_A: a=b -> (R <-> p=q)
+
+goal INC_P: p=q -> (included <-> ( 0 < a -> a <= b )) (by SAME_P)
+goal INC_A: a=b -> 0 < a -> (included <-> R) (by SAME_A)
+goal INC_1: a_empty -> (included <-> true)
+goal INC_2: b_negative -> (included <-> a_empty)
+goal INC_3: not R -> (included <-> a_empty)
+goal INC_4: not a_empty -> not b_negative -> (included <-> R)
+*)
+
+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
+ | _ -> raise Not_found
+
+(* -------------------------------------------------------------------------- *)
+(* --- Simplifier for 'havoc' --- *)
+(* -------------------------------------------------------------------------- *)
+
+(* havoc(m_undef, havoc(_undef,m0,p0,a0), p1,a1) =
+ - havoc(m_undef, m0, p1,a1) WHEN included (p1,a1,p0,a0) *)
+let r_havoc = function
+ | [undef1;m1;p1;a1] -> begin
+ match F.repr m1 with
+ | L.Fun( f , [_undef0;m0;p0;a0] ) when f == f_havoc -> begin
+ let open Qed.Logic in
+ match F.is_true (r_included [p0;a0;p1;a1]) with
+ | Yes -> F.e_fun f_havoc [undef1;m0;p1;a1]
+ | _ -> raise Not_found
+ end
+ | _ -> raise Not_found
+ end
+ | _ -> raise Not_found
+
+(* havoc(undef,m,p,a)[k] =
+ - undef[k] WHEN separated (p,a,k,1)
+ - m[k] WHEN NOT separated (p,a,k,1)
+*)
+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)
+ | _ -> raise Not_found
+
+(* -------------------------------------------------------------------------- *)
+(* --- Simplifier for int/addr conversion --- *)
+(* -------------------------------------------------------------------------- *)
+
+let phi_int_of_addr p =
+ if p == a_null then F.e_zero else
+ match F.repr p with
+ | L.Fun(f,[a]) when f == f_addr_of_int -> a
+ | _ -> raise Not_found
+
+let phi_addr_of_int p =
+ if p == F.e_zero then a_null else
+ match F.repr p with
+ | L.Fun(f,[a]) when f == f_int_of_addr -> a
+ | _ -> raise Not_found
+
+(* -------------------------------------------------------------------------- *)
+(* --- Simplifiers Registration --- *)
+(* -------------------------------------------------------------------------- *)
+
+let () = Context.register
+ begin fun () ->
+ F.set_builtin_1 f_base phi_base ;
+ F.set_builtin_1 f_offset phi_offset ;
+ F.set_builtin_2 f_shift (phi_shift f_shift) ;
+ F.set_builtin_eqp f_shift eq_shift ;
+ F.set_builtin_eqp f_global eq_shift ;
+ F.set_builtin p_separated r_separated ;
+ F.set_builtin p_included r_included ;
+ F.set_builtin f_havoc r_havoc ;
+ F.set_builtin_get f_havoc r_get_havoc ;
+ F.set_builtin_1 f_addr_of_int phi_addr_of_int ;
+ F.set_builtin_1 f_int_of_addr phi_int_of_addr ;
+ end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Frame Conditions --- *)
+(* -------------------------------------------------------------------------- *)
+
+module T = Definitions.Trigger
+
+let frames ~addr:p ~offset:n ~sizeof:s ?(basename="mem") tau =
+ let t_mem = L.Array(t_addr,tau) in
+ let m = F.e_var (Lang.freshvar ~basename t_mem) in
+ let m' = F.e_var (Lang.freshvar ~basename t_mem) in
+ let p' = F.e_var (Lang.freshvar ~basename:"q" t_addr) in
+ let n' = F.e_var (Lang.freshvar ~basename:"n" L.Int) in
+ let mh = F.e_fun f_havoc [m';m;p';n'] in
+ let v' = F.e_var (Lang.freshvar ~basename:"v" tau) in
+ let meq = F.p_call p_eqmem [m;m';p';n'] in
+ let diff = F.p_call p_separated [p;n;p';s] in
+ let sep = F.p_call p_separated [p;n;p';n'] in
+ let inc = F.p_call p_included [p;n;p';n'] in
+ let teq = T.of_pred meq in
+ [
+ "update" , [] , [diff] , m , e_set m p' v' ;
+ "eqmem" , [teq] , [inc;meq] , m , m' ;
+ "havoc" , [] , [sep] , m , mh ;
+ ]
+
+(* -------------------------------------------------------------------------- *)
+(* --- Range Comparison --- *)
+(* -------------------------------------------------------------------------- *)
+
+type range =
+ | LOC of term * term (* loc - size *)
+ | RANGE of term * Vset.set (* base - range offset *)
+
+let range ~shift ~addrof ~sizeof = function
+ | Sigs.Rloc(obj,loc) ->
+ LOC( addrof loc , F.e_int (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_fact s (e_range a b) in
+ LOC( p , n )
+ | Sigs.Rrange(loc,_obj,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_fact 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_fact 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)
+ | 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]
+ | _ ->
+ 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]
+ | _ ->
+ 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
+ r_included (range s1) (range s2)
+
+let separated ~shift ~addrof ~sizeof s1 s2 =
+ let range = range ~shift ~addrof ~sizeof in
+ r_disjoint (range s1) (range s2)
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/MemMemory.mli b/src/plugins/wp/MemMemory.mli
new file mode 100644
index 0000000000000000000000000000000000000000..557ab0826a150e92ab99d14fe0b06dc0c5fe8324
--- /dev/null
+++ b/src/plugins/wp/MemMemory.mli
@@ -0,0 +1,118 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Memory Theory --- *)
+(* -------------------------------------------------------------------------- *)
+
+open Lang
+open Lang.F
+
+(** {2 Theory} *)
+
+val t_addr : tau
+val t_malloc : tau (** allocation tables *)
+val t_mem : tau -> tau (** t_addr indexed array *)
+
+val a_null : term (** Null address. Same as [a_addr 0 0] *)
+val a_global : term -> term (** Zero-offset base. Same as [a_addr base 0] *)
+val a_addr : term -> term -> term (** Constructor for [{ base ; offset }] *)
+val a_shift : term -> term -> term (** Shift: [a_shift a k] adds [k] to [a.offset] *)
+val a_base : term -> term (** Returns the base *)
+val a_offset : term -> term (** Returns the offset *)
+val a_base_offset : term -> term
+(** Returns the offset in {i bytes} from the {i logic} offset
+ (which is a memory cell index, actually) *)
+
+val f_null : lfun
+val f_base : lfun
+val f_global : lfun
+val f_shift : lfun
+val f_offset : lfun
+val f_havoc : lfun
+val f_region : lfun
+val f_addr_of_int : lfun (** Physical address *)
+val f_int_of_addr : lfun (** Physical address *)
+
+val p_addr_lt : lfun
+val p_addr_le : lfun
+val p_linked : lfun
+val p_framed : lfun
+val p_sconst : lfun
+val p_separated : lfun
+val p_included : lfun
+val p_valid_rd : lfun
+val p_valid_rw : lfun
+val p_invalid : lfun
+val p_eqmem : lfun
+
+(* -------------------------------------------------------------------------- *)
+
+(** {2 Addr Producer Registration} *)
+
+(** Register simplifiers for functions producing [addr] terms:
+ - [~base es] is the simplifier for [(f es).base]
+ - [~offset es] is the simplifier for [(f es).offset]
+ - [~linear:true] register simplifier [f(f(p,i),k)=f(p,i+j)] on [f]
+ - [~equal a b] is the [set_eq_builtin] for [f]
+
+ The equality builtin is wrapped inside a default builtin that
+ compares [f es] by computing [base] and [offset].
+*)
+
+val register :
+ ?base:(term list -> term) ->
+ ?offset:(term list -> term) ->
+ ?equal:(term -> term -> pred) ->
+ ?linear:bool ->
+ lfun -> unit
+
+
+(** {2 Frame Conditions}
+
+ [frames ~addr] are frame conditions for reading a value
+ at address [addr] from a chunk of memory.
+ The value read at [addr] have length [offset],
+ while individual element in memory chunk have type [tau] and
+ offset length [sizeof].
+
+ Memory variables use [~basename] or ["mem"] by default.
+*)
+
+val frames : addr:term -> offset:term -> sizeof:term ->
+ ?basename:string -> tau -> Sigs.frame list
+
+(** {2 Range of Address} *)
+
+val separated :
+ shift:('a -> Ctypes.c_object -> term -> 'a) ->
+ addrof:('a -> term) ->
+ sizeof:(Ctypes.c_object -> int) ->
+ 'a Sigs.rloc -> 'a Sigs.rloc -> pred
+
+val included :
+ shift:('a -> Ctypes.c_object -> term -> 'a) ->
+ addrof:('a -> term) ->
+ sizeof:(Ctypes.c_object -> int) ->
+ 'a Sigs.rloc -> 'a Sigs.rloc -> pred
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/MemRegion.ml b/src/plugins/wp/MemRegion.ml
new file mode 100644
index 0000000000000000000000000000000000000000..14660db121ee6b83878b883344b8d5a1abbd7a4f
--- /dev/null
+++ b/src/plugins/wp/MemRegion.ml
@@ -0,0 +1,878 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(* TODO DEVEL MODE *)
+[@@@ warning "-32-37-60"]
+
+(* -------------------------------------------------------------------------- *)
+(* --- Region Memory Model --- *)
+(* -------------------------------------------------------------------------- *)
+
+open Cil_types
+open Sigs
+open Definitions
+
+module Wp = Wp_parameters
+module F = Lang.F
+module L = Qed.Logic
+
+(* -------------------------------------------------------------------------- *)
+(* --- Why-3 Region Theory --- *)
+(* -------------------------------------------------------------------------- *)
+
+let library = "region"
+
+let cluster_region () =
+ Definitions.cluster ~id:"Region" ~title:"Region Index Constructors" ()
+
+(* Index *)
+let t_addr = MemMemory.t_addr
+let t_index = L.Data( Lang.datatype ~library "index" ,[] )
+let f_addrof = Lang.extern_f ~library ~result:t_addr "addrof"
+let f_consistent = Lang.extern_fp ~library "consistent"
+let f_consistent_range = Lang.extern_fp ~library "consistent_range"
+
+let a_addrof l = F.e_fun f_addrof [l]
+let p_consistent l = F.p_call f_consistent [l]
+let p_consistent_range l n = F.p_call f_consistent_range [l;n]
+let p_range k n ps = F.(p_leq e_zero k :: p_lt k n :: ps)
+
+(* Null *)
+let f_inull = Lang.extern_f ~library ~result:t_index "inull"
+let l_inull = F.e_fun f_inull []
+let a_null = MemMemory.a_null
+let p_inull l = F.p_equal a_null (a_addrof l)
+
+(* Address *)
+
+let p_separated p n q m = F.p_call MemMemory.p_separated [p;n;q;m]
+
+(* Constructors *)
+let region_ctor ~result =
+ Lang.extern_f ~library ~category:L.Constructor ~result "%s"
+
+let f_addr_var = region_ctor ~result:t_addr "addr_var"
+let f_addr_ref = region_ctor ~result:t_addr "addr_ref"
+let f_base_var = region_ctor ~result:L.Int "base_var"
+let f_base_ref = region_ctor ~result:L.Int "base_ref"
+let f_index_var = region_ctor ~result:t_index "index_var"
+let f_index_ref = region_ctor ~result:t_index "index_ref"
+let f_index_mem = region_ctor ~result:t_index "index_mem"
+
+let a_addr_var x = F.e_fun f_addr_var [x]
+let a_addr_ref p = F.e_fun f_addr_ref [p]
+let l_index_var x = F.e_fun f_index_var [F.e_int x]
+let l_index_mem l k n = F.e_fun f_index_ref [l;k;n]
+let l_index_ref l = F.e_fun f_index_ref [l]
+
+(* Shifts *)
+
+let a_shift = MemMemory.a_shift
+let f_shift_index = Lang.extern_f ~library ~result:t_index "shift_index"
+let l_shift_index l p = F.e_fun f_shift_index [l;p]
+
+(* Bits *)
+let t_bits = L.Int
+
+(* -------------------------------------------------------------------------- *)
+(* --- Index Simplifiers --- *)
+(* -------------------------------------------------------------------------- *)
+
+type index_builtin = {
+ index: (Lang.lfun -> F.term list -> F.term -> F.term) ;
+ addrof : (F.term list -> F.term) ;
+ consistent : (F.term list -> F.pred) ;
+}
+
+module IndexBuiltin = WpContext.Static
+ (struct
+ type key = Lang.lfun
+ type data = index_builtin
+ let name = "MemRegion.INDEXER"
+ include Lang.Fun
+ end)
+
+(* f enjoys shifting props:
+ - f(l,p,...)+k == f(l,p+k,...)
+ - &f(l,p,...) = &l+p
+*)
+let is_shiftable f =
+ ( f == f_shift_index ) || ( f == f_index_mem)
+
+let phi_addrof index =
+ match F.repr index with
+ | L.Fun(f,[]) when f == f_inull -> a_null
+ | L.Fun(f,[x]) when f == f_index_var -> a_addr_var x
+ | L.Fun(f,[l]) when f == f_index_ref -> a_addr_ref (a_addrof l)
+ | L.Fun(f,l::p::_) when is_shiftable f -> a_shift (a_addrof l) p
+ | L.Fun(f,es) -> (IndexBuiltin.find f).addrof es
+ | _ -> raise Not_found
+
+let phi_shift_index l p =
+ if p == F.e_zero then l else
+ match F.repr l with
+ | L.Fun(f,l::q::w) when is_shiftable f -> F.e_fun f (l::(F.e_add p q)::w)
+ | L.Fun(f,es) -> (IndexBuiltin.find f).index f es p
+ | _ -> raise Not_found
+
+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
+ | L.Fun(f,[l]) when f == f_index_ref ->
+ 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]
+ | L.Fun(f,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 ;
+ ]
+ | _ -> raise Not_found
+
+let () = Context.register
+ begin fun () ->
+ MemMemory.register f_addr_var
+ ~base:(F.e_fun f_base_var) ~offset:(fun _ -> F.e_zero) ;
+ MemMemory.register f_addr_ref
+ ~base:(F.e_fun f_base_ref) ;
+ F.set_builtin_1 f_addrof phi_addrof ;
+ F.set_builtin_1 f_consistent phi_consistent ;
+ F.set_builtin_2 f_shift_index phi_shift_index ;
+ F.set_builtin_2 f_consistent_range phi_consistent_range ;
+ end
+
+let cid = ref 0 (* TODO: projectified *)
+
+let constructor ~basename ~params ~index ~addrof ~consistent =
+ let id = incr cid ; !cid in
+ let lfun = Lang.generated_f ~result:t_index "%s_%d" basename id in
+ let ps = List.map F.e_var params in
+ let l = F.e_fun lfun ps in
+ let k = Lang.freshvar ~basename:"k" L.Int in
+ let ofs = F.e_var k in
+ (* Must compute properties before registering simplifiers *)
+ let p_addrof = F.p_equal (a_addrof l) (addrof ps) in
+ let p_consistent = F.p_equiv (p_consistent l) (consistent ps) in
+ let p_index = F.p_equal (l_shift_index l ofs) (index lfun ps ofs) in
+ IndexBuiltin.define lfun { index ; addrof ; consistent } ;
+ fun cluster ->
+ begin
+ Definitions.define_symbol {
+ d_cluster = cluster ;
+ d_lfun = lfun ; d_params = params ; d_types = 0 ;
+ d_definition = Logic t_index ;
+ } ;
+ Definitions.define_lemma {
+ l_cluster = cluster ;
+ l_assumed = true ;
+ l_name = Printf.sprintf "addrof_%s_%d" basename id ;
+ l_forall = params ; l_types = 0 ; l_triggers = [] ;
+ l_lemma = p_addrof ;
+ } ;
+ Definitions.define_lemma {
+ l_cluster = cluster ;
+ l_assumed = true ;
+ l_name = Printf.sprintf "consistent_%s_%d" basename id ;
+ l_forall = params ; l_types = 0 ; l_triggers = [] ;
+ l_lemma = p_consistent ;
+ } ;
+ if p_index != F.p_true then
+ Definitions.define_lemma {
+ l_cluster = cluster ;
+ l_assumed = true ;
+ l_name = Printf.sprintf "index_%s_%d" basename id ;
+ l_forall = params @ [k] ; l_types = 0 ; l_triggers = [] ;
+ l_lemma = p_index ;
+ } ;
+ lfun
+ end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Field Index Constructors --- *)
+(* -------------------------------------------------------------------------- *)
+
+module FIELD =
+struct
+
+ type t = int list (* Overlay offsets *)
+
+ 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
+
+ let compare = Pervasives.compare
+
+ (* Extract constant offset *)
+ let offset k =
+ let rec walk s a =
+ match F.repr a with
+ | L.Add es -> List.fold_left walk s es
+ | L.Kint z ->
+ (try s + Integer.to_int z
+ with Z.Overflow -> s)
+ | _ -> s
+ in walk 0 k
+
+ let builtin_index f es q = match es with
+ | [l;p] -> F.e_fun f [l;F.e_add q p]
+ | _ -> raise Not_found
+
+ let builtin_addrof = function
+ | [l;p] -> a_shift (a_addrof l) p
+ | _ -> raise Not_found
+
+ let builtin_consistent fds = function
+ | [l;p] -> F.p_and (p_consistent l)
+ (F.p_any (fun fd -> F.p_equal (F.e_int fd) p) fds)
+ | _ -> raise Not_found
+
+end
+
+(* Model Independant Generators *)
+module FIELD_GEN = WpContext.StaticGenerator(FIELD)
+ (struct
+ type key = FIELD.t
+ type data = cluster -> Lang.lfun
+ let name = "MemRegion.FIELD_GEN"
+ let compile fds =
+ let l = Lang.freshvar ~basename:"l" t_index in
+ let p = Lang.freshvar ~basename:"p" L.Int in
+ constructor
+ ~basename:"field"
+ ~params:[l;p]
+ ~index:FIELD.builtin_index
+ ~addrof:FIELD.builtin_addrof
+ ~consistent:(FIELD.builtin_consistent fds)
+ end)
+
+(* Model Dependent Definitions *)
+module FIELD_MODEL = WpContext.Generator(FIELD)
+ (struct
+ type key = FIELD.t
+ type data = Lang.lfun
+ let name = "MemRegion.FIELD_MODEL"
+ let compile fds = FIELD_GEN.get fds @@ cluster_region ()
+ end)
+
+let l_field ovl l k =
+ let fds = List.map (fun rg -> rg.Layout.ofs) ovl in
+ F.e_fun (FIELD_MODEL.get fds) [l;k]
+
+(* -------------------------------------------------------------------------- *)
+(* --- Array Index Constructors --- *)
+(* -------------------------------------------------------------------------- *)
+
+module ARRAY =
+struct
+
+ type t = int * int list
+ let compare = Pervasives.compare
+ let pretty fmt (s,ds) = Format.fprintf fmt "%d%a" s Layout.Matrix.pretty ds
+
+ (* Coefficient from Matrix dimensions: c_i = \Pi_{i<j} d_j *)
+ let coefs s ds =
+ let rec walk cs s = function
+ | d::ds -> walk (s::cs) (d*s) ds
+ | [] -> cs
+ in walk [] s ds
+
+ (* All zeroes *)
+ let zeroes = List.map (fun _ -> F.e_zero)
+
+ (* Address shift with coefficient c_i for each index k_i *)
+ let rec shift a cs ks =
+ match cs , ks with
+ | c::cs , k::ks -> shift (a_shift a (F.e_fact c k)) cs ks
+ | _ -> a
+
+ (* Address of an array index *)
+ let builtin_addrof cs = function
+ | l::ks -> shift (a_addrof l) cs ks
+ | _ -> raise Not_found
+
+ (* Add conditions (0 <= ki < ni) to [ps].
+ WARNING: ns = rev ds *)
+ 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
+ | k::ks , [] ->
+ add_range_dims F.(p_equal e_zero k :: ps) ks []
+ | [] , _ -> ps
+
+ (* Consistent index.
+ WARNING: ns = rev ds *)
+ let builtin_consistent ns = function
+ | l::ks -> F.p_conj (add_range_dims [p_consistent l] ks ns)
+ | _ -> raise Not_found
+
+ (* Extract linear forms *)
+ let rec get_linear poly a =
+ match F.repr a with
+ | L.Add es -> List.fold_left get_linear poly es
+ | L.Kint z ->
+ (try (Integer.to_int z,F.e_one)::poly
+ with Z.Overflow -> (1,a)::poly)
+ | L.Times(c,e) ->
+ (try (Integer.to_int c,e)::poly
+ with Z.Overflow -> (1,a)::poly)
+ | _ -> (1,a)::poly
+
+ (* Some of linear form *)
+ let rec add_linear s = function
+ | (k,e)::poly -> add_linear (F.e_add s (F.e_fact k e)) poly
+ | [] -> s
+
+ (* Euclidian division *)
+ (* euclid q r ci p = q',r' <-> p + ci.q + r = ci.q' + r' *)
+ 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
+
+ (* 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
+ | _ -> List.rev_append ks' ks , p
+
+ (* Linear offset and remainder delta *)
+ let offset cs ks p =
+ let ks',r = add_linear_index cs ks [] (get_linear [] p) in
+ ks' , add_linear F.e_zero r
+
+ (* 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
+ | _ -> raise Not_found
+
+end
+
+module ARRAY_GEN = WpContext.StaticGenerator(ARRAY)
+ (struct
+ type key = ARRAY.t
+ type data = (cluster -> Lang.lfun)
+ let name = "MemRegion.ARRAY_GEN"
+ let compile (s,ds) =
+ let l = Lang.freshvar ~basename:"l" t_index in
+ let ks = List.map (fun _ -> Lang.freshvar ~basename:"k" L.Int) ds in
+ let cs = ARRAY.coefs s ds in
+ let ns = List.rev ds in
+ constructor
+ ~basename:"array"
+ ~params:(l::ks)
+ ~index:(ARRAY.builtin_index cs)
+ ~addrof:(ARRAY.builtin_addrof cs)
+ ~consistent:(ARRAY.builtin_consistent ns)
+ end)
+
+module ARRAY_MODEL = WpContext.Generator(ARRAY)
+ (struct
+ type key = ARRAY.t
+ type data = Lang.lfun
+ let name = "MemRegion.ARRAY_MODEL"
+ let compile dim = ARRAY_GEN.get dim @@ cluster_region ()
+ end)
+
+let l_array s ds l ks = F.e_fun (ARRAY_MODEL.get (s,ds)) (l::ks)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Model Context --- *)
+(* -------------------------------------------------------------------------- *)
+
+let datatype = "MemRegion"
+
+let configure () =
+ begin
+ Context.set Lang.pointer (fun _ -> t_index) ;
+ Context.set Cvalues.null p_inull ;
+ end
+
+let configure_ia =
+ let no_binder = { bind = fun _ f v -> f v } in
+ fun _vertex -> no_binder
+
+let hypotheses () = []
+
+let error msg = Warning.error ~source:"Region Model" msg
+
+(* -------------------------------------------------------------------------- *)
+(* --- Region Maps --- *)
+(* -------------------------------------------------------------------------- *)
+
+let map () =
+ RegionAnalysis.get
+ begin match WpContext.get_scope () with
+ | WpContext.Global -> None
+ | WpContext.Kf kf -> Some kf
+ end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Locations --- *)
+(* -------------------------------------------------------------------------- *)
+
+open Layout
+
+type region = Region.region
+type index = F.term
+
+let pp_index = F.pp_term
+let pp_region = Region.R.pretty
+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
+
+let pp_field fmt k =
+ if F.is_atomic k then
+ Format.fprintf fmt "@,+%a" F.pp_term k
+ else
+ Format.fprintf fmt "@,+(%a)" F.pp_term k
+
+let pp_delta fmt k =
+ if k != F.e_zero then pp_field fmt k
+
+type loc =
+ | GarbledMix (* any possible location *)
+ | Index of index (* unqualified address *)
+ | Lref of region * index * region
+ | Lmem of region * index * root * region value
+ | Lraw of region * index * root * region option
+ | Lfld of region * index * F.term * region overlay
+ | Larr of region * index * F.term * F.term list * int * int list
+ (* For Lxxx locations:
+ - index: start index inside the chunk
+ - term: additional shift index
+ - term list: array index from start *)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Loc Basics --- *)
+(* -------------------------------------------------------------------------- *)
+
+let null = Index l_inull
+
+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)
+ | Larr(_,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
+ | Larr(_,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
+ | Lref(r,l,r') ->
+ 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
+ | Lraw(r,l,_,None) ->
+ 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
+ | Lfld(r,l,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
+
+(* -------------------------------------------------------------------------- *)
+(* --- Loc Constructors --- *)
+(* -------------------------------------------------------------------------- *)
+
+let rec index map (r:region) (l:index) (ofs:F.term) (len:int) =
+ index_chunk map r l ofs len (Region.chunk map r)
+
+and index_chunk map (r:region) l ofs len = function
+ | Mref r' -> Lref(r,l_shift_index l ofs,r')
+ | Mraw(m,p) -> Lraw(r,l_shift_index l ofs,m,p)
+ | Mmem(m,v) -> Lmem(r,l_shift_index l ofs,m,v)
+ | Mcomp(_,[{ofs=0;reg;dim}]) -> index_dim map reg l ofs len dim
+ | Mcomp(_,overlay) -> index_field map r l ofs len overlay
+
+and index_field map r l ofs len overlay =
+ try
+ let k = FIELD.offset ofs in
+ let rg = List.find (Layout.Range.included k len) overlay in
+ let fd = F.e_int k in
+ let l' = l_field overlay l fd in
+ index_dim map rg.reg l' (F.e_sub ofs fd) len rg.dim
+ with Not_found ->
+ Lfld(r,l,ofs,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
+ | Dim(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
+ let ks,ofs = ARRAY.offset cs ks ofs in
+ if len <= s then
+ let l' = l_array s ds l ks in
+ index map r l' ofs len
+ else
+ Larr(r,l,ofs,ks,s,ds)
+
+and shift_index_loc map loc ofs len =
+ match loc with
+ | GarbledMix -> GarbledMix
+ | Index l -> Index (l_shift_index l ofs)
+ | Lref(r,l,r') -> Lref(r,l_shift_index l ofs,r')
+ | Lmem(r,l,m,v) -> Lmem(r,l_shift_index l ofs,m,v)
+ | Lraw(r,l,m,p) -> Lraw(r,l_shift_index l ofs,m,p)
+ | Lfld(r,l,k,overlay) -> index_field map r l (F.e_add k ofs) len overlay
+ | Larr(r,l,k,ks,s,ds) -> index_array map r l ks (F.e_add k ofs) len s ds
+
+let cvar x =
+ let map = map () in
+ let region = Region.of_cvar map x in
+ let id = if Cil.isConstType x.vtype then - x.vid else x.vid in
+ index map region (l_index_var id) F.e_zero (Cil.bitsSizeOf x.vtype)
+
+let field loc fd =
+ let map = map () in
+ let ofs,len = Region.field_offset map fd in
+ shift_index_loc map loc (F.e_int ofs) len
+
+let shift loc obj n =
+ let map = map () in
+ let s = Ctypes.bits_sizeof_object obj in
+ shift_index_loc map loc (F.e_fact s n) s
+
+let pointer_loc l = Index l
+let pointer_val = function
+ | GarbledMix -> error "Can not obtain address of Garbled-Mix location"
+ | Index l | Lref(_,l,_) | Lmem(_,l,_,_) | Lraw(_,l,_,_) -> l
+ | Lfld(_,l,k,overlay) -> l_field overlay l k
+ | Larr(_,l,k,ks,s,ds) -> l_shift_index (l_array s ds l ks) k
+
+let loc_of_index re ty l =
+ index (map()) re l F.e_zero (Cil.bitsSizeOf ty)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Chunks --- *)
+(* -------------------------------------------------------------------------- *)
+
+type chunk =
+ | Mu_alloc
+ | Mu_raw of region * root
+ | Mu_mem of region * root * region value
+
+module Chunk =
+struct
+
+ type t = chunk
+ let self = "region"
+
+ let id = function
+ | Mu_raw(r,_) | Mu_mem(r,_,_) -> Region.id r
+ | Mu_alloc -> Region.noid
+
+ let hash m = id m
+ let compare m m' = if m==m then 0 else Pervasives.compare (id m) (id m')
+ let equal m m' = m==m' || (id m = id m')
+
+ let tau_of_value = function
+ | Int _ -> L.Int
+ | Float _ -> L.Real
+ | Pointer _ -> t_index
+
+ let tau_of_chunk = function
+ | 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 basename_of_chunk = function
+ | Mu_raw _ -> "B"
+ | Mu_mem(_,root,Int _) -> if Root.indexed root then "M" else "V"
+ | Mu_mem(_,root,Float _) -> if Root.indexed root then "Mf" else "F"
+ | Mu_mem(_,root,Pointer _) -> if Root.indexed root then "Mp" else "M"
+ | Mu_alloc -> "A"
+
+ let is_framed = function
+ | Mu_raw(_,root) | Mu_mem(_,root,_) -> Root.framed root
+ | Mu_alloc -> false
+
+ let pretty fmt mu = Format.pp_print_string fmt (basename_of_chunk mu)
+
+end
+
+module Heap =
+struct
+ include Qed.Collection.Make(Chunk)
+ let empty = Set.empty
+ let of_raw r rt = Set.singleton (Mu_raw(r,rt))
+ let of_mem r rt v = Set.singleton (Mu_mem(r,rt,v))
+
+ let rec of_region map r =
+ match Region.chunk map r with
+ | Mref _ -> Set.empty
+ | Mraw(rt,_) -> of_raw r rt
+ | Mmem(rt,v) -> of_mem r rt v
+ | Mcomp(_,overlay) -> of_overlay map overlay
+
+ and of_range map { reg } = of_region map reg
+
+ and of_overlay map ovl =
+ Qed.Hcons.fold_list Set.union (of_range map) empty ovl
+
+end
+module Sigma = Sigma.Make(Chunk)(Heap)
+
+type sigma = Sigma.t
+type domain = Sigma.domain
+
+let domain _obj = function
+ | GarbledMix | Index _ -> error "Can not compute Garbled-mix domain"
+ | Lref _ -> Heap.empty
+ | Lraw(r,_,rt,_) -> Heap.of_raw r rt
+ | Lmem(r,_,rt,v) -> Heap.of_mem r rt v
+ | Lfld(_,_,_,ovl) -> Heap.of_overlay (map()) ovl
+ | Larr(r,_,_,_,_,_) -> Heap.of_region (map()) r
+
+let region_of_loc = function
+ | (GarbledMix | Index _) as l -> error "Can not find region of %a" pretty l
+ | Lref(r,_,_) | Lraw(r,_,_,_) | Lmem(r,_,_,_)
+ | Lfld(r,_,_,_) | Larr(r,_,_,_,_,_) -> r
+
+(* -------------------------------------------------------------------------- *)
+(* --- Loader --- *)
+(* -------------------------------------------------------------------------- *)
+
+module MODEL =
+struct
+
+ module Chunk = Chunk
+ module Sigma = Sigma
+ let name = "MemRegion.LOADER"
+ type nonrec loc = loc
+ let field = field
+ let shift = shift
+ let sizeof = Ctypes.bits_sizeof_object
+ let domain = domain
+ let frames _ _ _ = []
+
+ let to_addr l = a_addrof (pointer_val l)
+ let to_region_pointer l = Region.id (region_of_loc l) , pointer_val l
+ let of_region_pointer r obj l =
+ let map = map () in
+ index map (Region.region map r) l F.e_zero (Ctypes.bits_sizeof_object obj)
+
+ let load_mem sigma r rt v l =
+ let m = Sigma.value sigma (Mu_mem(r,rt,v)) in
+ if Root.indexed rt then F.e_get m (a_addrof l) else m
+
+ let load_int sigma i = function
+ | Lmem(r,l,rt,(Int i0 as v)) when i = i0 -> load_mem sigma r rt v l
+ | l -> error "Can not load %a value from %a" Ctypes.pp_int i pretty l
+
+ let load_float sigma f = function
+ | Lmem(r,l,rt,(Float f0 as v)) when f = f0 -> load_mem sigma r rt v l
+ | l -> error "Can not load %a value from %a" Ctypes.pp_float f pretty l
+
+ 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)
+ | Lref(_,l,r') ->
+ 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 =
+ match chunk with
+ | 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
+
+ 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
+
+ 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
+
+ let last _ = error "Can not compute last valid index"
+
+ let store_mem sigma r rt v l value =
+ let c = Mu_mem(r,rt,v) in
+ if Root.indexed rt then
+ c , F.e_set (Sigma.value sigma c) (a_addrof l) value
+ else c , value
+
+ let store_int sigma i loc value =
+ match loc with
+ | Lmem(r,l,rt,(Int i0 as v)) when i = i0 -> store_mem sigma r rt v l value
+ | _ -> error "Can not store %a value into %a" Ctypes.pp_int i pretty loc
+
+ let store_float sigma f loc value =
+ match loc with
+ | Lmem(r,l,rt,(Float f0 as v)) when f = f0 -> store_mem sigma r rt v l value
+ | _ -> error "Can not store %a value into %a" Ctypes.pp_float f pretty loc
+
+ let store_pointer sigma _ty loc value =
+ match loc with
+ | Lmem(r,l,rt,(Pointer _ as v)) -> store_mem sigma r rt v l value
+ | _ -> error "Can not store pointer values into %a" pretty loc
+
+end
+
+module LOADER = MemLoader.Make(MODEL)
+
+let load = LOADER.load
+let loadvalue = LOADER.loadvalue
+
+let stored = LOADER.stored
+let copied = LOADER.copied
+let assigned = LOADER.assigned
+
+(* -------------------------------------------------------------------------- *)
+(* --- Loc Segments --- *)
+(* -------------------------------------------------------------------------- *)
+
+type segment = loc rloc
+
+let region_of_sloc = function Rloc(_,l) | Rrange(l,_,_,_) -> region_of_loc l
+
+let disjoint_region s1 s2 =
+ let map = map () in
+ let c1 = Region.chunks map (region_of_sloc s1) in
+ let c2 = Region.chunks map (region_of_sloc s2) in
+ not (Qed.Intset.intersect c1 c2)
+
+
+let addrof = MODEL.to_addr
+let sizeof = Ctypes.bits_sizeof_object
+
+let included s1 s2 =
+ if disjoint_region s1 s2 then F.p_false else
+ MemMemory.included ~shift ~addrof ~sizeof s1 s2
+
+let separated s1 s2 =
+ if disjoint_region s1 s2 then F.p_true else
+ MemMemory.separated ~shift ~addrof ~sizeof s1 s2
+
+(* -------------------------------------------------------------------------- *)
+(* --- TODO TODO TODO TODO TODO TODO TODO TODO TODO TODO TODO TODO TODO --- *)
+(* -------------------------------------------------------------------------- *)
+
+type state = unit
+
+let state _ = ()
+let iter _ _ = ()
+let lookup _ _ = Mterm
+let updates _ _ = Bag.empty
+let apply _ _ = ()
+
+let literal ~eid _ = ignore eid ; GarbledMix
+
+let base_addr _l = GarbledMix
+let base_offset l = MemMemory.a_offset (addrof l)
+let block_length _s _obj _l = F.e_zero
+
+let cast _ _l = GarbledMix
+let loc_of_int _ _ = GarbledMix
+let int_of_loc _ _ = F.e_zero
+
+let not_yet_pointer () = error "Pointer comparison not yet implemented"
+
+let is_null _ = not_yet_pointer ()
+let loc_eq _ _ = not_yet_pointer ()
+let loc_lt _ _ = not_yet_pointer ()
+let loc_leq _ _ = not_yet_pointer ()
+let loc_neq _ _ = not_yet_pointer ()
+let loc_diff _ _ _ = not_yet_pointer ()
+
+let frame _sigma = []
+let alloc sigma _xs = sigma
+let scope _seq _s _xs = []
+let valid _sigma _acs _l = error "Validity not yet implemented"
+let invalid _sigma _l = error "Validity not yet implemented"
+let global _sigma _p = F.p_true
diff --git a/src/plugins/wp/MemRegion.mli b/src/plugins/wp/MemRegion.mli
new file mode 100644
index 0000000000000000000000000000000000000000..6191649db155bbd608cd6adb2fc67907cc03e8a0
--- /dev/null
+++ b/src/plugins/wp/MemRegion.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Empty Memory Model --- *)
+(* -------------------------------------------------------------------------- *)
+
+include Sigs.Model
diff --git a/src/plugins/wp/MemTyped.ml b/src/plugins/wp/MemTyped.ml
index f088afb4eb9c9cb216adb6893e14c88295dcab83..3836f09578188ba6491eabebc2083514a7bab9d5 100644
--- a/src/plugins/wp/MemTyped.ml
+++ b/src/plugins/wp/MemTyped.ml
@@ -31,64 +31,38 @@ open Lang
open Lang.F
open Sigs
open Definitions
+open MemMemory
let dkey_layout = Wp_parameters.register_category "layout"
-
module L = Qed.Logic
+(* -------------------------------------------------------------------------- *)
+(* --- Model Configuration --- *)
+(* -------------------------------------------------------------------------- *)
+
let datatype = "MemTyped"
let hypotheses () = []
-let library = "memory"
-
-let a_addr = Lang.datatype ~library "addr"
-let t_addr = L.Data(a_addr,[])
-let f_base = Lang.extern_f ~library ~result:L.Int
- ~link:{altergo = Qed.Engine.F_subst("%1.base");
- why3 = Qed.Engine.F_call("base");
- coq = Qed.Engine.F_subst("(base %1)");
- } "base"
-let f_offset = Lang.extern_f ~library ~result:L.Int
- ~link:{altergo = Qed.Engine.F_subst("%1.offset");
- why3 = Qed.Engine.F_call("offset");
- coq = Qed.Engine.F_subst("(offset %1)");
- } "offset"
-let f_shift = Lang.extern_f ~library ~result:t_addr "shift"
-let f_global = Lang.extern_f ~library ~result:t_addr ~category:L.Injection "global"
-let f_null = Lang.extern_f ~library ~result:t_addr "null"
-let f_base_offset = Lang.extern_f ~library ~category:Qed.Logic.Injection ~result:L.Int "base_offset"
-
-let ty_havoc = function
- | Some l :: _ -> l
- | _ -> raise Not_found
+let configure () =
+ begin
+ Context.set Lang.pointer (fun _ -> t_addr) ;
+ Context.set Cvalues.null (p_equal a_null) ;
+ end
-let l_havoc = Qed.Engine.{
- coq = F_call "fhavoc" ;
- altergo = F_call "havoc" ;
- why3 = F_call "havoc" ;
- }
-
-let p_valid_rd = Lang.extern_fp ~library "valid_rd"
-let p_valid_rw = Lang.extern_fp ~library "valid_rw"
-let p_invalid = Lang.extern_fp ~library "invalid"
-let p_separated = Lang.extern_fp ~library "separated"
-let p_included = Lang.extern_fp ~library "included"
-let p_eqmem = Lang.extern_fp ~library "eqmem"
-let f_havoc = Lang.extern_f ~library ~typecheck:ty_havoc ~link:l_havoc "havoc"
-let f_region = Lang.extern_f ~library ~result:L.Int "region" (* base -> region *)
-let p_framed = Lang.extern_fp ~library "framed" (* m-pointer -> prop *)
-let p_linked = Lang.extern_fp ~library "linked" (* allocation-table -> prop *)
-let p_sconst = Lang.extern_fp ~library "sconst" (* int-memory -> prop *)
-let a_lt = Lang.extern_p ~library ~bool:"addr_lt_bool" ~prop:"addr_lt" ()
-let a_leq = Lang.extern_p ~library ~bool:"addr_le_bool" ~prop:"addr_le" ()
-
-let a_addr_of_int = Lang.extern_f
- ~category:L.Injection
- ~library ~result:t_addr "addr_of_int"
-
-let a_int_of_addr = Lang.extern_f
- ~category:L.Injection
- ~library ~result:L.Int "int_of_addr"
+let configure_ia =
+ let no_binder = { bind = fun _ f v -> f v } in
+ fun _vertex -> no_binder
+
+(* -------------------------------------------------------------------------- *)
+(* --- Model Parameters --- *)
+(* -------------------------------------------------------------------------- *)
+
+type pointer = NoCast | Fits | Unsafe
+let pointer = Context.create "MemTyped.pointer"
+
+(* -------------------------------------------------------------------------- *)
+(* --- Model Semantics --- *)
+(* -------------------------------------------------------------------------- *)
(*
@@ -133,270 +107,6 @@ let a_int_of_addr = Lang.extern_f
*)
-(* -------------------------------------------------------------------------- *)
-(* --- Utilities --- *)
-(* -------------------------------------------------------------------------- *)
-
-let a_null = F.constant (e_fun f_null [])
-let a_base p = e_fun f_base [p]
-let a_offset p = e_fun f_offset [p]
-let a_global b = e_fun f_global [b]
-let a_base_offset k = e_fun f_base_offset [k]
-let a_shift l k = e_fun f_shift [l;k]
-let a_addr b k = a_shift (a_global b) k
-
-(* -------------------------------------------------------------------------- *)
-(* --- Qed Simplifiers --- *)
-(* -------------------------------------------------------------------------- *)
-
-(*
- Pointer arithmetic for structure access and array access could be
- defined directly using the record [{ base = p.base; offset = p.offset
- + c*i + c' }]. However that gives very bad triggers for the memory
- model axiomatization, so `shift p (c*i+c')` was used instead. It is
- not sufficient for user axiomatisation because memory access in
- axioms require trigger with arithmetic operators which is badly
- handled by provers. So for each c and c', ie for each kind of
- structure access and array access a specific function is used
- `shift_xxx`.
-
- Moreover no simplification of `shift_xxx` is done for keeping the
- same terms in axioms and the goal. `base` and `offset` function
- simplify all the `shift_xxx` because it seems they don't appear
- often in axioms and they are useful for simplifying `separated`,
- `assigns` and pointer comparisons in goals.
-
- To sum up memory access should match, but not `\base`, `\offset`,
- `\separated`, ...
-*)
-
-type registered_shift =
- | RS_Field of fieldinfo * term (* offset of the field *)
- | RS_Shift of Z.t (* size of the element *)
-
-module RegisterShift = WpContext.Static
- (struct
- type key = lfun
- type data = registered_shift
- let name = "MemTyped.RegisterShift"
- include Lang.Fun
- end)
-
-let phi_base l =
- match F.repr l with
- | L.Fun(f,p::_) when RegisterShift.mem f -> a_base p
- | L.Fun(f,[p;_]) when f==f_shift -> a_base p
- | L.Fun(f,[b]) when f==f_global -> b
- | L.Fun(f,[]) when f==f_null -> e_zero
- | _ -> raise Not_found
-
-let phi_offset l = match F.repr l with
- | L.Fun(f,[p;k]) when f==f_shift -> e_add (a_offset p) k
- | L.Fun(f,_) when f==f_global || f==f_null -> F.e_zero
- | L.Fun(f,p::args) ->
- begin match RegisterShift.get f, args with
- | Some (RS_Field(_,offset)), [] -> e_add offset (a_offset p)
- | Some (RS_Shift size), [k] -> e_add (a_offset p) ((F.e_times size) k)
- | Some _, _ -> assert false (* constructed at one place only *)
- | None, _ -> raise Not_found
- end
- | _ -> raise Not_found
-
-let eq_shift a b =
- let p = a_base a in
- let q = a_base b in
- let i = a_offset a in
- let j = a_offset b in
- if i==j then F.p_equal p q else
- match F.is_equal p q with
- | L.No -> F.p_false
- | L.Yes -> F.p_equal i j
- | L.Maybe -> raise Not_found
-
-let phi_shift f p i =
- match F.repr p with
- | L.Fun(g,[q;j]) when f == g -> F.e_fun f [q;F.e_add i j]
- | _ -> raise Not_found
-
-(* -------------------------------------------------------------------------- *)
-(* --- Simplifier for 'separated' --- *)
-(* -------------------------------------------------------------------------- *)
-
-(*
-logic a : int
-logic b : int
-logic S : prop
-
-predicate separated = a <= 0 or b <= 0 or S
-*)
-
-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
- | _ -> raise Not_found
-
-let is_separated args = F.is_true (r_separated args)
-
-(* -------------------------------------------------------------------------- *)
-(* --- Simplifier for 'included' --- *)
-(* -------------------------------------------------------------------------- *)
-
-(*
-logic a : int
-logic b : int
-
-predicate R = p.base = q.base
- /\ (q.offset <= p.offset)
- /\ (p.offset + a <= q.offset + b)
-
-predicate included = 0 < a -> ( 0 <= b and R )
-predicate a_empty = a <= 0
-predicate b_negative = b < 0
-
-lemma SAME_P: p=q -> (R <-> a<=b)
-lemma SAME_A: a=b -> (R <-> p=q)
-
-goal INC_P: p=q -> (included <-> ( 0 < a -> a <= b )) (by SAME_P)
-goal INC_A: a=b -> 0 < a -> (included <-> R) (by SAME_A)
-goal INC_1: a_empty -> (included <-> true)
-goal INC_2: b_negative -> (included <-> a_empty)
-goal INC_3: not R -> (included <-> a_empty)
-goal INC_4: not a_empty -> not b_negative -> (included <-> R)
-*)
-
-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
- | _ -> raise Not_found
-
-(* -------------------------------------------------------------------------- *)
-(* --- Simplifier for 'havoc' --- *)
-(* -------------------------------------------------------------------------- *)
-
-(* havoc(m_undef, havoc(_undef,m0,p0,a0), p1,a1) =
- - havoc(m_undef, m0, p1,a1) WHEN included (p1,a1,p0,a0) *)
-let r_havoc = function
- | [undef1;m1;p1;a1] -> begin
- match F.repr m1 with
- | L.Fun( f , [_undef0;m0;p0;a0] ) when f == f_havoc -> begin
- let open Qed.Logic in
- match F.is_true (r_included [p0;a0;p1;a1]) with
- | Yes -> F.e_fun f_havoc [undef1;m0;p1;a1]
- | _ -> raise Not_found
- end
- | _ -> raise Not_found
- end
- | _ -> raise Not_found
-
-(* havoc(undef,m,p,a)[k] =
- - undef[k] WHEN separated (p,a,k,1)
- - m[k] WHEN NOT separated (p,a,k,1)
-*)
-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)
- | _ -> raise Not_found
-
-(* -------------------------------------------------------------------------- *)
-(* --- Simplifier for int/addr conversion --- *)
-(* -------------------------------------------------------------------------- *)
-
-let phi_int_of_addr p =
- if p == a_null then F.e_zero else
- match F.repr p with
- | L.Fun(f,[a]) when f == a_addr_of_int -> a
- | _ -> raise Not_found
-
-let phi_addr_of_int p =
- if p == F.e_zero then a_null else
- match F.repr p with
- | L.Fun(f,[a]) when f == a_int_of_addr -> a
- | _ -> raise Not_found
-
-(* -------------------------------------------------------------------------- *)
-(* --- Simplifier Registration --- *)
-(* -------------------------------------------------------------------------- *)
-
-let () = Context.register
- begin fun () ->
- F.set_builtin_1 f_base phi_base ;
- F.set_builtin_1 f_offset phi_offset ;
- F.set_builtin_2 f_shift (phi_shift f_shift) ;
- F.set_builtin_eqp f_shift eq_shift ;
- F.set_builtin_eqp f_global eq_shift ;
- F.set_builtin p_separated r_separated ;
- F.set_builtin p_included r_included ;
- F.set_builtin f_havoc r_havoc ;
- F.set_builtin_get f_havoc r_get_havoc ;
- F.set_builtin_1 a_addr_of_int phi_addr_of_int ;
- F.set_builtin_1 a_int_of_addr phi_int_of_addr ;
- end
-
-(* -------------------------------------------------------------------------- *)
-(* --- Model Parameters --- *)
-(* -------------------------------------------------------------------------- *)
-
-let configure () =
- begin
- Context.set Lang.pointer (fun _ -> t_addr) ;
- Context.set Cvalues.null (p_equal a_null) ;
- end
-let no_binder = { bind = fun _ f v -> f v }
-let configure_ia _ = no_binder
-
-type pointer = NoCast | Fits | Unsafe
-let pointer = Context.create "MemTyped.pointer"
-
(* -------------------------------------------------------------------------- *)
(* --- Chunks --- *)
(* -------------------------------------------------------------------------- *)
@@ -431,9 +141,6 @@ struct
let compare a b = rank a - rank b
let equal = (=)
let pretty fmt c = Format.pp_print_string fmt (name c)
- let key_of_chunk = function
- | M_int | M_char | M_f32 | M_f64 | M_pointer -> t_addr
- | T_alloc -> L.Int
let val_of_chunk = function
| M_int | M_char -> L.Int
| M_f32 -> Cfloat.tau_of_float Ctypes.Float32
@@ -475,24 +182,13 @@ and footprint_comp c =
Heap.Set.union ft (footprint (object_of f.ftype))
) Heap.Set.empty c.cfields
-let signature ft =
- let s = Sigma.create () in
- let xs = ref [] in
- let cs = ref [] in
- Heap.Set.iter
- (fun c ->
- cs := c :: !cs ;
- xs := (Sigma.get s c) :: !xs ;
- ) ft ;
- List.rev !xs , List.rev !cs , s
-
-let memories sigma ft = List.map (Sigma.value sigma) ft
+let domain obj _l = footprint obj
-let rec size_of_object = function
+let rec length_of_object = function
| C_int _ | C_float _ | C_pointer _ -> 1
- | C_comp c -> size_of_comp c
+ | C_comp c -> length_of_comp c
| C_array { arr_flat = Some { arr_size = n } ; arr_element = elt } ->
- n * (size_of_typ elt)
+ n * (length_of_typ elt)
| C_array _ as a ->
if Wp_parameters.ExternArrays.get () then
max_int
@@ -500,20 +196,20 @@ let rec size_of_object = function
Warning.error ~source:"Typed Model"
"Undefined array-size (%a)" Ctypes.pretty a
-and size_of_typ t = size_of_object (object_of t)
-and size_of_field f = size_of_typ f.ftype
-and size_of_comp c =
+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 =
(* union field are considered as struct field *)
List.fold_left
- (fun s f -> s + size_of_field f)
+ (fun s f -> s + length_of_field f)
0 c.cfields
-let offset_of_field f =
+let position_of_field f =
let rec fnext k f = function
| [] -> assert false
| g::gs ->
if Fieldinfo.equal f g then k
- else fnext (k + size_of_field g) f gs
+ else fnext (k + length_of_field g) f gs
in fnext 0 f f.fcomp.cfields
(* -------------------------------------------------------------------------- *)
@@ -532,13 +228,32 @@ let occurs x l = F.occurs x l
(* --- Generated Axiomatization --- *)
(* -------------------------------------------------------------------------- *)
-let loadrec = ref (fun _ _ _ -> assert false)
-
let cluster_globals () =
Definitions.cluster ~id:"Globals" ~title:"Global Variables" ()
-let cluster_memory () =
- Definitions.cluster ~id:"Compound" ~title:"Memory Compound Updates" ()
+type shift =
+ | RS_Field of fieldinfo * int (* offset of the field *)
+ | RS_Index of int (* size of the shift *)
+
+let phi_base = function
+ | p::_ -> a_base p
+ | _ -> raise Not_found
+
+let phi_field offset = function
+ | [p] -> e_add (a_offset p) (F.e_int offset)
+ | _ -> raise Not_found
+
+let phi_index size = function
+ | [p;k] -> e_add (a_offset p) (F.e_fact size k)
+ | _ -> raise Not_found
+
+module RegisterShift = WpContext.Static
+ (struct
+ type key = lfun
+ type data = shift
+ let name = "MemTyped.RegisterShift"
+ include Lang.Fun
+ end)
module ShiftFieldDef = WpContext.StaticGenerator(Cil_datatype.Fieldinfo)
(struct
@@ -549,14 +264,14 @@ module ShiftFieldDef = WpContext.StaticGenerator(Cil_datatype.Fieldinfo)
let generate f =
let result = t_addr in
let lfun = Lang.generated_f ~result "shiftfield_%s" (Lang.field_id f) in
- let offset = (F.e_int (offset_of_field f)) in
+ let position = position_of_field f in
(* Since its a generated it is the unique name given *)
let xloc = Lang.freshvar ~basename:"p" t_addr in
let loc = e_var xloc in
- let def = a_shift loc offset in
+ let def = a_shift loc (F.e_int position) in
let dfun = Definitions.Function( result , Def , def) in
- RegisterShift.define lfun (RS_Field(f,offset)) ;
- F.set_builtin_eqp lfun eq_shift ;
+ RegisterShift.define lfun (RS_Field(f,position)) ;
+ MemMemory.register ~base:phi_base ~offset:(phi_field position) lfun ;
{
d_lfun = lfun ; d_types = 0 ;
d_params = [xloc] ;
@@ -574,7 +289,7 @@ module ShiftField = WpContext.Generator(Cil_datatype.Fieldinfo)
type data = lfun
let compile fd =
let dfun = ShiftFieldDef.get fd in
- let d_cluster = cluster_memory () in
+ let d_cluster = MemLoader.cluster () in
Definitions.define_symbol { dfun with d_cluster } ;
dfun.d_lfun
end)
@@ -610,17 +325,17 @@ module ShiftGen = WpContext.StaticGenerator(Cobj)
let generate obj =
let result = t_addr in
let shift = Lang.generated_f ~result "shift_%s" (c_object_id obj) in
- let size = Integer.of_int (size_of_object obj) in
+ let size = length_of_object obj in
(* Since its a generated it is the unique name given *)
let xloc = Lang.freshvar ~basename:"p" t_addr in
let loc = e_var xloc in
let xk = Lang.freshvar ~basename:"k" Qed.Logic.Int in
let k = e_var xk in
- let def = a_shift loc (F.e_times size k) in
+ let def = a_shift loc (F.e_fact size k) in
let dfun = Definitions.Function( result , Def , def) in
- RegisterShift.define shift (RS_Shift size) ;
- F.set_builtin_eqp shift eq_shift ;
- F.set_builtin_2 shift (phi_shift shift) ;
+ RegisterShift.define shift (RS_Index size) ;
+ MemMemory.register ~base:phi_base ~offset:(phi_index size)
+ ~linear:true shift ;
{
d_lfun = shift ; d_types = 0 ;
d_params = [xloc;xk] ;
@@ -639,7 +354,7 @@ module Shift = WpContext.Generator(Cobj)
type data = lfun
let compile obj =
let dfun = ShiftGen.get obj in
- let d_cluster = cluster_memory () in
+ let d_cluster = MemLoader.cluster () in
Definitions.define_symbol { dfun with d_cluster } ;
dfun.d_lfun
end)
@@ -739,6 +454,10 @@ module STRING = WpContext.Generator(LITERAL)
end)
+(* -------------------------------------------------------------------------- *)
+(* --- Base Registration --- *)
+(* -------------------------------------------------------------------------- *)
+
module RegisterBASE = WpContext.Index
(struct
type key = lfun
@@ -763,22 +482,20 @@ module BASE = WpContext.Generator(Varinfo)
l_cluster = cluster_globals () ;
}
+ let sizeof x =
+ Warning.handle
+ ~handler:(fun _ -> None)
+ ~effect:(Printf.sprintf "No allocation size for variable '%s'" x.vname)
+ (fun obj -> Some (length_of_object obj))
+ (Ctypes.object_of x.vtype)
+
let linked prefix x base =
let name = prefix ^ "_linked" in
- let obj = Ctypes.object_of x.vtype in
- let size =
- if x.vglob then
- Warning.handle
- ~handler:(fun _ -> None)
- ~effect:(Printf.sprintf "No allocation size for variable '%s'" x.vname)
- (fun obj -> Some (size_of_object obj))
- obj
- else Some 0
- in
+ let size = if x.vglob then sizeof x else Some 0 in
match size with
| None -> ()
| Some size ->
- let a = Lang.freshvar ~basename:"alloc" (Chunk.tau_of_chunk T_alloc) in
+ 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) (e_int size) in
@@ -816,215 +533,6 @@ module BASE = WpContext.Generator(Varinfo)
let compile = Lang.local generate
end)
-
-(* Add frame lemmas for generated logical function *)
-module MONOTONIC :
-sig
- val generate :
- string -> lfun -> var list -> chunk list -> (term list -> term) -> unit
-end =
-struct
-
- type env = {
- lfun : lfun ;
- sigma : sigma ;
- vars : var list ;
- params : term list ;
- range : term ;
- chunks : chunk list ;
- memories : term list ;
- }
-
- let _cluster () = Definitions.cluster ~id:"TypedMemory" ()
- (* projectified *)
-
- let update env c m =
- List.map
- (fun c' ->
- if Chunk.equal c c' then m else Sigma.value env.sigma c'
- ) env.chunks
-
- let separated env q k = F.p_call p_separated [List.hd env.params;env.range;q;k]
- let included env q k = F.p_call p_included [List.hd env.params;env.range;q;k]
-
- let generate_update prefix env c =
- let name = prefix ^ "_update_" ^ Chunk.name c in
- let q = e_var (Lang.freshvar ~basename:"q" (Chunk.key_of_chunk c)) in
- let v = e_var (Lang.freshvar ~basename:"v" (Chunk.val_of_chunk c)) in
- let phi = e_fun env.lfun (env.params @ env.memories) in
- let mem' = e_set (Sigma.value env.sigma c) q v in
- let phi' = e_fun env.lfun (env.params @ update env c mem') in
- let lemma = p_imply (separated env q e_one) (p_equal phi' phi) in
- Definitions.define_lemma {
- l_assumed = true ;
- l_name = name ; l_types = 0 ;
- l_triggers = [[Trigger.of_term phi']] ;
- l_forall = F.p_vars lemma ;
- l_lemma = lemma ;
- l_cluster = cluster_memory () ;
- }
-
- let generate_eqmem prefix env c =
- let name = prefix ^ "_eqmem_" ^ Chunk.name c in
- let q = e_var (Lang.freshvar ~basename:"q" (Chunk.key_of_chunk c)) in
- let k = e_var (Lang.freshvar ~basename:"k" L.Int) in
- let phi = e_fun env.lfun (env.params @ env.memories) in
- let mem = Sigma.value env.sigma c in
- let mem' = e_var (Lang.freshen (Sigma.get env.sigma c)) in
- let phi' = e_fun env.lfun (env.params @ update env c mem') in
- let eqmem = F.p_call p_eqmem [mem;mem';q;k] in
- let lemma = p_hyps [included env q k;eqmem] (p_equal phi' phi) in
- Definitions.define_lemma {
- l_assumed = true ;
- l_name = name ; l_types = 0 ;
- l_triggers = [
- [Trigger.of_pred eqmem ; Trigger.of_term phi ] ;
- [Trigger.of_pred eqmem ; Trigger.of_term phi'] ;
- ] ;
- l_forall = F.p_vars lemma ;
- l_lemma = lemma ;
- l_cluster = cluster_memory () ;
- }
-
- let generate_havoc prefix env c =
- let name = prefix ^ "_havoc_" ^ Chunk.name c in
- let q = e_var (Lang.freshvar ~basename:"q" (Chunk.key_of_chunk c)) in
- let k = e_var (Lang.freshvar ~basename:"k" L.Int) in
- let phi = e_fun env.lfun (env.params @ env.memories) in
- let mem = Sigma.value env.sigma c in
- let mem' = e_var (Lang.freshen (Sigma.get env.sigma c)) in
- let m_undef = e_var (Lang.freshen (Sigma.get env.sigma c)) in
- let phi' = e_fun env.lfun (env.params @ update env c mem') in
- let havoc = p_equal mem' (F.e_fun f_havoc [m_undef;mem;q;k]) in
- let lemma = p_hyps [separated env q k;havoc] (p_equal phi' phi) in
- Definitions.define_lemma {
- l_assumed = true ;
- l_name = name ; l_types = 0 ;
- l_triggers = [
- [ Trigger.of_pred havoc ; Trigger.of_term phi ] ;
- [ Trigger.of_pred havoc ; Trigger.of_term phi'] ;
- ] ;
- l_forall = F.p_vars lemma ;
- l_lemma = lemma ;
- l_cluster = cluster_memory () ;
- }
-
- let generate prefix lfun xs cs range =
- let sigma = Sigma.create () in
- let xp = Lang.freshvar ~basename:"p" t_addr in
- let xs = List.map Lang.freshen xs in
- let ps = List.map e_var xs in
- let ms = memories sigma cs in
- let env = {
- sigma = sigma ; lfun = lfun ;
- vars = xp::xs ; params = e_var xp::ps ;
- chunks = cs ; memories = ms ;
- range = range ps ;
- } in
- List.iter
- (fun chunk ->
- generate_update prefix env chunk ;
- generate_eqmem prefix env chunk ;
- generate_havoc prefix env chunk ;
- ) cs
-
-end
-
-module COMP = WpContext.Generator(Compinfo)
- (struct
- let name = "MemTyped.COMP"
- type key = compinfo
- type data = lfun * chunk list
-
- let generate c =
- let result = Lang.tau_of_comp c in
- let lfun = Lang.generated_f ~result "Load_%s" (Lang.comp_id c) in
- (* Since its a generated it is the unique name given *)
- let prefix = Lang.Fun.debug lfun in
- let xmem,ft,sigma = signature (footprint_comp c) in
- let xloc = Lang.freshvar ~basename:"p" t_addr in
- let loc = e_var xloc in
- let def = List.map
- (fun f ->
- Cfield f , !loadrec sigma (object_of f.ftype) (field loc f)
- ) c.cfields in
- let dfun = Definitions.Function( result , Def , e_record def ) in
- Definitions.define_symbol {
- d_lfun = lfun ; d_types = 0 ;
- d_params = xloc :: xmem ;
- d_definition = dfun ;
- d_cluster = cluster_memory () ;
- } ;
- let range = e_int (size_of_comp c) in
- MONOTONIC.generate prefix lfun [] ft (fun _ -> range) ;
- lfun , ft
-
- let compile = Lang.local generate
- end)
-
-module ARRAY = WpContext.Generator(Matrix.NATURAL)
- (struct
- open Matrix
- let name = "MemTyped.ARRAY"
- type key = matrix
- type data = lfun * chunk list
-
- let generate (obj,ds) =
- let result = Matrix.tau obj ds in
- let lfun = Lang.generated_f ~result "Array%s_%s"
- (Matrix.id ds) (Matrix.natural_id obj) in
- let prefix = Lang.Fun.debug lfun in
- let axiom = prefix ^ "_access" in
- let xmem,ft,sigma = signature (footprint obj) in
- let xloc = Lang.freshvar ~basename:"p" t_addr in
- let loc = e_var xloc in
- let denv = Matrix.denv ds in
- let phi = e_fun lfun (loc :: denv.size_val @ List.map e_var xmem) in
- let arr = List.fold_left e_get phi denv.index_val in
- let elt = !loadrec sigma obj (shift loc obj (e_sum denv.index_offset)) in
- let lemma = p_hyps denv.index_range (p_equal arr elt) in
- let cluster = cluster_memory () in
- Definitions.define_symbol {
- d_lfun = lfun ; d_types = 0 ;
- d_params = xloc :: denv.size_var @ xmem ;
- d_definition = Logic result ;
- d_cluster = cluster ;
- } ;
- Definitions.define_lemma {
- l_assumed = true ;
- l_name = axiom ; l_types = 0 ;
- l_forall = F.p_vars lemma ;
- l_triggers = [[Trigger.of_term arr]] ;
- l_lemma = lemma ;
- l_cluster = cluster ;
- } ;
- if denv.monotonic then
- MONOTONIC.generate prefix lfun denv.size_var ft F.e_prod ;
- lfun , ft
-
- let compile = Lang.local generate
- end)
-
-(* -------------------------------------------------------------------------- *)
-(* --- Loading Elementary Values --- *)
-(* -------------------------------------------------------------------------- *)
-
-let loadvalue sigma obj l = match obj with
- | C_int i -> F.e_get (Sigma.value sigma (m_int i)) l
- | C_float f -> F.e_get (Sigma.value sigma (m_float f)) l
- | C_pointer _ -> F.e_get (Sigma.value sigma M_pointer) l
- | C_comp c ->
- let phi,cs = COMP.get c in
- e_fun phi (l :: memories sigma cs)
- | C_array a ->
- let m = Matrix.of_array a in
- let phi,cs = ARRAY.get m in
- e_fun phi ( l :: Matrix.size m @ memories sigma cs )
-
-let () = loadrec := loadvalue
-
-let load sigma obj l = Val (loadvalue sigma obj l)
-
(* -------------------------------------------------------------------------- *)
(* --- Locations --- *)
(* -------------------------------------------------------------------------- *)
@@ -1034,23 +542,17 @@ let null = a_null (* as a loc *)
let literal ~eid cst =
shift (a_global (STRING.get (eid,cst))) (C_int (Ctypes.c_char ())) e_zero
-let cvar x =
- let base = a_global (BASE.get x) in
- if Cil.isArrayType x.vtype then
- let t_elt = Cil.typeOf_array_elem x.vtype in
- shift base (Ctypes.object_of t_elt) e_zero
- else base
+let cvar x = a_global (BASE.get x)
let pointer_loc t = t
let pointer_val t = t
-let get_alloc sigma l = F.e_get (Sigma.value sigma T_alloc) (a_base l)
-let get_last sigma l = e_add (get_alloc sigma l) e_minus_one
+let allocated sigma l = F.e_get (Sigma.value sigma T_alloc) (a_base l)
let base_addr l = a_addr (a_base l) e_zero
let base_offset l = a_base_offset (a_offset l)
let block_length sigma obj l =
- e_fact (Ctypes.sizeof_object obj) (get_alloc sigma l)
+ e_fact (Ctypes.sizeof_object obj) (allocated sigma l)
(* -------------------------------------------------------------------------- *)
(* --- Cast --- *)
@@ -1348,99 +850,80 @@ let cast s l =
"%a" pp_mismatch s ; l
end
-let loc_of_int _ v = F.e_fun a_addr_of_int [v]
-let int_of_loc _ l = F.e_fun a_int_of_addr [l]
+let loc_of_int _ v = F.e_fun f_addr_of_int [v]
+let int_of_loc _ l = F.e_fun f_int_of_addr [l]
(* -------------------------------------------------------------------------- *)
-(* --- Updates --- *)
+(* --- Frames --- *)
(* -------------------------------------------------------------------------- *)
-let domain obj _l = footprint obj
-
-let updated s c l v =
- let m1 = Sigma.value s.pre c in
- let m2 = Sigma.value s.post c in
- [Set(m2,F.e_set m1 l v)]
-
-let havoc_range s obj l n =
- let ps = ref [] in
- Heap.Set.iter
- (fun c ->
- let basename = (Chunk.basename_of_chunk c)^"_undef" in
- let tau = Chunk.tau_of_chunk c in
- let m_undef = e_var (Lang.freshvar ~basename tau) in
- let m1 = Sigma.value s.pre c in
- let m2 = Sigma.value s.post c in
- ps := (p_equal m2 (F.e_fun f_havoc [m_undef;m1;l;n])) :: !ps
- ) (footprint obj) ; !ps
-
-let havoc s obj l = havoc_range s obj l (e_int (size_of_object obj))
-
-let eqmem s obj l =
- let ps = ref [] in
- let n = e_int (size_of_object obj) in
- Heap.Set.iter
- (fun c ->
- let m1 = Sigma.value s.pre c in
- let m2 = Sigma.value s.post c in
- if m1 != m2 then
- ps := F.p_call p_eqmem [m1;m2;l;n] :: !ps
- ) (footprint obj) ; !ps
+let frames obj addr = function
+ | T_alloc -> []
+ | m ->
+ let offset = F.e_int (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
(* -------------------------------------------------------------------------- *)
-(* --- Copy --- *)
+(* --- Loader --- *)
(* -------------------------------------------------------------------------- *)
-let stored s obj l v =
- match obj with
- | C_int i -> updated s (m_int i) l v
- | C_float f -> updated s (m_float f) l v
- | C_pointer _ -> updated s M_pointer l v
- | C_comp _ | C_array _ ->
- Set(loadvalue s.post obj l, v) ::
- (List.map (fun p -> Assert p) (havoc s obj l))
+module MODEL =
+struct
+ module Chunk = Chunk
+ module Sigma = Sigma
+ let name = "MemTyped.LOADER"
+ type nonrec loc = loc
+ let field = field
+ let shift = shift
+ let sizeof = length_of_object
+ let domain = domain
+ let frames = frames
+ let to_addr l = l
+ let to_region_pointer l = 0,l
+ let of_region_pointer _ _ l = l
+
+ let load_int sigma i l = F.e_get (Sigma.value sigma (m_int i)) l
+ let load_float sigma f l = F.e_get (Sigma.value sigma (m_float f)) l
+ let load_pointer sigma _t l = F.e_get (Sigma.value sigma M_pointer) l
+
+ let last sigma obj l =
+ let n = length_of_object obj in
+ e_sub (F.e_div (allocated sigma l) (F.e_int n)) e_one
+
+ let havoc obj loc ~length chunk ~fresh ~current =
+ if chunk <> T_alloc then
+ let n = F.e_fact (length_of_object obj) length in
+ F.e_fun f_havoc [fresh;current;loc;n]
+ else fresh
+
+ let eqmem obj loc _chunk m1 m2 =
+ F.p_call p_eqmem [m1;m2;loc;e_int (length_of_object obj)]
+
+ let eqmem_forall obj loc _chunk m1 m2 =
+ let xp = Lang.freshvar ~basename:"p" t_addr in
+ let p = F.e_var xp in
+ let n = F.e_int (length_of_object obj) in
+ let separated = F.p_call p_separated [p;e_one;loc;n] in
+ let equal = p_equal (e_get m1 p) (e_get m2 p) in
+ [xp],separated,equal
-let copied s obj p q = stored s obj p (loadvalue s.pre obj q)
+ let updated sigma c l v = c , F.e_set (Sigma.value sigma c) l v
-(* -------------------------------------------------------------------------- *)
-(* --- Assignation --- *)
-(* -------------------------------------------------------------------------- *)
+ let store_int sigma i l v = updated sigma (m_int i) l v
+ let store_float sigma f l v = updated sigma (m_float f) l v
+ let store_pointer sigma _ty l v = updated sigma M_pointer l v
-let assigned_loc s obj l =
- match obj with
- | C_int _ | C_float _ | C_pointer _ ->
- let x = Lang.freshvar ~basename:"v" (Lang.tau_of_object obj) in
- List.map Cvalues.equation (stored s obj l (e_var x))
- | C_comp _ | C_array _ ->
- havoc s obj l
-
-let equal_loc s obj l =
- match obj with
- | C_int _ | C_float _ | C_pointer _ ->
- [p_equal (loadvalue s.pre obj l) (loadvalue s.post obj l)]
- | C_comp _ | C_array _ -> eqmem s obj l
-
-let assigned_range s obj l a b =
- let l = shift l obj a in
- let n = e_fact (size_of_object obj) (e_range a b) in
- havoc_range s obj l n
-
-let assigned s obj = function
- | Sloc l -> assigned_loc s obj l
- | Sdescr(xs,l,p) ->
- let xa = Lang.freshvar ~basename:"p" t_addr in
- let la = F.e_var xa in
- let n = F.e_int (size_of_object obj) in
- let sep = F.p_call p_separated [la;n;l;n] in
- let sep_all = F.p_forall xs (F.p_imply p sep) in
- let eq_loc = F.p_conj (equal_loc s obj la) in
- [F.p_forall [xa] (F.p_imply sep_all eq_loc)]
- | Sarray(l,obj,n) ->
- assigned_range s obj l e_zero (e_int (n-1))
- | Srange(l,obj,u,v) ->
- let a = match u with Some a -> a | None -> e_zero in
- let b = match v with Some b -> b | None -> get_last s.pre l in
- assigned_range s obj l a b
+end
+
+module LOADER = MemLoader.Make(MODEL)
+
+let load = LOADER.load
+let stored = LOADER.stored
+let copied = LOADER.copied
+let assigned = LOADER.assigned
(* -------------------------------------------------------------------------- *)
(* --- Loc Comparison --- *)
@@ -1454,11 +937,11 @@ let loc_compare f_cmp i_cmp p q =
let is_null l = p_equal l null
let loc_eq = p_equal
let loc_neq = p_neq
-let loc_lt = loc_compare a_lt p_lt
-let loc_leq = loc_compare a_leq p_leq
+let loc_lt = loc_compare p_addr_lt p_lt
+let loc_leq = loc_compare p_addr_le p_leq
let loc_diff obj p q =
let delta = e_sub (a_offset p) (a_offset q) in
- let size = e_int (size_of_object obj) in
+ let size = e_int (length_of_object obj) in
e_div delta size
(* -------------------------------------------------------------------------- *)
@@ -1474,10 +957,10 @@ let s_invalid sigma p n =
let segment phi = function
| Rloc(obj,l) ->
- phi l (e_int (size_of_object obj))
+ phi l (e_int (length_of_object obj))
| Rrange(l,obj,Some a,Some b) ->
let l = shift l obj a in
- let n = e_fact (size_of_object obj) (e_range a b) in
+ let n = e_fact (length_of_object obj) (e_range a b) in
phi l n
| Rrange(l,_,a,b) ->
Wp_parameters.abort ~current:true
@@ -1507,7 +990,7 @@ let scope seq scope xs =
(fun m x ->
let size = match scope with
| Sigs.Leave -> 0
- | Sigs.Enter -> size_of_typ x.vtype
+ | Sigs.Enter -> length_of_typ x.vtype
in F.e_set m (BASE.get x) (e_int size))
(Sigma.value seq.pre T_alloc) xs in
[ p_equal (Sigma.value seq.post T_alloc) alloc ]
@@ -1515,58 +998,18 @@ let scope seq scope xs =
let global _sigma p = p_leq (e_fun f_region [a_base p]) e_zero
(* -------------------------------------------------------------------------- *)
-(* --- Domain --- *)
+(* --- Segments --- *)
(* -------------------------------------------------------------------------- *)
-type range =
- | LOC of term * term (* loc - size *)
- | RANGE of term * Vset.set (* base - range offset *)
+let included =
+ let addrof l = l in
+ let sizeof = length_of_object in
+ MemMemory.included ~shift ~addrof ~sizeof
-let range = function
- | Rloc(obj,l) ->
- LOC( l , e_int (size_of_object obj) )
- | Rrange(l,obj,Some a,Some b) ->
- let l = shift l obj a in
- let n = e_fact (size_of_object obj) (e_range a b) in
- LOC( l , n )
- | Rrange(l,_obj,None,None) ->
- RANGE( a_base l , Vset.range None None )
- | Rrange(l,obj,Some a,None) ->
- let se = size_of_object obj in
- RANGE( a_base l , Vset.range (Some (e_fact se a)) None )
- | Rrange(l,obj,None,Some b) ->
- let se = size_of_object obj in
- RANGE( a_base l , Vset.range None (Some (e_fact se 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)
- | RANGE(base,set) -> base , set
-
-let r_included r1 r2 =
- match r1 , r2 with
- | LOC(l1,n1) , LOC(l2,n2) ->
- p_call p_included [l1;n1;l2;n2]
- | _ ->
- let base1,set1 = range_set r1 in
- let base2,set2 = range_set r2 in
- p_if (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) ->
- p_call p_separated [l1;n1;l2;n2]
- | _ ->
- let base1,set1 = range_set r1 in
- let base2,set2 = range_set r2 in
- p_imply (p_equal base1 base2) (Vset.disjoint set1 set2)
-
-let included s1 s2 = r_included (range s1) (range s2)
-let separated s1 s2 = r_disjoint (range s1) (range s2)
+let separated =
+ let addrof l = l in
+ let sizeof = length_of_object in
+ MemMemory.separated ~shift ~addrof ~sizeof
(* -------------------------------------------------------------------------- *)
(* --- State Model --- *)
@@ -1583,7 +1026,7 @@ let rec lookup_a e =
and lookup_f f es =
try match RegisterShift.find f , es with
| RS_Field(fd,_) , [e] -> Mstate.field (lookup_lv e) fd
- | RS_Shift _ , [e;k] -> Mstate.index (lookup_lv e) k
+ | RS_Index _ , [e;k] -> Mstate.index (lookup_lv e) k
| _ -> raise Not_found
with Not_found when es = [] ->
Sigs.(Mvar (RegisterBASE.find f),[])
diff --git a/src/plugins/wp/MemTyped.mli b/src/plugins/wp/MemTyped.mli
index 6c23647b4fe25faa6e81b96584cbae0f23199dae..5bd5298918c5a58fba5741d150fb2c19e81c1aea 100644
--- a/src/plugins/wp/MemTyped.mli
+++ b/src/plugins/wp/MemTyped.mli
@@ -28,11 +28,3 @@ include Sigs.Model
type pointer = NoCast | Fits | Unsafe
val pointer : pointer Context.value
-val f_havoc : Lang.lfun
-val p_separated : Lang.lfun
-val p_included : Lang.lfun
-val p_valid_rd : Lang.lfun
-val p_valid_rw : Lang.lfun
-val p_invalid : Lang.lfun
-val a_base : Lang.F.term -> Lang.F.term
-val a_offset : Lang.F.term -> Lang.F.term
diff --git a/src/plugins/wp/MemVar.ml b/src/plugins/wp/MemVar.ml
index b4d8a304b5e39ebcfb26c760a27b16bc269f24c9..58845184bfd33806fb328bf9d3fdbecb4f842b8a 100644
--- a/src/plugins/wp/MemVar.ml
+++ b/src/plugins/wp/MemVar.ml
@@ -1016,14 +1016,15 @@ struct
let eqk = p_forall (y::ys) (p_imply ek (p_equal ak bk)) in
assigned_path (eqk :: hs) xs ys ae be ofs
- let assigned_descr s xs mem x ofs p =
+ let assigned_genset s xs mem x ofs p =
let valid = valid_offset_path s.post Sigs.RW mem x ofs in
let a = get_term s.pre x in
let b = get_term s.post x in
let a_ofs = access a ofs in
let b_ofs = access b ofs in
let p_sloc = p_forall xs (p_hyps [valid;p_not p] (p_equal a_ofs b_ofs)) in
- assigned_path [p_sloc] xs [] a b ofs
+ let conds = assigned_path [p_sloc] xs [] a b ofs in
+ List.map (fun p -> Assert p) conds
(* -------------------------------------------------------------------------- *)
(* --- Assigned --- *)
@@ -1034,8 +1035,7 @@ struct
| Val((CVAL|CREF),_,[]) -> [] (* full update *)
| Val((CVAL|CREF),_,_) as vloc ->
let v = Lang.freshvar ~basename:"v" (Lang.tau_of_object obj) in
- let eqs = stored seq obj vloc (e_var v) in
- List.map Cvalues.equation eqs
+ stored seq obj vloc (e_var v)
| Val((HEAP|CTXT|CARR) as m,x,ofs) ->
M.assigned (mseq_of_seq seq) obj (Sloc (mloc_of_path m x ofs))
| Loc l ->
@@ -1048,8 +1048,7 @@ struct
| Val((CVAL|CREF),_,_) as vloc ->
let te = Lang.tau_of_object elt in
let v = Lang.freshvar ~basename:"v" Qed.Logic.(Array(Int,te)) in
- let eqs = stored seq obj vloc (e_var v) in
- List.map Cvalues.equation eqs
+ stored seq obj vloc (e_var v)
| 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))
@@ -1067,7 +1066,7 @@ struct
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
- assigned_descr 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
@@ -1077,7 +1076,7 @@ struct
| Val((HEAP|CTXT|CARR) as m,x,ofs) ->
M.assigned (mseq_of_seq seq) obj (Sdescr(xs,mloc_of_path m x ofs,p))
| Val((CVAL|CREF) as m,x,ofs) ->
- assigned_descr 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
diff --git a/src/plugins/wp/ProofScript.ml b/src/plugins/wp/ProofScript.ml
index 6649d349e675155a87176d1a248a5943af7414fe..35a027f61a35a1e10590516cd76d315596172eed 100644
--- a/src/plugins/wp/ProofScript.ml
+++ b/src/plugins/wp/ProofScript.ml
@@ -445,13 +445,13 @@ class console ~pool ~title =
?range:bool -> ?vmin:int -> ?vmax:int ->
?filter:(Lang.F.term -> bool) -> 'a field -> unit =
fun ?enabled ?title ?tooltip ?range ?vmin ?vmax ?filter field ->
- ignore enabled ;
- ignore title ;
- ignore tooltip ;
- ignore field ;
- ignore vmin ; ignore vmax ;
- ignore range ; ignore filter ;
- ()
+ ignore enabled ;
+ ignore title ;
+ ignore tooltip ;
+ ignore field ;
+ ignore vmin ; ignore vmax ;
+ ignore range ; ignore filter ;
+ ()
val mutable errors = false
method has_error = errors
diff --git a/src/plugins/wp/ProverTask.ml b/src/plugins/wp/ProverTask.ml
index 02390f98b1457e6db09d01ab35b71303f18d0f7e..a2e6ea942697d83376ea55d968f1922ede00a6b9 100644
--- a/src/plugins/wp/ProverTask.ml
+++ b/src/plugins/wp/ProverTask.ml
@@ -114,7 +114,7 @@ let dump_buffer buffer = function
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.is_out () then
+ else if Wp_parameters.has_out () then
Extlib.safe_remove log
let echo_buffer buffer =
diff --git a/src/plugins/wp/ProverWhy3.ml b/src/plugins/wp/ProverWhy3.ml
index 60d1afb8b05d673eb9424b932c60298691c0a330..951cb4e249c9b8497003de3f9320f01a8513f37f 100644
--- a/src/plugins/wp/ProverWhy3.ml
+++ b/src/plugins/wp/ProverWhy3.ml
@@ -1164,10 +1164,10 @@ module MODE = WpContext.StaticGenerator(Datatype.Unit)
parse_mode ~origin ~fallback:"-wp-cache" (Sys.getenv origin)
with Not_found ->
try
- parse_mode ~origin:"-wp-cache" ~fallback:"'none'"
+ parse_mode ~origin:"-wp-cache" ~fallback:"none"
(Wp_parameters.Cache.get())
with Not_found ->
- if Wp_parameters.Session.Dir_name.is_set ()
+ if Wp_parameters.has_session ()
then Update else NoCache
end)
diff --git a/src/plugins/wp/RefUsage.ml b/src/plugins/wp/RefUsage.ml
index 53160d9ae3070bd72330806bc457fbf4084ab11e..99ff308844e40829b59d021f5589426226507d0e 100644
--- a/src/plugins/wp/RefUsage.ml
+++ b/src/plugins/wp/RefUsage.ml
@@ -32,12 +32,13 @@ open Cil_datatype
(* --- Varinfo Accesses --- *)
(* ---------------------------------------------------------------------- *)
+(** By lattice order of usage *)
type access =
- | NoAccess
- | ByRef (* The expr ["*x"], equals to [load(load(&x))] *)
- | ByArray (* The expr ["x[_]"], equals to [load(shift(load(&x),_))] *)
- | ByValue (* The expr ["x"], equals to [load(&x)] *)
- | ByAddr (* The expr ["&x"] *)
+ | NoAccess (** Never used *)
+ | ByRef (** Only used as ["*x"], equals to [load(shift(load(&x),0))] *)
+ | ByArray (** Only used as ["x[_]"], equals to [load(shift(load(&x),_))] *)
+ | ByValue (** Only used as ["x"], equals to [load(&x)] *)
+ | ByAddr (** Widely used, potentially up to ["&x"] *)
module Access :
sig
@@ -59,8 +60,8 @@ struct
let rank = function
| NoAccess -> 0
| ByRef -> 1
- | ByValue -> 2
- | ByArray -> 3
+ | ByArray -> 2
+ | ByValue -> 3
| ByAddr -> 4
let cup a b = if rank a < rank b then b else a
@@ -357,7 +358,8 @@ and expr (e:Cil_types.exp) : model = match e.enode with
| CastE(ty_tgt,e) -> cast (cast_ctyp ty_tgt (Cil.typeOf e)) (expr e)
(* Address *)
- | AddrOf lval | StartOf lval -> lvalue lval
+ | AddrOf lval -> lvalue lval
+ | StartOf lval -> startof (lvalue lval) (Cil.typeOfLval lval)
(* Load *)
| Lval lval -> load (lvalue lval)
@@ -372,6 +374,9 @@ and offset (m:model) = function
| Field(_,ofs) -> offset (field m) ofs
| Index(e,ofs) -> offset (shift m (vexpr e)) ofs
+and startof (m:model) typ =
+ if Cil.isArrayType typ then shift m E.bot else m
+
(* ---------------------------------------------------------------------- *)
(* --- Compilation of ACSL-Terms --- *)
(* ---------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/RefUsage.mli b/src/plugins/wp/RefUsage.mli
index d68b05f7d487d4e5ac1ae00f4385160aa5659d10..9fa8852d6c99279a3855cafa3c04af876720c1a6 100644
--- a/src/plugins/wp/RefUsage.mli
+++ b/src/plugins/wp/RefUsage.mli
@@ -26,12 +26,13 @@
open Cil_types
+(** By lattice order of usage *)
type access =
- | NoAccess
- | ByRef (* The expression ["*x"], equal to [load(load(&x))] *)
- | ByArray (* The expression ["x[_]"], equal to [load(shift(load(&x),_))] *)
- | ByValue (* The expression ["x"], equal to [load(&x)] *)
- | ByAddr (* The expression ["&x"] *)
+ | NoAccess (** Never used *)
+ | ByRef (** Only used as ["*x"], equals to [load(shift(load(&x),0))] *)
+ | ByArray (** Only used as ["x[_]"], equals to [load(shift(load(&x),_))] *)
+ | ByValue (** Only used as ["x"], equals to [load(&x)] *)
+ | ByAddr (** Widely used, potentially up to ["&x"] *)
val get : ?kf:kernel_function -> ?init:bool -> varinfo -> access
diff --git a/src/plugins/wp/Region.ml b/src/plugins/wp/Region.ml
index 22813de5c12093676432f308fbce7fec0de96961..dc77afe871e5063a16ec80c7a15e096c539fd10b 100644
--- a/src/plugins/wp/Region.ml
+++ b/src/plugins/wp/Region.ml
@@ -20,254 +20,630 @@
(* *)
(**************************************************************************)
+open Cil_datatype
+open Layout
+
+module Wp = Wp_parameters
+
(* -------------------------------------------------------------------------- *)
-(* --- Logic Path and Regions --- *)
+(* --- Access Maps --- *)
(* -------------------------------------------------------------------------- *)
-open Qed.Logic
-open Lang
-open Lang.F
-open Vset
+module Vmap = Varinfo.Map
+module Smap = Datatype.String.Map
+module Rmap = Qed.Intmap
+module Rset = Qed.Intset
+module Dmap = Qed.Listmap.Make(Offset)
+module Dset = Qed.Listset.Make(Deref)
+module Acs = Qed.Listset.Make(Lvalue)
+module Class = Qed.Listset.Make(Datatype.String)
+module Ranks = Qed.Listset.Make(Datatype.Int)
+
+type region = {
+ id : int ;
+ mutable garbled : bool ;
+ mutable rw : bool ;
+ mutable pack : bool ;
+ mutable flat : bool ;
+ mutable names : Class.t ;
+ mutable alias : alias ;
+ mutable delta : int Dmap.t ;
+ mutable deref : Dset.t ;
+ mutable read : Acs.t ;
+ mutable written : Acs.t ;
+ mutable shifted : Acs.t ;
+ mutable copiedTo : Rset.t ; (* copies to *)
+ mutable pointsTo : int option ;
+}
+
+type map = {
+ cache : Offset.cache ;
+ queue : int Queue.t ;
+ mutable rid : int ;
+ mutable vars : int Vmap.t ;
+ mutable return : int ; (* -1 when undefined *)
+ mutable strings : (int * string) Rmap.t ; (* eid -> rid *)
+ mutable index : int Smap.t ;
+ mutable region : region Rmap.t ;
+ mutable aliasing : int Rmap.t ;
+ mutable cluster : region cluster Rmap.t ;
+ mutable roots : root Rmap.t ;
+ mutable froms : region from list Rmap.t ;
+ mutable mranks : Ranks.t Rmap.t ; (* set of sizeof(ds) accessed by shifting *)
+ mutable mdims : int list Rmap.t ; (* common dim prefix accessed from cluster *)
+ mutable domain : Rset.t ; (* reachable regions via clusters *)
+ mutable chunk : region chunk Rmap.t ; (* memory chunks *)
+}
+
+let create () = {
+ rid = 0 ;
+ return = (-1) ;
+ cache = Offset.cache () ;
+ vars = Vmap.empty ;
+ strings = Rmap.empty ;
+ index = Smap.empty ;
+ region = Rmap.empty ;
+ aliasing = Rmap.empty ;
+ queue = Queue.create () ;
+ cluster = Rmap.empty ;
+ roots = Rmap.empty ;
+ froms = Rmap.empty ;
+ mranks = Rmap.empty ;
+ mdims = Rmap.empty ;
+ domain = Rset.empty ;
+ chunk = Rmap.empty ;
+}
+
+let noid = 0
+let is_empty map = (map.rid = 0)
+
+let fresh map =
+ let id = map.rid in
+ map.rid <- succ id ;
+ let region = {
+ id ;
+ garbled = false ;
+ rw = RW.default () ;
+ flat = Flat.default () ;
+ pack = Pack.default () ;
+ names = [] ;
+ alias = NotUsed ;
+ delta = Dmap.empty ;
+ deref = Dset.empty ;
+ read = Acs.empty ;
+ written = Acs.empty ;
+ shifted = Acs.empty ;
+ copiedTo = Rset.empty ;
+ pointsTo = None ;
+ } in
+ map.region <- Rmap.add id region map.region ;
+ region
-type path = offset list
-and offset =
- | Oindex of term
- | Ofield of field
+(* -------------------------------------------------------------------------- *)
+(* --- Datatype --- *)
+(* -------------------------------------------------------------------------- *)
-let rec access e = function
- | [] -> e
- | Oindex k :: path -> access (e_get e k) path
- | Ofield f :: path -> access (e_getfield e f) path
+module R =
+struct
+ type t = region
+ let id a = a.id
+ let equal a b = (a.id = b.id)
+ let compare a b = Pervasives.compare a.id b.id
+ let pp_rid fmt id = Format.fprintf fmt "R%03d" id
+ let pretty fmt r = pp_rid fmt r.id
+end
-let rec update e path v =
- match path with
- | [] -> v
- | Oindex k :: tail ->
- let e_k = update (e_get e k) tail v in
- e_set e k e_k
- | Ofield f :: tail ->
- let e_f = update (e_getfield e f) tail v in
- e_setfield e f e_f
+module Map = Qed.Idxmap.Make(R)
+module Set = Qed.Idxset.Make(R)
(* -------------------------------------------------------------------------- *)
-(* --- Region --- *)
+(* --- Union Find --- *)
(* -------------------------------------------------------------------------- *)
-type rpath = roffset list
-and roffset =
- | Rindex of set
- | Rfield of field
+let rec aliasing map i =
+ try
+ let j = aliasing map (Rmap.find i map.aliasing) in
+ if j <> i then map.aliasing <- Rmap.add i j map.aliasing ; j
+ with Not_found -> i
+
+let linkto map i k =
+ if i <> k then
+ begin
+ map.aliasing <- Rmap.add i k map.aliasing ;
+ Queue.add i map.queue ;
+ end
+
+let region map r =
+ try Rmap.find (aliasing map r) map.region
+ with Not_found -> failwith "Wp.Region: Undefined Region"
+
+let join_classes map i j =
+ let k = min i j in (linkto map i k ; linkto map j k ; k)
+
+let join_id map i j =
+ let i = aliasing map i in
+ let j = aliasing map j in
+ if i = j then i else join_classes map i j
+
+let join_region map ra rb =
+ let i = aliasing map ra.id in
+ let j = aliasing map rb.id in
+ let k = join_classes map i j in
+ if k = i then ra else
+ if k = j then rb else
+ (* defensive *) region map k
-type region =
- | Empty
- | Full
- | Fields of (field * region) list (* SORTED, DEFAULT : empty *)
- | Indices of set * ( set * region ) list
- (* Indices for FULL region.
- Then indices for non-FULL and non-EMPTY regions *)
+(* -------------------------------------------------------------------------- *)
+(* --- Aliasing --- *)
+(* -------------------------------------------------------------------------- *)
-let empty = Empty
-let full = Full
+let alias map a b =
+ let k = join_id map a.id b.id in
+ let r = region map k in
+ r.alias <- Aliased ; r
-let rec path = function
- | [] -> Full
- | Oindex k :: tail ->
- let r = path tail in
- let s = Vset.singleton k in
- begin
- match r with (* never Empty *)
- | Full -> Indices(s,[])
- | _ -> Indices(Vset.empty,[s,r])
- end
- | Ofield f :: tail ->
- Fields [f,path tail]
+let do_alias map a b = ignore (alias map a b)
+
+let add_alias map ~into:a b =
+ let i = aliasing map a.id in
+ let j = aliasing map b.id in
+ let wa = (region map i).alias in
+ let wb = (region map j).alias in
+ let k = join_classes map i j in
+ (* Aliasing has changed *)
+ (region map k).alias <- Alias.alias wa (Alias.use wb)
+
+let get_merged map r =
+ let i = aliasing map r.id in
+ if i <> r.id then Some (region map i) else None
+
+let get_alias map r =
+ let i = aliasing map r.id in
+ if i <> r.id then region map i else r
+
+let eq_alias map a b = (aliasing map a.id = aliasing map b.id)
+
+(* -------------------------------------------------------------------------- *)
+(* --- General Iterator --- *)
+(* -------------------------------------------------------------------------- *)
+
+let once mark r =
+ if Rset.mem r.id !mark then false
+ else ( mark := Rset.add r.id !mark ; true )
+
+let iter map f =
+ let do_once marks f r = if once marks r then f r else () in
+ Rmap.iter (do_once (ref Rset.empty) f) map.region
+
+(* -------------------------------------------------------------------------- *)
+(* --- Region Accessor --- *)
+(* -------------------------------------------------------------------------- *)
+
+let id reg = reg.id
+let is_garbled reg = reg.garbled
+let has_pointed reg = reg.pointsTo <> None
+let has_deref reg = not (Dset.is_empty reg.deref)
+let has_layout reg = not (Dmap.is_empty reg.delta)
+let has_offset reg d = Dmap.mem d reg.delta
+let iter_offset map f reg =
+ Dmap.iter (fun ofs r -> f ofs (region map r)) reg.delta
+
+let has_copies reg = not (Rset.is_empty reg.copiedTo)
+let iter_copies map f reg =
+ Rset.iter (fun r -> f (region map r)) reg.copiedTo
+
+let add_offset map reg d =
+ try region map (Dmap.find d reg.delta)
+ with Not_found ->
+ let rd = fresh map in
+ reg.delta <- Dmap.add d rd.id reg.delta ; rd
+
+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 get_addrof map reg =
+ let addr = fresh map in
+ addr.pointsTo <- Some reg.id ; addr
+
+let get_pointed map reg =
+ match reg.pointsTo with
+ | None -> None
+ | Some r -> Some (region map r)
+
+let get_offset map reg d =
+ try Some (region map (Dmap.find d reg.delta))
+ with Not_found -> None
+
+let get_copies map reg =
+ List.map (region map) (Rset.elements reg.copiedTo)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Access --- *)
+(* -------------------------------------------------------------------------- *)
+
+let acs_read rg lvalue = rg.read <- Acs.add lvalue rg.read
+let acs_write rg lvalue = rg.written <- Acs.add lvalue rg.written
+let acs_shift rg lvalue = rg.shifted <- Acs.add lvalue rg.shifted
+let acs_deref rg deref = rg.deref <- Dset.add deref rg.deref
+let acs_copy ~src ~tgt =
+ if tgt.id <> src.id then src.copiedTo <- Rset.add tgt.id src.copiedTo
+
+let iter_read f rg = Acs.iter f rg.read
+let iter_write f rg = Acs.iter f rg.written
+let iter_shift f rg = Acs.iter f rg.shifted
+let iter_deref f rg = Dset.iter f rg.deref
+
+let is_read rg = not (Acs.is_empty rg.read)
+let is_written rg = not (Acs.is_empty rg.written)
+let is_shifted rg = not (Acs.is_empty rg.shifted)
+let is_aliased rg = Alias.is_aliased rg.alias
+
+(* -------------------------------------------------------------------------- *)
+(* --- Varinfo Index --- *)
+(* -------------------------------------------------------------------------- *)
+
+let rvar map x r =
+ let reg = region map r in
+ if reg.id <> r then map.vars <- Vmap.add x reg.id map.vars ; reg
+
+let of_null map = fresh map (* A fresh region each time: polymorphic *)
+
+let of_cvar map x =
+ try rvar map x (Vmap.find x map.vars)
+ with Not_found ->
+ let reg = fresh map in
+ map.vars <- Vmap.add x reg.id map.vars ; reg
+
+let of_return map =
+ if map.return < 0 then
+ let reg = fresh map in
+ map.return <- reg.id ; reg
+ else
+ region map map.return
+
+let has_return map = 0 <= map.return
+
+let iter_vars map f = Vmap.iter (fun x r -> f x (rvar map x r)) map.vars
+
+(* -------------------------------------------------------------------------- *)
+(* --- Field Info Index --- *)
+(* -------------------------------------------------------------------------- *)
+
+let field_offset map fd = Offset.field_offset map.cache fd
+
+(* -------------------------------------------------------------------------- *)
+(* --- String Literal Index --- *)
+(* -------------------------------------------------------------------------- *)
+
+let of_cstring map ~eid ~cst =
+ try region map (fst @@ Rmap.find eid map.strings)
+ with Not_found ->
+ let reg = fresh map in
+ map.strings <- Rmap.add eid (reg.id,cst) map.strings ; reg
+
+let iter_strings map f =
+ Rmap.iter (fun (rid,cst) -> f (region map rid) cst) map.strings
+
+(* -------------------------------------------------------------------------- *)
+(* --- Region Index --- *)
+(* -------------------------------------------------------------------------- *)
+
+let rindex map a r =
+ let reg = region map r in
+ if reg.id <> r then map.index <- Smap.add a reg.id map.index ; reg
+
+let of_name map a =
+ try rindex map a (Smap.find a map.index)
+ with Not_found ->
+ let reg = fresh map in
+ reg.names <- [a] ;
+ map.index <- Smap.add a reg.id map.index ; reg
-let rec rpath = function
- | [] -> Full
- | Rindex s :: tail ->
- let r = rpath tail in
+let of_class map = function
+ | None -> fresh map
+ | Some a -> of_name map a
+
+let has_names reg = not (Class.is_empty reg.names)
+let iter_names map f = Smap.iter (fun a r -> f a (rindex map a r)) map.index
+
+(* -------------------------------------------------------------------------- *)
+(* --- Fusion --- *)
+(* -------------------------------------------------------------------------- *)
+
+let merge_pointed map u v =
+ match u,v with
+ | None , w | w , None -> w
+ | Some i , Some j -> Some (join_id map i j)
+
+let merge_delta map _d a b = join_id map a b
+
+let merge_region map ~id a b =
+ {
+ id ;
+ garbled = a.garbled || b.garbled ;
+ rw = RW.merge a.rw b.rw ;
+ flat = Flat.merge a.flat b.flat ;
+ pack = Pack.merge a.pack b.pack ;
+ alias = Alias.merge a.alias b.alias ;
+ names = Class.union a.names b.names ;
+ read = Acs.union a.read b.read ;
+ written = Acs.union a.written b.written ;
+ shifted = Acs.union a.shifted b.shifted ;
+ copiedTo = Rset.union a.copiedTo b.copiedTo ;
+ pointsTo = merge_pointed map a.pointsTo b.pointsTo ;
+ delta = Dmap.union (merge_delta map) a.delta b.delta ;
+ deref = Dset.union a.deref b.deref ;
+ }
+
+let fusion map =
+ while not (Queue.is_empty map.queue) do
+ let i = Queue.pop map.queue in
+ let j = aliasing map i in
+ if i <> j then
begin
- match r with (* never Empty *)
- | Full -> Indices(s,[])
- | _ -> Indices(Vset.empty,[s,r])
+ if not (Wp.Region_fixpoint.get ()) then
+ Wp.debug "Region %a -> %a" R.pp_rid i R.pp_rid j ;
+ let a = try Rmap.find i map.region with Not_found -> assert false in
+ let b = try Rmap.find j map.region with Not_found -> assert false in
+ assert (i = a.id) ;
+ assert (j = b.id ) ;
+ let c = merge_region map ~id:j a b in
+ map.region <- Rmap.add j c (Rmap.remove i map.region) ;
end
- | Rfield f :: tail ->
- Fields [f,rpath tail]
-
-let rec merge a b =
- match a , b with
- | Full , _ | _ , Full -> Full
- | Empty , c | c , Empty -> c
- | Fields fxs , Fields gys -> Fields (merge_fields fxs gys)
- | Indices(s1,kxs) , Indices(s2,kys) ->
- Indices(Vset.union s1 s2,kxs @ kys)
- | Fields _ , Indices _
- | Indices _ , Fields _ -> assert false
-
-and merge_fields fxs gys =
- match fxs , gys with
- | [] , w | w , [] -> w
- | (f,x)::fxstail , (g,y)::gystail ->
- let c = Field.compare f g in
- if c < 0 then (f,x)::merge_fields fxstail gys else
- if c > 0 then (g,y)::merge_fields fxs gystail else
- (f,merge x y) :: merge_fields fxstail gystail
-
-(* -------------------------------------------------------------------------- *)
-(* --- Disjunction --- *)
-(* -------------------------------------------------------------------------- *)
-
-let rec disjoint a b =
- match a , b with
- | Empty , _ | _ , Empty -> p_true
- | Full , _ | _ , Full -> p_false
-
- | Fields fxs , Fields gys ->
- p_conj (disjoint_fields fxs gys)
-
- | Indices(s,xs) , Indices(t,ts) ->
- p_conj (disjoint_indices [Vset.disjoint s t] xs ts)
-
- | Fields _ , Indices _
- | Indices _ , Fields _ -> assert false
-
-and disjoint_fields frs grs =
- match frs , grs with
- | [] , _ | _ , [] -> []
- | (f,r)::ftail , (g,s)::gtail ->
- let c = Field.compare f g in
- if c < 0 then disjoint_fields ftail grs else
- if c > 0 then disjoint_fields frs gtail else
- disjoint r s :: disjoint_fields ftail gtail
-
-and disjoint_indices w sr1 sr2 =
- List.fold_left
- (fun w (s1,r1) ->
- List.fold_left
- (fun w (s2,r2) ->
- (p_or (Vset.disjoint s1 s2) (disjoint r1 r2)) :: w
- ) w sr2
- ) w sr1
-
-(* -------------------------------------------------------------------------- *)
-(* --- Region Inclusion --- *)
-(* -------------------------------------------------------------------------- *)
-
-let rec subset r1 r2 =
- match r1 , r2 with
- | _ , Full -> p_true
- | Empty , _ -> p_true
- | _ , Empty -> p_false
- | Full , _ -> p_false
- | Fields frs , Fields grs -> subset_fields frs grs
- | Indices(s1,ks1) , Indices(s2,ks2) ->
- p_and
- (Vset.subset s1 s2) (* because FULL never appears in ks2 *)
- (p_all (fun (s1,r1) -> subset_indices s1 r1 ks2) ks1)
- | Fields _ , Indices _
- | Indices _ , Fields _ -> assert false
-
-and subset_fields frs grs =
- match frs , grs with
- | [] , _ -> p_true
- | _ , [] -> p_false
- | (f,r)::ftail , (g,s)::gtail ->
- let c = Field.compare f g in
- if c < 0 then p_false (* only f is present *) else
- if c > 0 then subset_fields frs gtail (* g is not present *)
- else (* f=g *)
- p_and (subset r s) (subset_fields ftail gtail)
-
-(* All path (k,p) in (s1,r1) are in ks2
- = AND (k in s1 -> p in r1 -> (k,p) in ks2
- = AND (k in s1 -> p in r1 -> (OR (k in s2 and p in r2) for (s2,r2) in r2)
- = AND (k in s1 -> OR (k in s2 and r1 in r2) for (s2,r2) in r2)
- = AND (k in s1 -> subset_index k r1 ks2)
-*)
-and subset_indices s1 r1 ks2 =
- p_all (fun w ->
- let xs,e,p = Vset.descr w in
- p_forall xs
- (p_imply p (subset_index e r1 ks2))
- ) s1
-
-(* OR (k in s2 and r1 in r2) for (s2,r2) in r2) *)
-and subset_index e r1 ks2 =
- p_any (fun (s2,r2) ->
- p_and (Vset.member e s2) (subset r1 r2)
- ) ks2
-
-(* -------------------------------------------------------------------------- *)
-(* --- Equality outside a Region --- *)
-(* -------------------------------------------------------------------------- *)
-
-let rec equal_but t r a b =
- match t , r with
- | _ , Full -> p_true
- | _ , Empty -> p_equal a b
- | _ , Fields grs ->
- let fs = List.sort Field.compare (fields_of_tau t) in
- p_conj (equal_but_fields a b fs grs)
- | Array(ta,tb) , Indices(s,krs) ->
- let x = freshvar ta in
- let k = e_var x in
- let a_k = e_get a k in
- let b_k = e_get b k in
- p_forall [x] (p_conj (equal_but_index tb k a_k b_k s krs))
- | _ -> assert false
-
-and equal_but_fields a b fts grs =
- match fts , grs with
- | [] , _ -> []
- | _ , [] ->
- List.map (fun f -> p_equal (e_getfield a f) (e_getfield b f)) fts
- | f::ftail , (g,r)::gtail ->
- let c = Field.compare f g in
- if c < 0 then
- let eqf = p_equal (e_getfield a f) (e_getfield b f) in
- eqf :: equal_but_fields a b ftail grs
- else
- if c > 0 then
- (* field g does not appear *)
- equal_but_fields a b fts gtail
- else
- let tf = tau_of_field f in
- let eqf = equal_but tf r (e_getfield a f) (e_getfield b f) in
- eqf :: equal_but_fields a b ftail gtail
-
-and equal_but_index tb k a_k b_k s krs =
- List.map
- (fun (s,r) -> p_or (Vset.member k s) (equal_but tb r a_k b_k))
- ((s,Full)::krs)
-
-(* -------------------------------------------------------------------------- *)
-(* --- Utils --- *)
-(* -------------------------------------------------------------------------- *)
-
-let rec occurs x = function
- | Empty | Full -> false
- | Fields frs -> List.exists (fun (_,r) -> occurs x r) frs
- | Indices(s,srs) -> Vset.occurs x s || List.exists (occurs_idx x) srs
-
-and occurs_idx x (s,r) = Vset.occurs x s || occurs x r
-
-let rec vars = function
- | Empty | Full -> Vars.empty
- | Fields frs ->
- List.fold_left
- (fun xs (_,r) -> Vars.union xs (vars r))
- Vars.empty frs
- | Indices(s,srs) ->
- List.fold_left
- (fun xs (s,r) -> Vars.union xs (Vars.union (Vset.vars s) (vars r)))
- (Vset.vars s) srs
-
-(* -------------------------------------------------------------------------- *)
-(* --- Pretty --- *)
-(* -------------------------------------------------------------------------- *)
-
-let pretty fmt = function
- | Empty -> Format.fprintf fmt "empty"
- | Full -> Format.fprintf fmt "full"
- | Fields _ -> Format.fprintf fmt "fields" (*TODO*)
- | Indices _ -> Format.fprintf fmt "indices" (*TODO*)
+ done
+
+let fusionned map = not (Queue.is_empty map.queue)
+let iter_fusion map f = Queue.iter (fun i -> f i (region map i)) map.queue
+
+(* -------------------------------------------------------------------------- *)
+(* --- Garbling --- *)
+(* -------------------------------------------------------------------------- *)
+
+let rec garblify map reg =
+ if not reg.garbled then
+ begin
+ reg.garbled <- true ;
+ Dmap.iter
+ (fun _delta r ->
+ garblify map (region map r) ;
+ ignore (join_id map reg.id r) ;
+ ) reg.delta ;
+ reg.delta <- Dmap.empty ;
+ end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Clustering --- *)
+(* -------------------------------------------------------------------------- *)
+
+let cluster map reg =
+ try Rmap.find reg.id map.cluster
+ with Not_found -> Layout.Empty
+
+module Cluster =
+struct
+ open Layout
+
+ let rec from_region map reg =
+ try Rmap.find reg.id map.cluster
+ with Not_found ->
+ if reg.garbled then Garbled else
+ if not (Wp.Region_cluster.get ()) then Empty else
+ begin
+ map.cluster <- Rmap.add reg.id Empty map.cluster ;
+ let mu ~raw ra rb =
+ if raw then
+ begin
+ garblify map ra ;
+ garblify map rb ;
+ end ;
+ join_region map ra rb
+ in
+ let cluster =
+ if has_layout reg then
+ Cluster.reshape ~eq:R.equal ~flat:reg.flat ~pack:reg.pack @@
+ from_layout map mu reg
+ else
+ from_deref map mu reg
+ in
+ if cluster = Garbled then garblify map reg ;
+ map.cluster <- Rmap.add reg.id cluster map.cluster ;
+ cluster
+ end
+
+ and from_deref map mu reg =
+ let pointed = lazy (add_pointed map reg) in
+ List.fold_left
+ (fun chunk deref ->
+ Cluster.merge R.pretty mu chunk (Cluster.deref ~pointed deref)
+ ) Empty reg.deref
+
+ and from_layout map mu reg =
+ Dmap.fold
+ (fun offset tgt acc ->
+ let layout = shift map offset (region map tgt) in
+ Cluster.merge R.pretty mu (Layout layout) acc
+ ) reg.delta Empty
+
+ and shift map offset target =
+ let inline = Wp.Region_inline.get () || not (is_aliased target) in
+ let cluster = from_region map target in
+ Cluster.shift map.cache R.pretty offset target ~inline cluster
+
+ let compute map reg =
+ begin
+ if has_layout reg && has_deref reg then
+ begin
+ Dset.iter
+ (fun deref ->
+ let target = add_offset map reg (Index(snd deref,1)) in
+ target.read <- Acs.union reg.read target.read ;
+ target.written <- Acs.union reg.written target.written ;
+ acs_deref target deref
+ ) reg.deref ;
+ reg.deref <- Dset.empty ;
+ reg.read <- Acs.empty ;
+ reg.written <- Acs.empty ;
+ Queue.add reg.id map.queue ;
+ end ;
+ ignore (from_region map reg) ;
+ end
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Froms Analysis --- *)
+(* -------------------------------------------------------------------------- *)
+
+let get_froms map reg =
+ try Rmap.find reg.id map.froms
+ with Not_found -> []
+
+let add_from map ~from ~target =
+ let rs = get_froms map target in
+ map.froms <- Rmap.add target.id (from :: rs) map.froms
+
+module Froms =
+struct
+ open Layout
+
+ let rec forward map marks ~source ~from ~target =
+ map.domain <- Rset.add source.id map.domain ;
+ add_from map ~from ~target ;
+ if once marks target then add_region map marks target
+
+ and add_region map marks reg =
+ begin
+ add_points_to map marks ~source:reg reg.pointsTo ;
+ add_cluster map marks ~source:reg (cluster map reg) ;
+ end
+
+ and add_points_to map marks ~source = function
+ | None -> ()
+ | Some p -> add_deref map marks ~source ~target:(region map p)
+
+ and add_deref map marks ~source ~target =
+ let from = if is_shifted target then Farray source else Fderef source in
+ forward map marks ~source ~from ~target
+
+ and add_cluster map marks ~source = function
+ | Empty | Garbled | Chunk (Int _ | Float _) -> ()
+ | Chunk (Pointer target) -> add_deref map marks ~source ~target
+ | Layout { layout } -> List.iter (add_range map marks ~source) layout
+
+ and add_range map marks ~source = function
+ | { ofs ; reg = target ; dim = Dim(_,[]) } ->
+ forward map marks ~source ~from:(Ffield(source,ofs)) ~target
+ | { reg = target } ->
+ forward map marks ~source ~from:(Findex source) ~target
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Roots Analysis --- *)
+(* -------------------------------------------------------------------------- *)
+
+let get_roots map reg =
+ try Rmap.find reg.id map.roots
+ with Not_found -> Rnone
+
+let has_roots map reg = get_roots map reg <> Rnone
+
+module Roots =
+struct
+
+ let rec of_region map region =
+ try Rmap.find region.id map.roots
+ with Not_found ->
+ let froms = get_froms map region in
+ let roots =
+ List.fold_left
+ (fun roots from ->
+ Root.merge roots (Root.from ~root:(of_region map) from)
+ ) Rnone froms
+ in map.roots <- Rmap.add region.id roots map.roots ; roots
+
+ let compute map reg = ignore (of_region map reg)
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Forward & Backward Propagation --- *)
+(* -------------------------------------------------------------------------- *)
+
+let forward map =
+ begin
+ let marks = ref Rset.empty in
+ map.domain <- Rset.empty ;
+ Vmap.iter
+ (fun x r ->
+ let reg = region map r in
+ let open Cil_types in
+ if x.vglob || x.vformal then
+ add_from map ~from:(Fvar x) ~target:(region map r) ;
+ Froms.add_region map marks reg ;
+ ) map.vars ;
+ end
+
+let backward map =
+ begin
+ Rmap.iter (Roots.compute map) map.region ;
+ end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Chunk Analysis --- *)
+(* -------------------------------------------------------------------------- *)
+
+let rec chunk map region =
+ try Rmap.find region.id map.chunk
+ with Not_found ->
+ let roots = get_roots map region in
+ let chunk =
+ 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
+ | Layout { 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
+
+and chunks map region =
+ match chunk map region with
+ | Mcomp(rs,_) -> rs
+ | _ -> Chunk.singleton region.id
+
+(* -------------------------------------------------------------------------- *)
+(* --- Fixpoint --- *)
+(* -------------------------------------------------------------------------- *)
+
+let fixpoint map =
+ begin
+ let turn = ref 0 in
+ let loop = ref true in
+ while !loop do
+ incr turn ;
+ Wp.feedback ~ontty:`Transient "Region clustering (loop #%d)" !turn ;
+ fusion map ;
+ map.cluster <- Rmap.empty ;
+ iter map (Cluster.compute map) ;
+ loop := fusionned map ;
+ done ;
+ Wp.feedback ~ontty:`Transient "Region forward analysis" ;
+ forward map ;
+ Wp.feedback ~ontty:`Transient "Region backward analysis" ;
+ backward map ;
+ Wp.feedback ~ontty:`Transient "Region fixpoint reached" ;
+ end
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/Region.mli b/src/plugins/wp/Region.mli
index f7a5eba2289224f8072eb1b563eae5d56859b1c3..98c01f12825ac7bbf87f351dcbb17416877f7971 100644
--- a/src/plugins/wp/Region.mli
+++ b/src/plugins/wp/Region.mli
@@ -20,43 +20,86 @@
(* *)
(**************************************************************************)
-(* -------------------------------------------------------------------------- *)
-(* --- Logic Path and Regions --- *)
-(* -------------------------------------------------------------------------- *)
+open Cil_types
+open Layout
-open Lang
-open Lang.F
-open Vset
+type region
+type map
-(** {2 Paths} *)
+module R : Layout.Data with type t = region
+module Map : Qed.Idxmap.S with type key = region
+module Set : Qed.Idxset.S with type elt = region
-type path = offset list
-and offset =
- | Oindex of term
- | Ofield of field
+val create : unit -> map
+val is_empty : map -> bool
+val iter : map -> (region -> unit) -> unit
-val access : term -> path -> term
-val update : term -> path -> term -> term
+val id: region -> int
+val noid: int
-(** {2 Regions} *)
+val get_addrof : map -> region -> region
+val add_pointed : map -> region -> region
+val add_offset : map -> region -> offset -> region
+val field_offset : map -> fieldinfo -> int * int
-type rpath = roffset list
-and roffset =
- | Rindex of set
- | Rfield of field
+val get_froms : map -> region -> region from list
+val get_roots : map -> region -> root
+val has_roots : map -> region -> bool
-type region
+val is_garbled : region -> bool
+val has_pointed : region -> bool
+val has_layout : region -> bool
+val has_offset : region -> offset -> bool
+val has_copies : region -> bool
+val has_deref : region -> bool
+val has_names : region -> bool
+val has_return : map -> bool
+
+val get_pointed : map -> region -> region option
+val get_offset : map -> region -> offset -> region option
+val get_copies : map -> region -> region list
+val get_alias : map -> region -> region
+val get_merged : map -> region -> region option
+val eq_alias : map -> region -> region -> bool
+
+val acs_read : region -> lvalue -> unit
+val acs_write : region -> lvalue -> unit
+val acs_shift : region -> lvalue -> unit
+val acs_deref : region -> deref -> unit
+val acs_copy : src:region -> tgt:region -> unit
+
+val is_read : region -> bool
+val is_written : region -> bool
+val is_shifted : region -> bool
+val is_aliased : region -> bool
+
+val iter_read : (lvalue -> unit) -> region -> unit
+val iter_write : (lvalue -> unit) -> region -> unit
+val iter_shift : (lvalue -> unit) -> region -> unit
+val iter_deref : (deref -> unit) -> region -> unit
+val iter_offset : map -> (offset -> region -> unit) -> region -> unit
+val iter_copies : map -> (region -> unit) -> region -> unit
+val iter_vars : map -> (varinfo -> region -> unit) -> unit
+val iter_names : map -> (string -> region -> unit) -> unit
+val iter_strings : map -> (region -> string -> unit) -> unit
+
+val of_null : map -> region
+val of_return : map -> region
+val of_cvar : map -> varinfo -> region
+val of_cstring : map -> eid:int -> cst:string -> region
+val of_name : map -> string -> region
+val of_class : map -> string option -> region
-val empty : region
-val full : region
-val path : path -> region (** Empty, but Full for the path *)
-val rpath : rpath -> region (** Empty, but Full for the r-paths *)
-val merge : region -> region -> region
+val region : map -> int -> region
+val cluster : map -> region -> region cluster
+val chunk : map -> region -> region chunk
+val chunks : map -> region -> chunks
-val disjoint : region -> region -> pred
-val subset : region -> region -> pred
-val equal_but : tau -> region -> term -> term -> pred
+val alias : map -> region -> region -> region
+val do_alias : map -> region -> region -> unit
+val add_alias : map -> into:region -> region -> unit
-val vars : region -> Vars.t
-val occurs : var -> region -> bool
-val pretty : Format.formatter -> region -> unit
+val fusion : map -> unit
+val fusionned : map -> bool
+val iter_fusion : map -> (int -> region -> unit) -> unit
+val fixpoint : map -> unit
diff --git a/src/plugins/wp/RegionAccess.ml b/src/plugins/wp/RegionAccess.ml
new file mode 100644
index 0000000000000000000000000000000000000000..591b77b53d291436a440b5a85ba37fca895cad77
--- /dev/null
+++ b/src/plugins/wp/RegionAccess.ml
@@ -0,0 +1,455 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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 Cil_types
+open Layout
+open Region
+
+(* -------------------------------------------------------------------------- *)
+(* --- Location Compiler --- *)
+(* -------------------------------------------------------------------------- *)
+
+type addr = {
+ addrof : Region.region ;
+ typeOfPointed : typ ;
+ shift : bool ;
+}
+
+type value =
+ | Pure
+ | Read_at of typ * region
+ | Addr_of of addr
+
+[@@@ warning "-32"]
+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
+[@@@ warning "+32"]
+
+(* -------------------------------------------------------------------------- *)
+(* --- Strings --- *)
+(* -------------------------------------------------------------------------- *)
+
+let cc_string map exp =
+ let cst = Pretty_utils.to_string Cil_datatype.Exp.pretty exp in
+ let addrof = Region.of_cstring map ~eid:exp.eid ~cst in
+ { addrof ; typeOfPointed = Cil.charType ; shift=false }
+
+(* -------------------------------------------------------------------------- *)
+(* --- Reading Values --- *)
+(* -------------------------------------------------------------------------- *)
+
+let read acs = function
+ | Pure -> ()
+ | Addr_of _ -> ()
+ | Read_at(tr,r) ->
+ 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)
+
+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 ;
+ }
+ | 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 }
+ | Read_at (_,r) -> Read_at(ty,r)
+ | Pure -> Pure
+ else
+ value
+
+let is_pointer_value = function
+ | Pure -> false
+ | Addr_of _ -> true
+ | Read_at(tr,_) -> Cil.isPointerType tr
+
+let merge_type t t' =
+ if Cil.isVoidType t then t' else
+ if Cil.isVoidType t' then t else
+ if Cil_datatype.Typ.equal t t' then t
+ else failwith "Wp.Region: merge incompatible pointer types"
+
+let merge_addrof (map:map) v1 v2 =
+ if not (is_pointer_value v1) then v2 else
+ if not (is_pointer_value v2) then v1 else
+ let a1 = addrof map v1 in
+ let a2 = addrof map v2 in
+ let typeOfPointed = merge_type a1.typeOfPointed a2.typeOfPointed in
+ let addrof = Region.alias map a1.addrof a2.addrof in
+ let shift = a1.shift || a2.shift in
+ Addr_of { addrof ; typeOfPointed ; shift }
+
+(* -------------------------------------------------------------------------- *)
+(* --- Expressions & L-values --- *)
+(* -------------------------------------------------------------------------- *)
+
+let rec cc_exp (map:map) exp =
+ match exp.enode with
+ | BinOp( (PlusPI | IndexPI | 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 }
+ | AddrOf lv | StartOf lv ->
+ 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)
+ | Info(e,_) -> cc_exp map e
+ | Const (CStr _ | CWStr _) -> Addr_of (cc_string map exp)
+ | Const (CInt64 _ | CChr _ | CEnum _ | CReal _)
+ | SizeOf _ | SizeOfE _ | SizeOfStr _
+ | AlignOf _ | AlignOfE _ -> Pure
+ | UnOp(_,e,ty) ->
+ 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
+
+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
+
+and cc_lval map (host , offset) =
+ let r,ty = cc_host map host in cc_offset map r ty 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
+ | 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
+
+and cc_addr map a = addrof map (cc_exp map a)
+
+and cc_read map e = read (Eval e) (cc_exp map e)
+
+and cc_comp map e =
+ match cc_exp map e with
+ | Pure | Addr_of _ -> failwith "Wp.Region: comp expected"
+ | Read_at(_,r) -> r
+
+let cc_writes map stmt tgt typ e =
+ acs_deref tgt (Value,typ) ;
+ 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)
+ | TComp _ ->
+ let src = cc_comp map e in
+ acs_copy ~src ~tgt
+ | _ ->
+ cc_read map e
+
+let cc_assign map stmt lv e =
+ cc_writes map stmt (cc_lval map lv) (Cil.typeOfLval lv) e
+
+let cc_return map stmt e =
+ cc_writes map stmt (Region.of_return map) (Cil.typeOf e) e
+
+(* -------------------------------------------------------------------------- *)
+(* --- Stmt & Instructions --- *)
+(* -------------------------------------------------------------------------- *)
+
+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
+
+let cc_local_init map stmt x = function
+ | AssignInit vi -> cc_init map stmt (Var x,NoOffset) vi
+ | ConsInit _ -> failwith "Wp.Region: cons-init not implemented"
+
+let cc_instr map stmt = function
+ | Set(lv,e,_) -> cc_assign map stmt lv e
+ | Call _ -> failwith "Wp.Region: call not implemented"
+ | Local_init(x,vi,_) -> cc_local_init map stmt x vi
+ | Asm _ | Skip _ | Code_annot _ -> ()
+
+let cc_skind map stmt =
+ match stmt.skind with
+ | Instr instr -> cc_instr map stmt instr
+ | Return(Some ve,_) -> cc_return map stmt ve
+ | If(e,_,_,_) -> cc_read map e
+ | Switch(e,_,_,_) -> cc_read map e
+
+ | Return(None,_) | Goto _ | Break _ | Continue _ | Loop _
+ | Block _ | UnspecifiedSequence _
+ | Throw _ | TryCatch _ | TryFinally _ | TryExcept _ -> ()
+
+(* -------------------------------------------------------------------------- *)
+(* --- ACSL Terms --- *)
+(* -------------------------------------------------------------------------- *)
+
+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
+ | 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
+ | TBinOp( (PlusPI | IndexPI | 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
+
+ | Tnull ->
+ 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
+
+ | Tat(t,_) -> cc_term_value map t
+
+ | TCastE(ty,t) -> cast ty @@ cc_term_value map t
+ | TLogic_coerce (Ctype ty,t) -> cast ty @@ cc_term_value map t
+ | TLogic_coerce (_,t) -> cc_term_value map t
+
+ | TConst _
+ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _
+ | TAlignOf _ | TAlignOfE _ | Ttype _ | Ttypeof _
+ -> Pure
+
+ | 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
+
+ | 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)
+
+ | Tempty_set -> Pure
+ | Tunion ts | Tinter 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"
+
+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
+ | 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
+
+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
+ | 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
+ | TModel _ -> failwith "Wp.Region: model field"
+
+and cc_term_offset_read map = function
+ | TNoOffset -> ()
+ | TField(_,ofs) -> cc_term_offset_read map ofs
+ | TModel(_,ofs) -> cc_term_offset_read map ofs
+ | TIndex(t,ofs) -> cc_term map t ; cc_term_offset_read map ofs
+
+and cc_term_addr map t = addrof map @@ cc_term_value map t
+
+and cc_term_option map = function None -> () | Some t -> cc_term map t
+
+(* -------------------------------------------------------------------------- *)
+(* --- ACSL Predicates --- *)
+(* -------------------------------------------------------------------------- *)
+
+and cc_pred (map:map) (p:predicate) =
+ match p.pred_content with
+ | Pfalse | Ptrue -> ()
+
+ | Prel(_,a,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
+ | Pand(a,b) | Por(a,b) | Pxor(a,b) | Pimplies(a,b) | Piff(a,b) ->
+ cc_pred map a ; cc_pred map b
+
+ | Pforall(_,p) | Pexists(_,p) -> cc_pred map p
+
+ | Pseparated ts -> List.iter (cc_term map) ts
+ | Pvalid(_,t) | Pvalid_read(_,t) | Pvalid_function t
+ | Pinitialized(_,t) | Pdangling(_,t) | Pallocable(_,t)
+ | Pfreeable(_,t) -> cc_term map t
+ | Pfresh(_,_,ptr,n) -> cc_term map ptr ; cc_term map n
+
+ | Pat(p,_at) -> cc_pred map p
+
+ | Plet _ | Papp _ ->
+ failwith "Wp.Region: unsupported logic predicates and bindings"
+
+(* -------------------------------------------------------------------------- *)
+(* --- ACSL Spec & Defs --- *)
+(* -------------------------------------------------------------------------- *)
+
+class visitor map =
+ object
+ inherit Visitor.frama_c_inplace as super
+
+ method! vpredicate p = cc_pred map p ; Cil.SkipChildren
+ method! vterm t = cc_term map t ; Cil.SkipChildren
+ method! vstmt s = cc_skind map s ; super#vstmt s
+ (* vpredicate and vterm are called from vcode_annot *)
+
+ (* speed up: skip non interesting subtrees *)
+ method! vloop_pragma _ = Cil.SkipChildren (* no need *)
+ method! vvdec _ = Cil.SkipChildren (* done via stmt *)
+ method! vexpr _ = Cil.SkipChildren (* done via stmt *)
+ method! vlval _ = Cil.SkipChildren (* done via stmt *)
+ method! vattr _ = Cil.SkipChildren (* done via stmt *)
+ method! vinst _ = Cil.SkipChildren (* done via stmt *)
+ end
+
+let cc_fundec map def =
+ let visitor = new visitor map in
+ ignore (Cil.visitCilFunction (visitor:>Cil.cilVisitor) def)
+
+let cc_spec map spec =
+ let visitor = new visitor map in
+ ignore (Cil.visitCilFunspec (visitor:>Cil.cilVisitor) spec)
+
+(* -------------------------------------------------------------------------- *)
+(* --- L-path Iterator --- *)
+(* -------------------------------------------------------------------------- *)
+
+open RegionAnnot
+
+let iter_star map f t r =
+ let pointed = add_pointed map r in
+ acs_deref pointed (Deref,t) ; f pointed
+
+let iter_shift map f t r =
+ let pointed = add_pointed map r in
+ acs_deref pointed (Array,t) ; f r
+
+let iter_index map f tarr r =
+ f (add_offset map r (Offset.index tarr))
+
+let iter_fields map f fds r =
+ List.iter (fun fd -> f (add_offset map r (Offset.field fd))) fds
+
+let rec iter_lpath map f lv =
+ match lv.lnode with
+ | L_var x -> f (of_cvar map x)
+ | L_region a -> f (of_name map a)
+ | L_cast(_,a) -> iter_lpath map f a
+ | L_addr a -> iter_lpath map (fun r -> f (get_addrof map r)) a
+ | L_star(te,a) -> iter_lpath map (iter_star map f te) a
+ | L_shift(a,te,_) -> iter_lpath map (iter_shift map f te) a
+ | L_index(a,_,_) -> iter_lpath map (iter_index map f lv.ltype) a
+ | L_field(a,fs) -> iter_lpath map (iter_fields map f fs) a
+
+(* -------------------------------------------------------------------------- *)
+(* --- Region Specs --- *)
+(* -------------------------------------------------------------------------- *)
+
+let cc_lpath map rclass _rpattern lv =
+ iter_lpath map (Region.add_alias map ~into:rclass) lv
+
+let cc_region map spec =
+ let rclass = Region.of_class map spec.region_name in
+ let rpattern = spec.region_pattern in
+ List.iter (cc_lpath map rclass rpattern) spec.region_lpath
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/value/domains/apron/apron_domain.ko.ml b/src/plugins/wp/RegionAccess.mli
similarity index 66%
rename from src/plugins/value/domains/apron/apron_domain.ko.ml
rename to src/plugins/wp/RegionAccess.mli
index 9ccb3680e2919874b7ad15a85c8b3c597e39083d..58f219332a3c52c4e9ea927c5d00c8b27a21963d 100644
--- a/src/plugins/value/domains/apron/apron_domain.ko.ml
+++ b/src/plugins/wp/RegionAccess.mli
@@ -1,9 +1,9 @@
(**************************************************************************)
(* *)
-(* This file is part of Frama-C. *)
+(* This file is part of WP plug-in of Frama-C. *)
(* *)
(* Copyright (C) 2007-2019 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
(* alternatives) *)
(* *)
(* you can redistribute it and/or modify it under the terms of the GNU *)
@@ -20,30 +20,23 @@
(* *)
(**************************************************************************)
-let ok = false
+open Cil_types
+open Region
-module type S = Abstract_domain.Internal
- with type value = Main_values.Interval.t
- and type location = Precise_locs.precise_location
+(* -------------------------------------------------------------------------- *)
-module U = Unit_domain.Make (Main_values.Interval) (Main_locations.PLoc)
+val cc_lval : map -> lval -> region
+val cc_read : map -> exp -> unit
+val cc_assign : map -> stmt -> lval -> exp -> unit
+val cc_init : map -> stmt -> lval -> init -> unit
+val cc_instr : map -> stmt -> instr -> unit
+val cc_fundec : map -> fundec -> unit
-module Octagon = U
-module Box = U
-module Polka_Loose = U
-module Polka_Strict = U
-module Polka_Equalities = U
+val cc_pred : map -> predicate -> unit
+val cc_term : map -> term -> unit
+val cc_spec : map -> spec -> unit
-let dummy_key = Structure.Key_Domain.create_key "dummy_apron"
-let octagon_key = dummy_key
-let box_key = dummy_key
-let polka_loose_key = dummy_key
-let polka_strict_key = dummy_key
-let polka_equalities_key = dummy_key
+open RegionAnnot
+val cc_region : map -> region_spec -> unit
-
-(*
-Local Variables:
-compile-command: "make -C ../../../.."
-End:
-*)
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/RegionAnalysis.ml b/src/plugins/wp/RegionAnalysis.ml
new file mode 100644
index 0000000000000000000000000000000000000000..a0679ed23c6e1ca88da3a29849da8c3ba782ffcd
--- /dev/null
+++ b/src/plugins/wp/RegionAnalysis.ml
@@ -0,0 +1,110 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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 Cil_types
+module Wp = Wp_parameters
+module Kf = Kernel_function
+
+(* ---------------------------------------------------------------------- *)
+(* --- Compute Analysis --- *)
+(* ---------------------------------------------------------------------- *)
+
+let compute kf =
+ let map = Region.create () in
+ if Kf.is_definition kf then
+ begin
+ Wp.feedback ~ontty:`Transient "[region] Analyzing %a" Kf.pretty kf ;
+ let def = Kf.get_definition kf in
+ RegionAccess.cc_fundec map def ;
+ let spec = Annotations.funspec kf in
+ RegionAccess.cc_spec map spec ;
+ List.iter
+ (fun bhv ->
+ let region_specs = RegionAnnot.of_behavior bhv in
+ if region_specs <> [] then
+ if Cil.is_default_behavior bhv then
+ List.iter (RegionAccess.cc_region map) region_specs
+ else
+ Wp.warning ~once:true
+ "Region specifications in non-default behaviours are skipped."
+ ) spec.spec_behavior ;
+ if Wp.Region_fixpoint.get () then Region.fixpoint map ;
+ end ;
+ map
+
+(* ---------------------------------------------------------------------- *)
+(* --- Projectified Analysis Result --- *)
+(* ---------------------------------------------------------------------- *)
+
+module REGION = Datatype.Make
+ (struct
+ type t = Region.map
+ include Datatype.Undefined
+ let reprs = [Region.create ()]
+ let name = "Wp.RegionAnalysis.region"
+ let mem_project = Datatype.never_any_project
+ end)
+
+module GLOBAL = State_builder.Ref
+ (REGION)
+ (struct
+ let name = "Wp.RegionAnalysis.ref"
+ let dependencies = [Ast.self]
+ let default = Region.create
+ end)
+
+module REGISTRY = State_builder.Hashtbl
+ (Kernel_function.Hashtbl)
+ (REGION)
+ (struct
+ let name = "Wp.RegionAnalysis.registry"
+ let dependencies = [Ast.self]
+ let size = 32
+ end)
+
+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
+
+(* ---------------------------------------------------------------------- *)
+(* --- Command Line Registry --- *)
+(* ---------------------------------------------------------------------- *)
+
+let main () =
+ if Wp.Region.get () then
+ begin
+ Ast.compute () ;
+ let dir = Wp.get_output_dir "region" in
+ Wp.iter_kf (fun kf ->
+ let map = get (Some kf) in
+ if not (Region.is_empty map) then
+ RegionDump.dump ~dir kf map
+ ) ;
+ end
+
+let () = Db.Main.extend main
+
+(* ---------------------------------------------------------------------- *)
diff --git a/src/plugins/value/domains/numerors/numerors_domain.ko.ml b/src/plugins/wp/RegionAnalysis.mli
similarity index 70%
rename from src/plugins/value/domains/numerors/numerors_domain.ko.ml
rename to src/plugins/wp/RegionAnalysis.mli
index eb6bc8b9a4fd68b544826004a66bc62dc4b3f43d..396190e6283ef2974b4094483b890b3d455f19a8 100644
--- a/src/plugins/value/domains/numerors/numerors_domain.ko.ml
+++ b/src/plugins/wp/RegionAnalysis.mli
@@ -1,9 +1,9 @@
(**************************************************************************)
(* *)
-(* This file is part of Frama-C. *)
+(* This file is part of WP plug-in of Frama-C. *)
(* *)
(* Copyright (C) 2007-2019 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
(* alternatives) *)
(* *)
(* you can redistribute it and/or modify it under the terms of the GNU *)
@@ -20,20 +20,10 @@
(* *)
(**************************************************************************)
-#24 "src/plugins/value/domains/numerors/numerors_domain.ko.ml"
-type value
-type location = Precise_locs.precise_location
-let value_key = Structure.Key_Value.create_key "dummy_numerors_values"
+(* -------------------------------------------------------------------------- *)
-let ok = false
+(** Memoized and Projectified Region Analyzis for the given Function. *)
+val get : Kernel_function.t option -> Region.map
-let abort () =
- Value_parameters.abort
- "The numerors domain has been requested but is not available, as Frama-C \
- did not found the MPFR library. The analysis is aborted."
-
-let add_numerors_value _ = abort ()
-let numerors_domain = abort
-
-let reduce_error _ = fun v -> v
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/RegionAnnot.ml b/src/plugins/wp/RegionAnnot.ml
new file mode 100644
index 0000000000000000000000000000000000000000..5ada4f4dc9434380e19dfa9d69147f562c6ecb12
--- /dev/null
+++ b/src/plugins/wp/RegionAnnot.ml
@@ -0,0 +1,494 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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 Cil_types
+open Cil_datatype
+open Logic_ptree
+
+module Wp = Wp_parameters
+
+(* -------------------------------------------------------------------------- *)
+(* --- L-Path --- *)
+(* -------------------------------------------------------------------------- *)
+
+type region_pattern =
+ | FREE
+ | PVAR
+ | PREF
+ | PMEM
+ | PVECTOR
+ | PMATRIX
+
+type lrange =
+ | R_index of term
+ | R_range of term option * term option
+
+type lpath = {
+ loc : location ;
+ lnode : lnode ;
+ ltype : typ ;
+}
+and lnode =
+ | L_var of varinfo
+ | L_region of string
+ | L_addr of lpath
+ | L_star of typ * lpath
+ | L_shift of lpath * typ * lrange
+ | L_index of lpath * typ * lrange
+ | L_field of lpath * fieldinfo list
+ | L_cast of typ * lpath
+
+type region_spec = {
+ region_name: string option ;
+ region_pattern: region_pattern ;
+ region_lpath: lpath list ;
+}
+
+(*
+let get_int e =
+ match Logic_utils.constFoldTermToInt e with
+ | None -> None
+ | Some a -> Some (Integer.to_int a)
+
+let get_int_option = function
+ | None -> None
+ | Some e -> get_int e
+*)
+
+module Lpath =
+struct
+
+ type t = lpath
+
+ let compare_bound a b =
+ match a,b with
+ | None , None -> 0
+ | Some a , Some b -> Term.compare a b
+ | None , Some _ -> (-1)
+ | Some _ , None -> 1
+
+ let compare_range a b =
+ match a,b with
+ | R_index a , R_index b -> Term.compare a b
+ | 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 rec compare a b =
+ match a.lnode , b.lnode with
+ | L_var x , L_var y -> Varinfo.compare x y
+ | L_var _ , _ -> (-1)
+ | _ , L_var _ -> 1
+ | L_region a , L_region b -> String.compare a b
+ | 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
+ | L_star _ , _ -> (-1)
+ | _ , L_star _ -> 1
+ | L_addr a , L_addr b -> compare a b
+ | L_addr _ , _ -> (-1)
+ | _ , L_addr _ -> 1
+ | L_shift(a,ta,i) , L_shift(b,tb,j) -> compare_index a ta i b tb j
+ | L_shift _ , _ -> (-1)
+ | _ , L_shift _ -> 1
+ | L_index(a,ta,i) , L_index(b,tb,j) -> compare_index a ta i b tb j
+ | 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
+ | 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
+
+ and compare_index a ta i b tb j =
+ let cmp = compare a b in
+ if cmp <> 0 then cmp else
+ let cmp = Typ.compare ta tb in
+ if cmp <> 0 then cmp else
+ compare_range i j
+
+ let equal a b = (compare a b = 0)
+
+ let pp_bound pp fmt = function None -> () | Some a -> pp fmt a
+ 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
+
+ let first = function [] -> assert false | f::_ -> f
+ let rec last = function [] -> assert false | [f] -> f | _::fs -> last fs
+
+ let is_lval = function
+ | L_var _ | L_region _ | L_index _ | L_field _ -> true
+ | _ -> false
+
+ let rec pp_lpath pp fmt a = match a.lnode with
+ | L_var x -> Varinfo.pretty fmt x
+ | 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))
+ | L_index(a,_,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
+ | 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
+
+ and pfield pp a f fmt =
+ Format.fprintf fmt "@[<hov 2>%a%a@]" (panchor pp) a Fieldinfo.pretty f
+
+ and panchor pp fmt a =
+ match a.lnode with
+ | L_star(_,p) -> Format.fprintf fmt "%a@,->" (pp_lval pp) p
+ | _ -> Format.fprintf fmt "%a@,." (pp_lval pp) a
+
+ and pp_lval pp fmt a =
+ if is_lval a.lnode then pp_lpath pp fmt a
+ else Format.fprintf fmt "(%a)" (pp_lpath pp) a
+
+ let pretty = pp_lpath Term.pretty
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Region Spec Printer --- *)
+(* -------------------------------------------------------------------------- *)
+
+let patterns = [
+ "PVAR" , PVAR ;
+ "PREF" , PREF ;
+ "PMEM" , PMEM ;
+ "PVECTOR" , PVECTOR ;
+ "PMATRIX" , PMATRIX ;
+]
+
+let p_name p = fst (List.find (fun (_,q) -> q = p) patterns)
+
+let pp_pattern_spec fmt p =
+ try Format.fprintf fmt "\\pattern{%s}" (p_name p) ; true
+ with Not_found -> false
+
+let pp_path_spec pp fmt coma lv =
+ if coma then Format.fprintf fmt ",@ " ;
+ Lpath.pp_lpath pp fmt lv ; true
+
+let pp_region_spec pp fmt coma spec =
+ begin
+ if coma then Format.fprintf fmt ",@ " ;
+ Format.fprintf fmt "@[<hv 2>" ;
+ Extlib.may (Format.fprintf fmt "%s:@ ") spec.region_name ;
+ let coma = pp_pattern_spec fmt spec.region_pattern in
+ let coma = List.fold_left (pp_path_spec pp fmt) coma spec.region_lpath in
+ Format.fprintf fmt "@]" ;
+ coma
+ end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Typing Env --- *)
+(* -------------------------------------------------------------------------- *)
+
+type env = {
+ context : Logic_typing.typing_context ;
+ mutable declared : string list ;
+ mutable name : string option ;
+ mutable pattern : region_pattern ;
+ mutable paths : lpath list ;
+ mutable specs : region_spec list ;
+}
+
+let error env ~loc msg = env.context.Logic_typing.error loc msg
+
+let flush env =
+ let region_name = env.name in env.name <- None ;
+ let region_pattern = env.pattern in env.pattern <- FREE ;
+ let region_lpath = List.rev env.paths in env.paths <- [] ;
+ Extlib.may (fun a -> env.declared <- a::env.declared) region_name ;
+ if not (region_name = None && region_lpath = []) then
+ let region = { region_name ; region_pattern ; region_lpath } in
+ env.specs <- region :: env.specs
+
+(* -------------------------------------------------------------------------- *)
+(* --- Type Utils --- *)
+(* -------------------------------------------------------------------------- *)
+
+let isIndexType t =
+ match Logic_utils.unroll_type t with
+ | Ctype (TInt _) | Linteger -> true
+ | _ -> false
+
+let getCompoundType env ~loc typ =
+ match Cil.unrollType typ with
+ | TComp(comp,_,_) -> comp
+ | _ -> error env ~loc "Expected compound type for term"
+
+(* -------------------------------------------------------------------------- *)
+(* --- Path Typechecking --- *)
+(* -------------------------------------------------------------------------- *)
+
+let parse_varinfo env ~loc x =
+ try
+ match env.context.Logic_typing.find_var x with
+ | { lv_origin = Some v } -> v
+ | _ -> error env ~loc "Variable '%s' is not a C-variable" x
+ with Not_found ->
+ error env ~loc "Unknown variable (or region) '%s'" x
+
+let parse_fieldinfo env ~loc comp f =
+ try List.find (fun fd -> fd.fname = f) comp.cfields
+ with Not_found ->
+ error env ~loc "No field '%s' in compound type '%s'" f comp.cname
+
+let parse_lindex env e =
+ let open Logic_typing in
+ let g = env.context in
+ let t = g.type_term g g.pre_state e in
+ if isIndexType t.term_type then t
+ else error env ~loc:t.term_loc "Index term shall have a integer type"
+
+let parse_ltype env ~loc t =
+ let open Logic_typing in
+ let g = env.context in
+ let t = g.logic_type g loc g.pre_state t in
+ match Logic_utils.unroll_type t with
+ | Ctype typ -> typ
+ | _ -> error env ~loc "C-type expected for casting l-values"
+
+let parse_lbound env = function
+ | None -> None
+ | Some e -> Some (parse_lindex env e)
+
+let parse_lrange env e =
+ match e.lexpr_node with
+ | PLrange(a,b) -> R_range( parse_lbound env a , parse_lbound env b )
+ | _ -> R_index( parse_lindex env e )
+
+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 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 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 }
+ | 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 '&'"
+ | PLunop( Uamp , p ) ->
+ 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 '+'"
+ | 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 }
+ | PLarrow( p , f ) ->
+ 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"
+ | 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 }
+ | 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 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 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 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"
+
+and parse_fpath env p =
+ let lv = parse_lpath env p in
+ match lv.lnode with
+ | L_field( a , [f] ) -> a , f
+ | _ -> error env ~loc:lv.loc "Missing field access in range"
+
+(* -------------------------------------------------------------------------- *)
+(* --- Spec Typechecking --- *)
+(* -------------------------------------------------------------------------- *)
+
+let kspec = ref 0
+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
+ | [] -> error env ~loc "Missing pattern name"
+ | _ -> error env ~loc "Duplicate pattern names"
+
+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
+ | 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 path = parse_lpath env p in
+ env.paths <- path :: env.paths
+
+let typecheck ~typing_context ~loc:_loc ps =
+ let env = {
+ name = None ;
+ declared = [] ;
+ context = typing_context ;
+ pattern = FREE ;
+ paths = [] ; specs = [] ;
+ } in
+ List.iter (parse_region env) ps ;
+ let id = !kspec in incr kspec ;
+ let specs = flush env ; env.specs in
+ Hashtbl.add registry id specs ; Ext_id id
+
+(* -------------------------------------------------------------------------- *)
+(* --- Registry --- *)
+(* -------------------------------------------------------------------------- *)
+
+let of_extid = Hashtbl.find registry
+let of_extrev = function
+ | { ext_name="region" ; ext_kind = Ext_id k } -> of_extid k
+ | _ -> raise Not_found
+let of_extension e = List.rev (of_extrev e)
+let of_behavior bhv =
+ List.fold_left
+ (fun acc e -> List.rev_append (try of_extrev e with Not_found -> []) acc)
+ [] bhv.Cil_types.b_extended
+
+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 specified =
+ let re = Str.regexp_case_fold "region" in
+ fun model ->
+ try
+ ignore (Str.search_forward re model 0) ; true
+ with Not_found -> false
+
+let register () =
+ if Wp.Region.get () || Wp.Region_annot.get () ||
+ List.exists specified (Wp.Model.get ())
+ then
+ begin
+ Logic_typing.register_behavior_extension "region" true typecheck ;
+ Cil_printer.register_behavior_extension "region" pp_extension ;
+ end
+
+let () = Cmdline.run_after_configuring_stage register
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/RegionAnnot.mli b/src/plugins/wp/RegionAnnot.mli
new file mode 100644
index 0000000000000000000000000000000000000000..c48c63f3e2f1aab417b5dc36b2d1a365b8bc9d74
--- /dev/null
+++ b/src/plugins/wp/RegionAnnot.mli
@@ -0,0 +1,70 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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 Cil_types
+
+type lrange =
+ | R_index of term
+ | R_range of term option * term option
+
+type lpath = {
+ loc : location ;
+ lnode : lnode ;
+ ltype : typ ;
+}
+and lnode =
+ | L_var of varinfo
+ | L_region of string
+ | L_addr of lpath
+ | L_star of typ * lpath
+ | L_shift of lpath * typ * lrange
+ | L_index of lpath * typ * lrange
+ | L_field of lpath * fieldinfo list
+ | L_cast of typ * lpath
+
+module Lpath :
+sig
+ type t = lpath
+ val equal : t -> t -> bool
+ val compare : t -> t -> int
+ val pretty : Format.formatter -> t -> unit
+end
+
+type region_pattern =
+ | FREE
+ | PVAR
+ | PREF
+ | PMEM
+ | PVECTOR
+ | PMATRIX
+
+type region_spec = {
+ region_name: string option ;
+ region_pattern: region_pattern ;
+ region_lpath: lpath list ;
+}
+
+val p_name : region_pattern -> string
+val of_extension : acsl_extension -> region_spec list
+val of_behavior : behavior -> region_spec list
+
+val register : unit -> unit (** Auto when `-wp-region` *)
diff --git a/src/plugins/wp/RegionDump.ml b/src/plugins/wp/RegionDump.ml
new file mode 100644
index 0000000000000000000000000000000000000000..cd4d31c78b4b93c0b790124aee648d1ce95dfcdc
--- /dev/null
+++ b/src/plugins/wp/RegionDump.ml
@@ -0,0 +1,295 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+module Wp = Wp_parameters
+module Kf = Kernel_function
+module G = Dotgraph
+module R = G.Node(Region.Map)
+
+let node_default = [`Attr("fontname","monospace")]
+let edge_default = [`Attr("fontname","monospace")]
+
+let attr_offset = [ `Filled ; `Color "grey" ; `Box ]
+let attr_write = [ `Label "W" ; `Fillcolor "green" ; `Filled ]
+let attr_read = [ `Label "R" ; `Fillcolor "green" ; `Filled ]
+let attr_alias = [ `Label "&" ; `Fillcolor "orange" ; `Filled ]
+let attr_merge = [ `Color "red" ; `Fillcolor "red" ; `Filled ]
+let attr_shift = [ `Label "[]" ]
+let attr_delta = [ `Filled ; `Color "lightblue" ; `Box ]
+let attr_deref = [ `ArrowHead "tee" ]
+let attr_cil = [ `Filled ; `Fillcolor "yellow" ]
+let attr_region = `Shape "tab" :: attr_cil
+let attr_var = `Shape "cds" :: attr_cil
+let attr_garbled = [`Fillcolor "red";`Filled]
+let attr_froms = [ `Color "blue" ; `Attr("dir","back") ]
+
+let attr_pointed = [
+ `Color "red"
+]
+
+let attr_pointed_deref = [
+ `Attr("taillabel","*");
+ `Attr("labelangle","+30");
+ `Color "red";
+]
+
+let attr_pointed_shift = [
+ `Attr("taillabel","[..]");
+ `Attr("labeldistance","1.7");
+ `Attr("labelangle","+40");
+ `Color "red";
+]
+
+let rid_key = Wp.register_category "rid"
+let dot_key = Wp.register_category "dot"
+let pdf_key = Wp.register_category "pdf"
+let deref_key = Wp.register_category "deref"
+let roots_key = Wp.register_category "roots"
+let froms_key = Wp.register_category "froms"
+let cluster_key = Wp.register_category "cluster"
+let chunk_key = Wp.register_category "chunk"
+let offset_key = Wp.register_category "offset"
+
+let sfprintf = Pretty_utils.sfprintf
+
+let dotpointed ~label r =
+ let attr =
+ if Region.is_shifted r
+ then attr_pointed_shift else attr_pointed_deref in
+ let target = G.port (R.get r) "w" in
+ `Port ("",["",attr,target],label)
+
+let dotvalue ?(prefix="") value : Dotgraph.record =
+ let open Layout in
+ match value with
+ | Int i -> `Label (sfprintf "%s%a" prefix Ctypes.pp_int i)
+ | Float f -> `Label (sfprintf "%s%a" prefix Ctypes.pp_float f)
+ | Pointer r -> dotpointed ~label:(prefix ^ "ptr") r
+
+let dotrange ?(prefix="") rg : Dotgraph.record =
+ let open Layout in
+ let pp_dim fmt = function
+ | Raw _ -> Format.pp_print_string fmt "raw"
+ | Dim(s,ds) -> Format.fprintf fmt "%d%a" s Matrix.pretty ds
+ in
+ let label = sfprintf "%d..%d: %s%a"
+ rg.ofs (rg.ofs + rg.len - 1)
+ prefix pp_dim rg.dim in
+ `Port("",["",[`Dotted],R.get rg.reg],label)
+
+let dotcluster cluster : Dotgraph.record =
+ let open Layout in
+ match cluster with
+ | Empty -> `Label "-"
+ | 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 dotchunk mem : Dotgraph.record =
+ let open Layout in
+ match mem with
+ | Mraw(_,None) -> `Label "Raw"
+ | 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
+ | 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 dotregion dot map region node =
+ begin
+ let is_read = Region.is_read region in
+ let is_written = Region.is_written region in
+ let is_aliased = Region.is_aliased region in
+ let is_accessed = is_read || is_written || is_aliased in
+ let has_deref = Wp.has_dkey deref_key && Region.has_deref region in
+ let has_roots = Wp.has_dkey roots_key && Region.has_roots map region in
+ let has_index_infos = has_deref || has_roots in
+ let has_side_cluster =
+ is_accessed ||
+ has_index_infos ||
+ Region.has_names region ||
+ Wp.has_dkey offset_key ||
+ Wp.has_dkey rid_key ||
+ not (Wp.has_dkey cluster_key || Wp.has_dkey chunk_key) ||
+ not (Wp.Region_fixpoint.get ())
+ in
+ if has_side_cluster then
+ begin
+ let attr = G.decorate [ `Oval ] [
+ is_read , attr_read ;
+ Region.has_pointed region , [ `Label "D" ] ;
+ is_written , attr_write ;
+ Region.is_shifted region , attr_shift ;
+ is_aliased , attr_alias ;
+ Region.get_alias map region != region , attr_merge ;
+ Region.is_garbled region , attr_merge ;
+ ] in
+ G.node dot node attr ;
+ end ;
+ if Wp.has_dkey offset_key then
+ Region.iter_offset map
+ (fun offset target ->
+ let label = Pretty_utils.to_string Layout.Offset.pretty offset in
+ let delta = G.inode dot (`Label label :: attr_offset) in
+ G.link dot [node;delta;R.get target] [`Dotted]
+ ) region ;
+ if Wp.has_dkey offset_key then
+ Extlib.may
+ (fun target ->
+ let label = if Region.is_shifted target then "[..]" else "*" in
+ let deref = G.inode dot (`Label label :: attr_offset) in
+ G.link dot [node;deref;R.get target] attr_pointed
+ ) (Region.get_pointed map region) ;
+ if has_index_infos then
+ begin
+ let derefs = ref [] in
+ let label s = derefs := s :: !derefs in
+ if has_roots then
+ label @@ sfprintf "roots:%a"
+ Layout.Root.pretty (Region.get_roots map region) ;
+ if has_deref then
+ Region.iter_deref
+ (fun deref ->
+ label @@ Pretty_utils.to_string Layout.Deref.pretty deref
+ ) region ;
+ if !derefs <> [] then
+ begin
+ let label = String.concat "\n" (List.rev !derefs) in
+ let delta = G.inode dot (`Label label :: attr_delta) in
+ G.rank dot [node;delta] ;
+ G.edge dot delta node attr_deref
+ end
+ end ;
+ if Wp.has_dkey cluster_key then
+ begin
+ let cluster = Region.cluster map region in
+ if not (has_side_cluster && Layout.Cluster.is_empty cluster) then
+ let record = dotcluster cluster in
+ let attr = if Region.is_garbled region then attr_garbled else [] in
+ if has_side_cluster then
+ let delta = G.irecord dot ~attr record in
+ G.edge dot node (G.port delta "w") attr_deref
+ else
+ G.record dot node ~attr record
+ end ;
+ if Wp.has_dkey chunk_key then
+ begin
+ let chunk = Region.chunk map region in
+ let record = dotchunk chunk in
+ let attr = if Region.is_garbled region then attr_garbled else [] in
+ if has_side_cluster then
+ let delta = G.irecord dot ~attr record in
+ G.edge dot node (G.port delta "w") attr_deref
+ else
+ G.record dot node ~attr record
+ end ;
+ if Wp.has_dkey froms_key then
+ begin
+ let open Layout in
+ List.iter
+ (function
+ | Fvar _ -> ()
+ | Farray r ->
+ G.edge dot (R.get r) node (`Label "[]"::attr_froms)
+ | Fderef r ->
+ G.edge dot (R.get r) node (`Label "*"::attr_froms)
+ | Findex r ->
+ 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)
+ ) (Region.get_froms map region)
+ end ;
+ Region.iter_copies map
+ (fun target ->
+ G.edge dot node (R.get target) [`Color "green"]
+ ) region ;
+ Extlib.may
+ (fun target ->
+ G.edge dot node (R.get target) [`Color "red"]
+ ) (Region.get_merged map region) ;
+ end
+
+let dotvar dot x r =
+ begin
+ let open Cil_types in
+ let xnode = G.inode dot ~prefix:"V" (`Label x.vname :: attr_var) in
+ G.edge dot (G.port xnode "e") (R.get r) [] ;
+ end
+
+let dotlabel dot a r =
+ begin
+ let anode = G.inode dot ~prefix:"R" (`Label a :: attr_region) in
+ let rnode = R.get r in
+ G.rank dot [ anode ; rnode ] ;
+ G.edge dot anode rnode []
+ end
+
+let dotrid dot r =
+ dotlabel dot (Pretty_utils.to_string Region.R.pretty r) r
+
+let dotstr dot r cst =
+ dotlabel dot (String.escaped cst) r
+
+let dotgraph dot map =
+ begin
+ G.node_default dot node_default ;
+ G.edge_default dot edge_default ;
+ R.clear () ;
+ R.push dot (dotregion dot map) ;
+ Region.iter_vars map (dotvar dot) ;
+ Region.iter_strings map (dotstr dot) ;
+ G.pop_all dot ;
+ if Wp.has_dkey rid_key then Region.iter map (dotrid dot) ;
+ Region.iter_names map (dotlabel dot) ;
+ if Region.has_return map then
+ dotlabel dot "\\result" (Region.of_return map) ;
+ Region.iter_fusion map (fun i r ->
+ let rid = Region.id r in
+ if i <> rid then
+ dotlabel dot (Printf.sprintf "Fusion R%03d" i) r
+ else
+ dotlabel dot "Fusion (Self)" r
+ ) ;
+ G.pop_all dot ;
+ end
+
+let dump ~dir kf map =
+ if Wp.has_dkey dot_key || Wp.has_dkey pdf_key then
+ begin
+ let name = Kf.get_name kf in
+ let file = Printf.sprintf "%s/%s.dot" dir name in
+ let dot = Dotgraph.open_dot ~attr:[`LR] ~name ~file () in
+ dotgraph dot map ;
+ Dotgraph.close dot ;
+ let outcome =
+ if Wp.has_dkey pdf_key
+ then Dotgraph.layout dot
+ else file in
+ Wp.result "Region Graph: %s" outcome
+ end
diff --git a/src/plugins/wp/RegionDump.mli b/src/plugins/wp/RegionDump.mli
new file mode 100644
index 0000000000000000000000000000000000000000..362876448cd0c752ae7661005952d286ec9040ad
--- /dev/null
+++ b/src/plugins/wp/RegionDump.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(* *)
+(* This file is part of WP plug-in of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat a l'energie atomique et aux energies *)
+(* 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). *)
+(* *)
+(**************************************************************************)
+
+(* Dump region graphs to dir according to -wp options.
+ By default, does nothing. *)
+
+val dump : dir:string -> Kernel_function.t -> Region.map -> unit
diff --git a/src/plugins/wp/Sigs.ml b/src/plugins/wp/Sigs.ml
index 3c5e197bbe689567d2e3ce1bf8b7bc712f502ba8..43db54a110aea9a9706f602940bc2a49e035b56d 100644
--- a/src/plugins/wp/Sigs.ml
+++ b/src/plugins/wp/Sigs.ml
@@ -85,6 +85,16 @@ type 'a result =
(** Polarity of predicate compilation *)
type polarity = [ `Positive | `Negative | `NoPolarity ]
+(** Frame Conditions.
+ Consider a function [phi(m)] over memory [m],
+ we want memories [m1,m2] and condition [p] such that
+ [p(m1,m2) -> phi(m1) = phi(m2)].
+ - [name] used for generating lemma
+ - [triggers] for the lemma
+ - [conditions] for the frame lemma to hold
+ - [mem1,mem2] to two memories for which the lemma holds *)
+type frame = string * Definitions.trigger list * pred list * term * term
+
(* -------------------------------------------------------------------------- *)
(** {1 Reversing Models}
@@ -135,6 +145,7 @@ sig
type t
val self : string (** Chunk names, for pretty-printing. *)
val hash : t -> int
+ val equal : t -> t -> bool
val compare : t -> t -> int
val pretty : Format.formatter -> t -> unit
@@ -315,9 +326,9 @@ sig
shall be performed, otherwise return [Mvalue].
Recognized [Cil] patterns:
- - [Mvar x,[Mindex 0]] is rendered as [*x] when [x] has a pointer type
- - [Mmem p,[Mfield f;...]] is rendered as [p->f...] like in Cil
- - [Mmem p,[Mindex k;...]] is rendered as [p[k]...] to catch Cil [Mem(AddPI(p,k)),...] *)
+ - [Mvar x,[Mindex 0]] is rendered as [*x] when [x] has a pointer type
+ - [Mmem p,[Mfield f;...]] is rendered as [p->f...] like in Cil
+ - [Mmem p,[Mindex k;...]] is rendered as [p[k]...] to catch Cil [Mem(AddPI(p,k)),...] *)
val lookup : state -> term -> mval
(** Try to interpret a sequence of states into updates.
@@ -423,7 +434,7 @@ sig
location [loc] which is represented by [t] in [sigma.post].
*)
- val assigned : sigma sequence -> c_object -> loc sloc -> pred list
+ val assigned : sigma sequence -> c_object -> loc sloc -> equation list
(**
Return a set of formula that express that two memory state are the same
except at the given set of memory location.
@@ -601,12 +612,6 @@ sig
type nonrec result = M.loc result
type sigma = M.Sigma.t
- (** {2 Debug} *)
-
- val pp_logic : Format.formatter -> logic -> unit
- val pp_sloc : Format.formatter -> loc sloc -> unit
- val pp_region : Format.formatter -> region -> unit
-
(** {2 Frames}
Frames are compilation environment for ACSL. A frame typically
diff --git a/src/plugins/wp/TacBitwised.ml b/src/plugins/wp/TacBitwised.ml
index 4c9efb759af6245f97c86a542ab8f644806eb71e..31e47696959e28e323cd8236f4e2ca2160856d4d 100644
--- a/src/plugins/wp/TacBitwised.ml
+++ b/src/plugins/wp/TacBitwised.ml
@@ -117,7 +117,7 @@ let rec lookup push clause ~nbits ~priority p =
class autobitwise =
object(self)
- method private nbits = Ctypes.range (Ctypes.c_ptr ())
+ method private nbits = Ctypes.i_bits (Ctypes.c_ptr ())
method id = "wp:bitwised"
method title =
diff --git a/src/plugins/wp/TacHavoc.ml b/src/plugins/wp/TacHavoc.ml
index 9b7034cc30839c0ed07020faf82927db93ef5e96..9e68996a899b6602601fc6334b8daa46eaa4e600 100644
--- a/src/plugins/wp/TacHavoc.ml
+++ b/src/plugins/wp/TacHavoc.ml
@@ -35,7 +35,7 @@ let lookup_havoc e =
| L.Aget( m , p ) ->
begin
match F.repr m with
- | L.Fun( f , [mr;m0;a;n] ) when f == MemTyped.f_havoc ->
+ | L.Fun( f , [mr;m0;a;n] ) when f == MemMemory.f_havoc ->
Some( mr , m0 , a , n , p )
| _ -> None
end
@@ -55,7 +55,7 @@ class havoc =
| None -> Not_applicable
| Some(mr,m0,a,n,p) ->
let separated =
- F.p_call MemTyped.p_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 ;
@@ -70,11 +70,11 @@ class havoc =
let separated ?at property =
match F.e_expr property with
- | L.Fun( f , [p;n;q;m] ) when f == MemTyped.p_separated ->
- let base_p = MemTyped.a_base p in
- let ofs_p = MemTyped.a_offset p in
- let base_q = MemTyped.a_base q in
- let ofs_q = MemTyped.a_offset q in
+ | 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
@@ -110,8 +110,8 @@ class separated =
(* -------------------------------------------------------------------------- *)
let invalid m p n =
- let base = MemTyped.a_base p in
- let offset = MemTyped.a_offset p in
+ let base = MemMemory.a_base p in
+ let offset = MemMemory.a_offset p in
let malloc = F.e_get m base in
"Invalid",
F.p_imply
@@ -121,8 +121,8 @@ let invalid m p n =
(F.p_leq (F.e_add offset n) F.e_zero))
let valid_rd m p n =
- let base = MemTyped.a_base p in
- let offset = MemTyped.a_offset p in
+ let base = MemMemory.a_base p in
+ let offset = MemMemory.a_offset p in
let malloc = F.e_get m base in
"Valid (Read)",
F.p_imply
@@ -132,8 +132,8 @@ let valid_rd m p n =
(F.p_leq (F.e_add offset n) malloc))
let valid_rw m p n =
- let base = MemTyped.a_base p in
- let offset = MemTyped.a_offset p in
+ let base = MemMemory.a_base p in
+ let offset = MemMemory.a_offset p in
let malloc = F.e_get m base in
"Valid (Read & Write)",
F.p_imply
@@ -145,10 +145,10 @@ let valid_rw m p n =
])
let included p a q b =
- let p_base = MemTyped.a_base p in
- let q_base = MemTyped.a_base q in
- let p_offset = MemTyped.a_offset p in
- let q_offset = MemTyped.a_offset q in
+ let p_base = MemMemory.a_base p in
+ let q_base = MemMemory.a_base q in
+ let p_offset = MemMemory.a_offset p in
+ let q_offset = MemMemory.a_offset q in
"Included",
F.p_imply
(F.p_lt F.e_zero a)
@@ -161,10 +161,10 @@ let included p a q b =
]))
let lookup f = function
- | [p;a;q;b] when f == MemTyped.p_included -> included p a q b
- | [m;p;n] when f == MemTyped.p_invalid -> invalid m p n
- | [m;p;n] when f == MemTyped.p_valid_rd -> valid_rd m p n
- | [m;p;n] when f == MemTyped.p_valid_rw -> valid_rw m p n
+ | [p;a;q;b] when f == MemMemory.p_included -> included p a q b
+ | [m;p;n] when f == MemMemory.p_invalid -> invalid m p n
+ | [m;p;n] when f == MemMemory.p_valid_rd -> valid_rd m p n
+ | [m;p;n] when f == MemMemory.p_valid_rw -> valid_rw m p n
| _ -> raise Not_found
let unfold ?at e f es =
diff --git a/src/plugins/wp/Tactical.mli b/src/plugins/wp/Tactical.mli
index c135567fe9fe67191b949604a845248dc0b9f962..80ce4eb29c52fe910501e8f8a9cd871591e5ea09 100644
--- a/src/plugins/wp/Tactical.mli
+++ b/src/plugins/wp/Tactical.mli
@@ -133,9 +133,9 @@ val search :
find:(string -> 'a) ->
unit -> 'a named option field * parameter
(** Search field.
- - [browse s n] is the lookup function, used in the GUI only.
+ - [browse s n] is the lookup function, used in the GUI only.
Shall returns at most [n] results applying to selection [s].
- - [find n] is used at script replay, and shall retrieve the
+ - [find n] is used at script replay, and shall retrieve the
selected item's [id] later on. *)
type 'a formatter = ('a,Format.formatter,unit) format -> 'a
diff --git a/src/plugins/wp/Why3Provers.ml b/src/plugins/wp/Why3Provers.ml
index 7499579fe54f7bb617847a092818a80cf72cac7b..a7bb783256673119bd9d380d123424676444f0aa 100644
--- a/src/plugins/wp/Why3Provers.ml
+++ b/src/plugins/wp/Why3Provers.ml
@@ -42,7 +42,7 @@ let configure =
begin fun () ->
if !todo then
begin
- let args = Array.of_list ("why3"::Wp_parameters.WhyFlags.get ()) in
+ let args = Array.of_list ("why3"::Wp_parameters.Why3Flags.get ()) in
begin try
Arg.parse_argv ~current:(ref 0) args
(Why3.Debug.Args.[desc_debug;desc_debug_all;desc_debug_list])
diff --git a/src/plugins/wp/cfgWP.ml b/src/plugins/wp/cfgWP.ml
index ea3cd5016fe6236b9dc0d1679b10ebb05f45b238..5c9f650ca85e03c7b8c934b4b2c13b37a3255002 100644
--- a/src/plugins/wp/cfgWP.ml
+++ b/src/plugins/wp/cfgWP.ml
@@ -339,13 +339,13 @@ struct
let merge_all_vcs : vc Splitter.t Gmap.t list -> vc Splitter.t Gmap.t =
fun cases ->
- let targets = List.fold_left
- (fun goals vcs -> Gset.union goals (Gmap.domain vcs))
- Gset.empty cases in
- let goal g vcs = try Gmap.find g vcs with Not_found -> Splitter.empty in
- Gset.mapping
- (fun g -> Splitter.merge_all merge_vcs (List.map (goal g) cases))
- targets
+ let targets = List.fold_left
+ (fun goals vcs -> Gset.union goals (Gmap.domain vcs))
+ Gset.empty cases in
+ let goal g vcs = try Gmap.find g vcs with Not_found -> Splitter.empty in
+ Gset.mapping
+ (fun g -> Splitter.merge_all merge_vcs (List.map (goal g) cases))
+ targets
(* -------------------------------------------------------------------------- *)
(* --- Merge for Calculus --- *)
@@ -789,7 +789,7 @@ struct
let rec cc_case_values ks vs sigma = function
| [] -> ks , vs
| e::es ->
- match Ctypes.get_int e with
+ match Ctypes.get_int64 e with
| Some k ->
cc_case_values (k::ks) (F.e_int64 k::vs) sigma es
| None ->
diff --git a/src/plugins/wp/ctypes.ml b/src/plugins/wp/ctypes.ml
index f26b90250538d28231b9fbbee1bd422d4f3fe95d..d6ad36e4a1ff099a330ae22fbfcbf432199d583c 100644
--- a/src/plugins/wp/ctypes.ml
+++ b/src/plugins/wp/ctypes.ml
@@ -47,14 +47,14 @@ let signed = function
| UInt8 | UInt16 | UInt32 | UInt64 -> false
| SInt8 | SInt16 | SInt32 | SInt64 -> true
-let range = function
+let i_bits = function
| CBool -> 1
| UInt8 | SInt8 -> 8
| UInt16 | SInt16 -> 16
| UInt32 | SInt32 -> 32
| UInt64 | SInt64 -> 64
-let sizeof_i = function
+let i_bytes = function
| CBool -> 1
| UInt8 | SInt8 -> 1
| UInt16 | SInt16 -> 2
@@ -73,7 +73,8 @@ let is_char = function
| SInt8 -> not Cil.theMachine.Cil.theMachine.char_is_unsigned
| UInt16 | SInt16
| UInt32 | SInt32
- | UInt64 | SInt64 | CBool -> false
+ | UInt64 | SInt64
+ | CBool -> false
let c_int ikind =
let mach = Cil.theMachine.Cil.theMachine in
@@ -93,12 +94,15 @@ let c_int ikind =
let c_bool () = c_int IBool
let c_char () = c_int IChar
-let c_ptr () =
- make_c_int false Cil.theMachine.Cil.theMachine.sizeof_ptr
+
+let p_bytes () = Cil.theMachine.Cil.theMachine.sizeof_ptr
+let p_bits () = 8 * p_bytes ()
+
+let c_ptr () = make_c_int false (p_bytes ())
let sub_c_int t1 t2 =
- if (signed t1 = signed t2) then range t1 <= range t2
- else (not(signed t1) && (range t1 < range t2))
+ if (signed t1 = signed t2) then i_bits t1 <= i_bits t2
+ else (not(signed t1) && (i_bits t1 < i_bits t2))
type c_float =
| Float32
@@ -106,7 +110,7 @@ type c_float =
let compare_c_float : c_float -> c_float -> _ = Extlib.compare_basic
-let sizeof_f = function
+let f_bytes = function
| Float32 -> 4
| Float64 -> 8
@@ -126,7 +130,7 @@ let c_float fkind =
| FDouble -> make_c_float mach.sizeof_double
| FLongDouble -> make_c_float mach.sizeof_longdouble
-let equal_float f1 f2 = (f1 = f2)
+let equal_float f1 f2 = f_bits f1 = f_bits f2
(* Array objects, with both the head view and the flatten view. *)
@@ -195,15 +199,15 @@ let f_iter f =
(* --- Bounds --- *)
(* -------------------------------------------------------------------------- *)
-let bounds =
- let i_bounds i =
- if signed i then
- let m = Integer.two_power_of_int (range i - 1) in
- Integer.neg m , Integer.pred m
- else
- let m = Integer.two_power_of_int (range i) in
- Integer.zero , Integer.pred m
- in i_memo i_bounds
+let i_bounds i =
+ if signed i then
+ let m = Integer.two_power_of_int (i_bits i - 1) in
+ Integer.neg m , Integer.pred m
+ else
+ let m = Integer.two_power_of_int (i_bits i) in
+ Integer.zero , Integer.pred m
+
+let bounds i = i_memo i_bounds i
(* -------------------------------------------------------------------------- *)
(* --- Pretty Printers --- *)
@@ -211,7 +215,7 @@ let bounds =
let pp_int fmt i =
if i = CBool then Format.pp_print_string fmt "bool"
- else Format.fprintf fmt "%cint%d" (if signed i then 's' else 'u') (range i)
+ else Format.fprintf fmt "%cint%d" (if signed i then 's' else 'u') (i_bits i)
let pp_float fmt f = Format.fprintf fmt "float%d" (f_bits f)
@@ -234,6 +238,11 @@ let constant e =
| _ -> WpLog.fatal "Non-constant expression (%a)" Printer.pp_exp e
let get_int e =
+ match (Cil.constFold true e).enode with
+ | Const(CInt64(k,_,_)) -> Some (Integer.to_int k)
+ | _ -> None
+
+let get_int64 e =
match (Cil.constFold true e).enode with
| Const(CInt64(k,_,_)) -> Some (Integer.to_int64 k)
| _ -> None
@@ -254,14 +263,12 @@ let is_pointer = function
| C_pointer _ -> true
| C_int _ | C_float _ | C_array _ | C_comp _ -> false
-let is_void = Cil.isVoidType
-
let rec object_of typ =
match typ with
| TInt(i,_) -> C_int (c_int i)
| TFloat(f,_) -> C_float (c_float f)
- | TPtr(typ,_) -> C_pointer (if is_void typ then TInt (IChar,[]) else typ)
- | TFun _ -> C_pointer (TVoid [])
+ | TPtr(typ,_) -> C_pointer (if Cil.isVoidType typ then Cil.charType else typ)
+ | TFun _ -> C_pointer Cil.voidType
| TEnum ({ekind=i},_) -> C_int (c_int i)
| TComp (comp,_,_) -> C_comp comp
| TArray (typ_elt,e_opt,_,_) ->
@@ -272,7 +279,6 @@ let rec object_of typ =
arr_element = typ_elt;
arr_flat = None;
}
-
| Some e ->
let dim,ncells,ty_cell = dimension typ in
C_array {
@@ -444,24 +450,36 @@ let sizeof_defined = function
| C_array { arr_flat = None } -> false
| _ -> true
+let typ_comp cinfo = TComp(cinfo,Cil.empty_size_cache(),[])
+
+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.integer ~loc:Cil.builtinLoc a.arr_cell_nbr in
+ let ctype = TArray(a.arr_cell,Some csize,Cil.empty_size_cache(),[]) in
+ Cil.bitsSizeOf ctype
+ | None ->
+ if WpLog.ExternArrays.get () then
+ max_int
+ else
+ WpLog.fatal ~current:true "Sizeof unknown-size array"
+
+
let sizeof_object = function
- | C_int i -> sizeof_i i
- | C_float f -> sizeof_f f
- | C_pointer _ty -> sizeof_i (c_ptr())
- | C_comp cinfo ->
- let ctype = TComp(cinfo,Cil.empty_size_cache(),[]) in
- (Cil.bitsSizeOf ctype / 8)
- | C_array ainfo ->
- match ainfo.arr_flat with
- | Some a ->
- let csize = Cil.integer ~loc:Cil.builtinLoc a.arr_cell_nbr in
- let ctype = TArray(a.arr_cell,Some csize,Cil.empty_size_cache(),[]) in
- (Cil.bitsSizeOf ctype / 8)
- | None ->
- if WpLog.ExternArrays.get () then
- max_int
- else
- WpLog.fatal ~current:true "Sizeof unknown-size array"
+ | C_int i -> i_bytes i
+ | C_float f -> f_bytes f
+ | C_pointer _ty -> p_bytes ()
+ | C_comp cinfo -> bits_sizeof_comp cinfo / 8
+ | C_array ainfo -> bits_sizeof_array ainfo / 8
+
+let bits_sizeof_object = function
+ | C_int i -> i_bits i
+ | C_float f -> f_bits f
+ | C_pointer _ty -> p_bits ()
+ | C_comp cinfo -> bits_sizeof_comp cinfo
+ | C_array ainfo -> bits_sizeof_array ainfo
let field_offset fd =
if fd.fcomp.cstruct then (* C struct *)
@@ -490,7 +508,7 @@ let field_offset fd =
(* with greater rank, whatever *)
(* their sign. *)
-let i_convert t1 t2 = if range t1 < range t2 then t2 else t1
+let i_convert t1 t2 = if i_bits t1 < i_bits t2 then t2 else t1
let f_convert t1 t2 = if f_bits t1 < f_bits t2 then t2 else t1
let promote a1 a2 =
diff --git a/src/plugins/wp/ctypes.mli b/src/plugins/wp/ctypes.mli
index b09df11064c7352f237ebc29997f42b18528b8a3..5de9dbf2e282193a7a99d5e21cd1c090f0d95e6e 100644
--- a/src/plugins/wp/ctypes.mli
+++ b/src/plugins/wp/ctypes.mli
@@ -90,18 +90,23 @@ val c_int : ikind -> c_int (** Conforms to {Cil.theMachine} *)
val c_float : fkind -> c_float (** Conforms to {Cil.theMachine} *)
val object_of : typ -> c_object
-val is_void : typ -> bool
val is_pointer : c_object -> bool
val char : char -> int64
val constant : exp -> int64
-val get_int : exp -> int64 option
+
+val get_int : exp -> int option
+val get_int64 : exp -> int64 option
val signed : c_int -> bool (** [true] if signed *)
-val range : c_int -> int (** range in 2^n *)
val bounds: c_int -> Integer.t * Integer.t (** domain, bounds included *)
-(** All sizes are in bits *)
+val i_bits : c_int -> int (** size in bits *)
+val i_bytes : c_int -> int (** size in bytes *)
+val f_bits : c_float -> int (** size in bits *)
+val f_bytes : c_float -> int (** size in bytes *)
+val p_bits : unit -> int (** pointer size in bits *)
+val p_bytes : unit -> int (** pointer size in bits *)
val sub_c_int: c_int -> c_int -> bool
@@ -109,6 +114,9 @@ val equal_float : c_float -> c_float -> bool
val sizeof_defined : c_object -> bool
val sizeof_object : c_object -> int
+val bits_sizeof_comp : compinfo -> int
+val bits_sizeof_array : arrayinfo -> int
+val bits_sizeof_object : c_object -> int
val field_offset : fieldinfo -> int
val no_infinite_array : c_object -> bool
@@ -149,5 +157,8 @@ sig
val hash : t -> int
end
+val compare_c_int : c_int -> c_int -> int
+val compare_c_float : c_float -> c_float -> int
+
val compare_ptr_conflated : c_object -> c_object -> int
(** same as {!compare} but all PTR are considered the same *)
diff --git a/src/plugins/wp/doc/manual/wp_plugin.tex b/src/plugins/wp/doc/manual/wp_plugin.tex
index d582a2d2640f33f69f2bf06ad2d8c87c6f0e6935..d3d4fb60a65a2ad5b148354b37efdd95c47830b2 100644
--- a/src/plugins/wp/doc/manual/wp_plugin.tex
+++ b/src/plugins/wp/doc/manual/wp_plugin.tex
@@ -1368,20 +1368,31 @@ by a link (`\user{link};'). The available tags are depicted on figure~\ref{wp-dr
\end{figure}
\clearpage
-\subsection{Proof Cache}
+\subsection{Proof Session \& Cache}
\label{wp-cache}
-Running provers have a cost in terms of memory and CPU resources. When working
+The \textsf{WP} plugin can use a session directory to store informations to be used from one execution to another one.
+It is used to store proof scripts edited from the TIP (see Section~\ref{wp-proof-editor}) and to replay them from the command line.
+And it is also used to speedup the invocation of provers by reusing previous runs.
+
+Actually, running provers can be demanding in terms of memory and CPU resources. When working
interactively or incrementally, it is often the case where most proof obligations remain unchanged
from one \textsf{WP} execution to the other. To reduce this costs, a cache of prover results can be used
and stored in your session.
-The cache can only be used with \textsf{Why-3} provers, it does not work with native \textsf{Alt-Ergo} and \textsf{Coq} provers. There are different ways of using the cache, depending on your precise needs.
-The main option to control cache usage is \verb+-wp-cache+, documented below:
+The cache can only be used with \textsf{Why-3} provers, it does not work with native \textsf{Alt-Ergo}
+and \textsf{Coq} provers -- although proof scripts works with both.
+There are different ways of using the cache, depending on your precise needs.
+
+The \textsf{WP} options to control session and cache are \verb+-wp-session+ and \verb+-wp-cache+, as documented below:
\begin{description}
-\item[\tt -wp-cache <mode>] selects the cache mode to use with why3 provers. The default mode is \verb'update' if \verb+-wp-session+ is set or when using the Frama-C/Gui, and \verb+none+ otherwize. The cache entries
-are stored in the session directory, which is \verb+./frama-c/wp/cache+ by default.
+\item[\tt -wp-session <dir>] select the directory where cached results and proof scripts
+ are stored. If the local directory \verb+'.frama-c'+ already exists, the default session
+ directory \verb+'.frama-c/wp'+ will be used to setup the \textsf{WP} session.
+\item[\tt -wp-cache <mode>] selects the cache mode to use with why3 provers. The default mode is \verb'update'
+ if a \textsf{WP} session is set, and \verb+none+ otherwise. The cache entries are stored in the session directory,
+ which is \verb+./.frama-c/wp/cache+ by default.
\end{description}
The available cache modes are described below:
@@ -1395,8 +1406,7 @@ The available cache modes are described below:
\end{description}
When using cache with a non-\verb+offline+ mode, time and steps limits recorded in the cache are compared to the command line settings to produce meaningful and consistent results. Hence, if you provide more time or more steps from the command line than before, the prover would be run again. If you provide less or equal limits, the cache entries are reused, but \textsf{WP} still report the cached time and step limits to inform you of your previous attempts. For instance, if you have in the cache a « Valid » entry with time 12.4s and re-run it with a timeout of 5s, you will have a « Timeout » result with time 12.4s printed on the console.
-
-Cached result are indicated on the standard output. You might also have additional information with \verb+-wp-msg-key cache+ or you might silent them with \verb+-wp-msg-key no-cache-info+.
+Cached usage is indicated on the standard output, unless you specify \verb+-wp-msg-key no-cache-info+.
\section{Plug-in Developer Interface}
\label{wp-api}
diff --git a/src/plugins/wp/driver.mll b/src/plugins/wp/driver.mll
index e606dddb652c89d0862d82e3129d8df454ab9b61..b3b2b170b395aae98e54e08948b86fee35f03ffd 100644
--- a/src/plugins/wp/driver.mll
+++ b/src/plugins/wp/driver.mll
@@ -486,13 +486,11 @@ and bal = parse
let dkey = Wp_parameters.register_category "includes"
let dkey_driver = Wp_parameters.register_category "driver"
- let loaded : (string list * string list, driver) Hashtbl.t =Hashtbl.create 10
+ let loaded : (string list, driver) Hashtbl.t =Hashtbl.create 10
let load_driver () =
let drivers = Wp_parameters.Drivers.get () in
- let includes = Wp_parameters.get_includes () in
- let key = (drivers,includes) in
begin try
- let driver = Hashtbl.find loaded key in
+ let driver = Hashtbl.find loaded drivers in
Context.set LogicBuiltins.driver driver
with Not_found ->
let driver_basename file =
@@ -503,10 +501,9 @@ and bal = parse
let id = String.concat "_" drvs in
let descr = String.concat "," drvs in
let includes =
- let shared =
+ let directories =
try [Wp_parameters.Share.dir ~error:false ()]
with Wp_parameters.Share.No_dir -> [] in
- let directories = includes @ shared in
if Wp_parameters.has_dkey dkey then
Wp_parameters.debug ~dkey "Included directories:%t"
(fun fmt ->
@@ -528,7 +525,7 @@ and bal = parse
let ontty = if feedback then `Message else `Transient in
load_file ~ontty default;
List.iter load_file drivers;
- Hashtbl.add loaded key (Context.get LogicBuiltins.driver);
+ Hashtbl.add loaded drivers (Context.get LogicBuiltins.driver);
if Wp_parameters.has_dkey dkey_driver then LogicBuiltins.dump ()
end ; Context.get LogicBuiltins.driver
diff --git a/src/plugins/wp/register.ml b/src/plugins/wp/register.ml
index 29f760ae9ee6aec093df4f4c94a50864a65e5601..3f93fa21f7a9e0628163176d4edf3f9325aa2618 100644
--- a/src/plugins/wp/register.ml
+++ b/src/plugins/wp/register.ml
@@ -21,7 +21,10 @@
(**************************************************************************)
open Factory
-let job_key= Wp_parameters.register_category "trace-job"
+
+let dkey_main = Wp_parameters.register_category "main"
+let dkey_raised = Wp_parameters.register_category "raised"
+let dkey_shell = Wp_parameters.register_category "shell"
(* --------- Command Line ------------------- *)
@@ -296,6 +299,49 @@ let do_progress goal msg =
pp goal.Wpo.po_sid msg ;
end
+(* ------------------------------------------------------------------------ *)
+(* --- Caching --- *)
+(* ------------------------------------------------------------------------ *)
+
+let do_report_cache_usage mode =
+ if not (Wp_parameters.has_dkey dkey_shell) &&
+ not (Wp_parameters.has_dkey VCS.dkey_no_cache_info)
+ then
+ let hits = ProverWhy3.get_hits () in
+ let miss = ProverWhy3.get_miss () in
+ if hits <= 0 && miss <= 0 then
+ Wp_parameters.result "[Cache] not used"
+ else
+ Wp_parameters.result "[Cache]%t"
+ begin fun fmt ->
+ let sep = ref " " in
+ let pp_cache fmt n job =
+ if n > 0 then
+ ( Format.fprintf fmt "%s%s:%d" !sep job n ; sep := ", " ) in
+ match mode with
+ | ProverWhy3.NoCache -> ()
+ | ProverWhy3.Replay ->
+ pp_cache fmt hits "found" ;
+ pp_cache fmt miss "missed" ;
+ Format.pp_print_newline fmt () ;
+ | ProverWhy3.Offline ->
+ pp_cache fmt hits "found" ;
+ pp_cache fmt miss "failed" ;
+ Format.pp_print_newline fmt () ;
+ | ProverWhy3.Update | ProverWhy3.Cleanup ->
+ pp_cache fmt hits "found" ;
+ pp_cache fmt miss "updated" ;
+ Format.pp_print_newline fmt () ;
+ | ProverWhy3.Rebuild ->
+ pp_cache fmt hits "replaced" ;
+ pp_cache fmt miss "updated" ;
+ Format.pp_print_newline fmt () ;
+ end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Prover Results --- *)
+(* -------------------------------------------------------------------------- *)
+
let do_wpo_stat goal prover res =
let s = get_pstat prover in
let open VCS in
@@ -441,6 +487,8 @@ let do_report_scheduled () =
Wp_parameters.result "%d goal%s generated" !exercised plural
else
let proved = GOALS.cardinal !proved in
+ let mode = ProverWhy3.get_mode () in
+ if mode <> ProverWhy3.NoCache then do_report_cache_usage mode ;
Wp_parameters.result "%t"
begin fun fmt ->
Format.fprintf fmt "Proved goals: %4d / %d@\n" proved !scheduled ;
@@ -458,58 +506,6 @@ let do_list_scheduled_result () =
clear_scheduled () ;
end
-(* ------------------------------------------------------------------------ *)
-(* --- Caching --- *)
-(* ------------------------------------------------------------------------ *)
-
-let dkey_cache = Wp_parameters.register_category "cache"
-
-let do_report_cache_usage mode =
- let hits = ProverWhy3.get_hits () in
- let miss = ProverWhy3.get_miss () in
- let removed = ProverWhy3.get_removed () in
- if hits <= 0 && miss <= 0 then
- Wp_parameters.result "[Cache] not used"
- else
- Wp_parameters.result "[Cache]%t"
- begin fun fmt ->
- let sep = ref " " in
- let pp_cache fmt n job =
- if n > 0 then
- ( Format.fprintf fmt "%s%s:%d" !sep job n ; sep := ", " ) in
- match mode with
- | ProverWhy3.NoCache -> ()
- | ProverWhy3.Replay ->
- pp_cache fmt hits "found" ;
- pp_cache fmt miss "missed" ;
- Format.pp_print_newline fmt () ;
- | ProverWhy3.Offline ->
- pp_cache fmt hits "found" ;
- pp_cache fmt miss "failed" ;
- Format.pp_print_newline fmt () ;
- | ProverWhy3.Update ->
- pp_cache fmt hits "found" ;
- pp_cache fmt miss "updated" ;
- Format.pp_print_newline fmt () ;
- | ProverWhy3.Cleanup ->
- pp_cache fmt hits "found" ;
- pp_cache fmt miss "missed" ;
- pp_cache fmt removed "removed" ;
- Format.pp_print_newline fmt () ;
- | ProverWhy3.Rebuild ->
- pp_cache fmt (hits+miss) "updated" ;
- Format.pp_print_newline fmt () ;
- end
-
-(* registered at frama-c (normal) exit *)
-let do_cache_cleanup () =
- begin
- let mode = ProverWhy3.get_mode () in
- ProverWhy3.cleanup_cache ~mode ;
- if Wp_parameters.has_dkey dkey_cache
- then do_report_cache_usage mode ;
- end
-
(* ------------------------------------------------------------------------ *)
(* --- Proving --- *)
(* ------------------------------------------------------------------------ *)
@@ -693,6 +689,19 @@ let do_wp_proofs () = do_wp_proofs_iter (fun f -> Wpo.iter ~on_goal:f ())
let do_wp_proofs_for goals = do_wp_proofs_iter (fun f -> Bag.iter f goals)
+(* registered at frama-c (normal) exit *)
+let do_cache_cleanup () =
+ begin
+ let mode = ProverWhy3.get_mode () in
+ ProverWhy3.cleanup_cache ~mode ;
+ let removed = ProverWhy3.get_removed () in
+ if removed > 0 &&
+ not (Wp_parameters.has_dkey dkey_shell) &&
+ not (Wp_parameters.has_dkey VCS.dkey_no_cache_info)
+ then
+ Wp_parameters.result "[Cache] removed:%d" removed
+ end
+
(* ------------------------------------------------------------------------ *)
(* --- Secondary Entry Points --- *)
(* ------------------------------------------------------------------------ *)
@@ -748,34 +757,28 @@ let cmdline_run () =
RefUsage.compute ();
RefUsage.dump ();
end ;
- if Wp_parameters.has_dkey dkey_builtins then
- begin
- LogicBuiltins.dump ();
- end ;
let bhv = Wp_parameters.Behaviors.get () in
let prop = Wp_parameters.Properties.get () in
(** TODO entry point *)
let computer = computer () in
+ if Wp_parameters.has_dkey dkey_builtins then
+ begin
+ WpContext.on_context (computer#model,WpContext.Global)
+ LogicBuiltins.dump ();
+ end ;
Generator.compute_selection computer ~fct ~bhv ~prop ()
in
- match Wp_parameters.job () with
- | Wp_parameters.WP_None -> ()
- | Wp_parameters.WP_All ->
+ let fct = Wp_parameters.get_wp () in
+ match fct with
+ | Wp_parameters.Fct_none -> ()
+ | Wp_parameters.Fct_all ->
begin
- ignore (wp_main Generator.F_All);
+ ignore (wp_main fct);
do_wp_proofs ();
do_wp_print ();
do_wp_report ();
end
- | jb ->
- let fct =
- let open Wp_parameters in
- match jb with
- | WP_None -> Generator.F_List Cil_datatype.Kf.Set.empty
- | WP_All -> Generator.F_All
- | WP_Fct fs -> Generator.F_List fs
- | WP_SkipFct fs -> Generator.F_Skip fs
- in
+ | _ ->
begin
let goals = wp_main fct in
do_wp_proofs_for goals ;
@@ -883,13 +886,15 @@ let pp_wp_parameters fmt =
Format.pp_print_newline fmt () ;
end
-let dkey_shell = Wp_parameters.register_category "shell"
-
let () = Cmdline.run_after_setting_files
(fun _ ->
if Wp_parameters.has_dkey dkey_shell then
Log.print_on_output pp_wp_parameters)
+(* -------------------------------------------------------------------------- *)
+(* --- Prover Configuration & Detection --- *)
+(* -------------------------------------------------------------------------- *)
+
let () = Cmdline.run_after_configuring_stage Why3Provers.configure
let do_prover_detect () =
@@ -921,8 +926,6 @@ let rec try_sequence jobs () = match jobs with
| head :: tail ->
Extlib.try_finally ~finally:(try_sequence tail) head ()
-let dkey_raised = Wp_parameters.register_category "raised"
-
let sequence jobs () =
if Wp_parameters.has_dkey dkey_raised
then List.iter (fun f -> f ()) jobs
@@ -938,12 +941,12 @@ let tracelog () =
end
let main = sequence [
- (fun () -> Wp_parameters.debug ~dkey:job_key "Start WP plugin...@.") ;
+ (fun () -> Wp_parameters.debug ~dkey:dkey_main "Start WP plugin...@.") ;
do_prover_detect ;
cmdline_run ;
tracelog ;
Wp_parameters.reset ;
- (fun () -> Wp_parameters.debug ~dkey:job_key "Stop WP plugin...@.") ;
+ (fun () -> Wp_parameters.debug ~dkey:dkey_main "Stop WP plugin...@.") ;
]
let () = Cmdline.at_normal_exit do_cache_cleanup
diff --git a/src/plugins/wp/share/Makefile.resources b/src/plugins/wp/share/Makefile.resources
index 4c153ff60070b9b23a2ad5e5833375629a4f1f2e..17399b03db40b234f061ebfec038995ea45d12c7 100644
--- a/src/plugins/wp/share/Makefile.resources
+++ b/src/plugins/wp/share/Makefile.resources
@@ -27,7 +27,6 @@
## Used in share/why3
WHY3_LIBS_CEA:= \
- ArcTrigo.mlw \
cbits.mlw \
cint.mlw \
cfloat.mlw \
diff --git a/src/plugins/wp/share/ergo/Cbits.mlw b/src/plugins/wp/share/ergo/Cbits.mlw
index 1bf6749cffed1c9e2e168e513d1960e72b6f64e5..4b2b2d6ed430f12ce4b1c5e3ee9a1380be4a3f7e 100644
--- a/src/plugins/wp/share/ergo/Cbits.mlw
+++ b/src/plugins/wp/share/ergo/Cbits.mlw
@@ -27,14 +27,12 @@
(** The theory bool_Bool_ must be appended to this file*)
(** The theory int_Int_ must be appended to this file*)
(** The theory int_Abs_ must be appended to this file*)
-(** The theory int_EuclideanDivision_ must be appended to this file*)
(** The theory int_ComputerDivision_ must be appended to this file*)
(** The theory real_Real_ must be appended to this file*)
(** The theory real_RealInfix_ must be appended to this file*)
(** The theory real_FromInt_ must be appended to this file*)
-(** The theory for_drivers_ComputerOfEuclideanDivision_ must be appended to this file*)
(** The theory Cint_ must be appended to this file*)
-<<<<<<< HEAD
+
logic bit_testb : int, int -> bool
logic bit_test : int, int -> prop
@@ -51,8 +49,6 @@ logic lsl : int, int -> int
logic lsr : int, int -> int
-||||||| merged common ancestors
-=======
axiom lnot_bool : (lnot(0) = (-1))
axiom lnot_bool1 : (lnot((-1)) = 0)
@@ -87,7 +83,6 @@ axiom lxor_0 : (forall x:int [lxor(0, x)]. (lxor(0, x) = x))
axiom lxor_0bis : (forall x:int [lxor(x, 0)]. (lxor(x, 0) = x))
->>>>>>> origin/master
axiom bit_test_def :
(forall x:int. forall k:int [bit_testb(x, k)]. ((bit_testb(x, k) = true) ->
bit_test(x, k)))
@@ -536,4 +531,3 @@ axiom lor_addition :
axiom lxor_addition :
(forall x:int. forall y:int [land(x, y), lxor(x, y)]. ((land(x, y) = 0) ->
((x + y) = lxor(x, y))))
-
diff --git a/src/plugins/wp/share/ergo/Qed.mlw b/src/plugins/wp/share/ergo/Qed.mlw
index 0537e4c35cbdb14341fcfade5481df37a862b5b0..eeb3d92f8822c9f0c0e116425e7e9c457119cfca 100644
--- a/src/plugins/wp/share/ergo/Qed.mlw
+++ b/src/plugins/wp/share/ergo/Qed.mlw
@@ -26,12 +26,10 @@
(** The theory bool_Bool_ must be appended to this file*)
(** The theory int_Int_ must be appended to this file*)
(** The theory int_Abs_ must be appended to this file*)
-(** The theory int_EuclideanDivision_ must be appended to this file*)
(** The theory int_ComputerDivision_ must be appended to this file*)
(** The theory real_Real_ must be appended to this file*)
(** The theory real_RealInfix_ must be appended to this file*)
(** The theory real_FromInt_ must be appended to this file*)
-(** The theory for_drivers_ComputerOfEuclideanDivision_ must be appended to this file*)
logic match_bool : bool, 'a, 'a -> 'a
axiom match_bool1 :
diff --git a/src/plugins/wp/share/ergo/int.ComputerOfEuclideanDivision.mlw b/src/plugins/wp/share/ergo/int.ComputerOfEuclideanDivision.mlw
index ab250caabbfa9ce388e6699ec584ccd4e0fd172b..4fca9c6c375416d431f1e8a4491f37f58da2b61f 100644
--- a/src/plugins/wp/share/ergo/int.ComputerOfEuclideanDivision.mlw
+++ b/src/plugins/wp/share/ergo/int.ComputerOfEuclideanDivision.mlw
@@ -17,8 +17,8 @@
(** The theory Bool_ must be appended to this file*)
(** The theory int_Int_ must be appended to this file*)
(** The theory int_Abs_ must be appended to this file*)
-(** The theory int_EuclideanDivision_ must be appended to this file*)
(** The theory int_ComputerDivision_ must be appended to this file*)
+
axiom cdiv_cases :
(forall n:int. forall d:int [div(n, d)]. ((0 <= n) -> ((0 < d) -> (div(n,
d) = (n / d)))))
@@ -50,4 +50,3 @@ axiom cmod_cases2 :
axiom cmod_cases3 :
(forall n:int. forall d:int [mod(n, d)]. ((n <= 0) -> ((d < 0) -> (mod(n,
d) = (-((-n) % (-d)))))))
-
diff --git a/src/plugins/wp/tests/wp_acsl/oracle/logic.res.oracle b/src/plugins/wp/tests/wp_acsl/oracle/logic.res.oracle
index a3cea5bd6984268aed68ac102feb1159c7e9c6d3..1c84108b378c44fa16db512cf87e86a4d9fe60ab 100644
--- a/src/plugins/wp/tests/wp_acsl/oracle/logic.res.oracle
+++ b/src/plugins/wp/tests/wp_acsl/oracle/logic.res.oracle
@@ -39,7 +39,12 @@
------------------------------------------------------------
Goal Post-condition (file tests/wp_acsl/logic.i, line 21) in 'h':
-Prove: true.
+Let a = global(G_t_27).
+Let m = Array1_S1(shift___anonstruct_Point_1(a, 0), 3, Mint_0).
+Let m_1 = Array1_S1(a, 3, Mint_0).
+Assume { Type: IsArray1S1(m_1) /\ IsArray1S1(m). (* Call 'f' *) Have: P_P(m).
+}
+Prove: P_P(m_1).
------------------------------------------------------------
@@ -67,9 +72,9 @@ Let a_1 = shift___anonstruct_Point_1(a, 2).
Let a_2 = shift___anonstruct_Point_1(a, 1).
Let a_3 = shift___anonstruct_Point_1(a, 0).
Let a_4 = shiftfield_F4_bytes(global(G_buint_39)).
-Let m = Array1_S1(a_3, 3, Mint_0).
+Let m = Array1_S1(a, 3, Mint_0).
Assume {
- Type: IsArray1S1(m).
+ Type: IsArray1S1(m) /\ IsArray1S1(Array1_S1(a_3, 3, Mint_0)).
(* Initializer *)
Init: Mint_0[shift_uint8(a_4, 0)] = 1.
(* Initializer *)
@@ -103,9 +108,9 @@ Let a_1 = shift___anonstruct_Point_1(a, 2).
Let a_2 = shift___anonstruct_Point_1(a, 1).
Let a_3 = shift___anonstruct_Point_1(a, 0).
Let a_4 = shiftfield_F4_bytes(global(G_buint_39)).
-Let m = Array1_S1(a_3, 3, Mint_0).
+Let m = Array1_S1(a, 3, Mint_0).
Assume {
- Type: IsArray1S1(m).
+ Type: IsArray1S1(m) /\ IsArray1S1(Array1_S1(a_3, 3, Mint_0)).
(* Initializer *)
Init: Mint_0[shift_uint8(a_4, 0)] = 1.
(* Initializer *)
@@ -141,7 +146,7 @@ Let a_3 = shift___anonstruct_Point_1(a, 0).
Let a_4 = shiftfield_F4_bytes(global(G_buint_39)).
Let m = Array1_S1(a_3, 3, Mint_0).
Assume {
- Type: IsArray1S1(m).
+ Type: IsArray1S1(Array1_S1(a, 3, Mint_0)) /\ IsArray1S1(m).
(* Initializer *)
Init: Mint_0[shift_uint8(a_4, 0)] = 1.
(* Initializer *)
diff --git a/src/plugins/wp/tests/wp_acsl/oracle/pointer.res.oracle b/src/plugins/wp/tests/wp_acsl/oracle/pointer.res.oracle
index e428c32c2f5c9831b0119efe709d6ccdb7ce2f5f..729631120271baea7851ecb93afefce754328d9f 100644
--- a/src/plugins/wp/tests/wp_acsl/oracle/pointer.res.oracle
+++ b/src/plugins/wp/tests/wp_acsl/oracle/pointer.res.oracle
@@ -3,12 +3,18 @@
[wp] Running WP plugin...
[wp] Loading driver 'share/wp.driver'
[wp] Warning: Missing RTE guards
-[wp] tests/wp_acsl/pointer.i:50: Warning: Uncomparable locations p_0 and mem:t
-[wp] tests/wp_acsl/pointer.i:49: Warning: Uncomparable locations p_0 and mem:t
-[wp] tests/wp_acsl/pointer.i:48: Warning: Uncomparable locations p_0 and mem:t
-[wp] tests/wp_acsl/pointer.i:47: Warning: Uncomparable locations p_0 and mem:t
-[wp] tests/wp_acsl/pointer.i:46: Warning: Uncomparable locations p_0 and mem:t
-[wp] tests/wp_acsl/pointer.i:45: Warning: Uncomparable locations p_0 and mem:t
+[wp] tests/wp_acsl/pointer.i:50: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
+[wp] tests/wp_acsl/pointer.i:49: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
+[wp] tests/wp_acsl/pointer.i:48: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
+[wp] tests/wp_acsl/pointer.i:47: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
+[wp] tests/wp_acsl/pointer.i:46: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
+[wp] tests/wp_acsl/pointer.i:45: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
------------------------------------------------------------
Function absurd
------------------------------------------------------------
@@ -111,7 +117,7 @@ Prove: q = p.
Goal Post-condition 'qed_ok,Lt' in 'mixed_array_pointer':
tests/wp_acsl/pointer.i:45: warning from Reference Variable Model:
- Warning: Hide sub-term definition
- Reason: Uncomparable locations p_0 and mem:t
+ Reason: Uncomparable locations p_0 and mem:t.(0)
Assume {
(* Goal *)
When: 0 < w.
@@ -127,7 +133,7 @@ Prove: addr_lt(shift_sint32(global(G_t_19), 0), p).
Goal Post-condition 'qed_ok,Le' in 'mixed_array_pointer':
tests/wp_acsl/pointer.i:46: warning from Reference Variable Model:
- Warning: Hide sub-term definition
- Reason: Uncomparable locations p_0 and mem:t
+ Reason: Uncomparable locations p_0 and mem:t.(0)
Assume {
(* Goal *)
When: 0 <= w.
@@ -143,7 +149,7 @@ Prove: addr_le(shift_sint32(global(G_t_19), 0), p).
Goal Post-condition 'qed_ok,Eq' in 'mixed_array_pointer':
tests/wp_acsl/pointer.i:47: warning from Reference Variable Model:
- Warning: Hide sub-term definition
- Reason: Uncomparable locations p_0 and mem:t
+ Reason: Uncomparable locations p_0 and mem:t.(0)
Assume {
(* Heap *)
Have: region(G_t_19) <= 0.
@@ -157,7 +163,7 @@ Prove: shift_sint32(global(G_t_19), 0) = p.
Goal Post-condition 'qed_ok,Ne' in 'mixed_array_pointer':
tests/wp_acsl/pointer.i:48: warning from Reference Variable Model:
- Warning: Hide sub-term definition
- Reason: Uncomparable locations p_0 and mem:t
+ Reason: Uncomparable locations p_0 and mem:t.(0)
Assume {
(* Goal *)
When: w != 0.
@@ -173,7 +179,7 @@ Prove: shift_sint32(global(G_t_19), 0) != p.
Goal Post-condition 'qed_ko,Le_oracle_ko' in 'mixed_array_pointer':
tests/wp_acsl/pointer.i:49: warning from Reference Variable Model:
- Warning: Hide sub-term definition
- Reason: Uncomparable locations p_0 and mem:t
+ Reason: Uncomparable locations p_0 and mem:t.(0)
Assume {
(* Goal *)
When: 0 <= w.
@@ -189,7 +195,7 @@ Prove: addr_lt(shift_sint32(global(G_t_19), 0), p).
Goal Post-condition 'qed_ko,Lt_oracle_ko' in 'mixed_array_pointer':
tests/wp_acsl/pointer.i:50: warning from Reference Variable Model:
- Warning: Hide sub-term definition
- Reason: Uncomparable locations p_0 and mem:t
+ Reason: Uncomparable locations p_0 and mem:t.(0)
Assume {
(* Goal *)
When: 0 < w.
@@ -270,8 +276,8 @@ Prove: false.
------------------------------------------------------------
[wp] Warning: Memory model hypotheses for function 'compare':
- /*@ behavior typed: requires \separated(&p,q); */
+ /*@ behavior typed: requires \separated(&p,q+(..)); */
void compare(int *q);
[wp] Warning: Memory model hypotheses for function 'absurd':
- /*@ behavior typed: requires \separated(&p,q); */
+ /*@ behavior typed: requires \separated(&p,q+(..)); */
void absurd(int *q);
diff --git a/src/plugins/wp/tests/wp_acsl/oracle_qualif/init_value_mem.0.session/cache/22897f38fca9d1f1cd1837f1350d4499.json b/src/plugins/wp/tests/wp_acsl/oracle_qualif/init_value_mem.0.session/cache/ada35ef3207f170ebebb1029d3420256.json
similarity index 91%
rename from src/plugins/wp/tests/wp_acsl/oracle_qualif/init_value_mem.0.session/cache/22897f38fca9d1f1cd1837f1350d4499.json
rename to src/plugins/wp/tests/wp_acsl/oracle_qualif/init_value_mem.0.session/cache/ada35ef3207f170ebebb1029d3420256.json
index bae3da127cbd881ecd10c973b23f6aea0154f5b8..3783f56fa7d1ce2810f838c883105ecdb344ec7f 100644
--- a/src/plugins/wp/tests/wp_acsl/oracle_qualif/init_value_mem.0.session/cache/22897f38fca9d1f1cd1837f1350d4499.json
+++ b/src/plugins/wp/tests/wp_acsl/oracle_qualif/init_value_mem.0.session/cache/ada35ef3207f170ebebb1029d3420256.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0232,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0307,
"steps": 36 }
diff --git a/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/3b92daa0c60a8fd3936ce9728c00cb1b.json b/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/3b92daa0c60a8fd3936ce9728c00cb1b.json
new file mode 100644
index 0000000000000000000000000000000000000000..ba4e2a2d32ba18ae2e46dde7ff8819a2cd8fc522
--- /dev/null
+++ b/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/3b92daa0c60a8fd3936ce9728c00cb1b.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0191,
+ "steps": 30 }
diff --git a/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/090dcbb7243fc5374efafdaf37e519bb.json b/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/47d1b9e051b4330350aa41a5c9d5a242.json
similarity index 100%
rename from src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/090dcbb7243fc5374efafdaf37e519bb.json
rename to src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/47d1b9e051b4330350aa41a5c9d5a242.json
diff --git a/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/47212b097d7a57e437c6007c537e0914.json b/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/73c06b555235a7d0c550272daddaaf5c.json
similarity index 100%
rename from src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/47212b097d7a57e437c6007c537e0914.json
rename to src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/73c06b555235a7d0c550272daddaaf5c.json
diff --git a/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/850478f3d426778af16ee9be9a21ecb8.json b/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/850478f3d426778af16ee9be9a21ecb8.json
new file mode 100644
index 0000000000000000000000000000000000000000..eb4b46e40ba2406227255ff986f8a819d0c84f60
--- /dev/null
+++ b/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.0.session/cache/850478f3d426778af16ee9be9a21ecb8.json
@@ -0,0 +1 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "stepout", "steps": 50 }
diff --git a/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.res.oracle b/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.res.oracle
index 68a296dd46dbd97ec6b6cfe215de2c1a76f2a45b..28577423c82097e4e492b90b7fda1f8c7bd569f4 100644
--- a/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.res.oracle
+++ b/src/plugins/wp/tests/wp_acsl/oracle_qualif/logic.res.oracle
@@ -35,12 +35,12 @@
[wp] tests/wp_acsl/logic.i:62: Warning:
Logic cast to struct (Tint2) from (int [6]) not implemented yet
[wp] 21 goals scheduled
-[wp] [Qed] Goal typed_h_ensures : Valid
+[wp] [Alt-Ergo 2.0.0] Goal typed_h_ensures : Unsuccess
[wp] [Qed] Goal typed_h_assigns_exit : Valid
[wp] [Qed] Goal typed_h_assigns_normal : Valid
[wp] [Qed] Goal typed_main_requires_qed_ok : Valid
-[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_2 : Unsuccess
-[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_3 : Unsuccess
+[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_2 : Valid
+[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_3 : Valid
[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_4 : Unsuccess
[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_5 : Unsuccess (Stronger)
[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_6 : Unsuccess (Stronger)
@@ -56,13 +56,13 @@
[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_16 : Unsuccess (Stronger)
[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_17 : Unsuccess (Stronger)
[wp] [Alt-Ergo 2.0.0] Goal typed_main_requires_qed_ok_18 : Unsuccess (Stronger)
-[wp] Proved goals: 4 / 21
- Qed: 4
- Alt-Ergo 2.0.0: 0 (unsuccess: 17)
+[wp] Proved goals: 5 / 21
+ Qed: 3
+ Alt-Ergo 2.0.0: 2 (unsuccess: 16)
[wp] Report in: 'tests/wp_acsl/oracle_qualif/logic.0.report.json'
[wp] Report out: 'tests/wp_acsl/result_qualif/logic.0.report.json'
-------------------------------------------------------------
Functions WP Alt-Ergo Total Success
-h 3 - 3 100%
-main 1 - 18 5.6%
+h 2 - 3 66.7%
+main 1 2 (24..36) 18 16.7%
-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_acsl/oracle_qualif/pointer.0.res.oracle b/src/plugins/wp/tests/wp_acsl/oracle_qualif/pointer.0.res.oracle
index 3638dce1955a4a1e48b6bb9237273cc1e6f39f75..55a615c73c142a453cf0df1132e767a60585533c 100644
--- a/src/plugins/wp/tests/wp_acsl/oracle_qualif/pointer.0.res.oracle
+++ b/src/plugins/wp/tests/wp_acsl/oracle_qualif/pointer.0.res.oracle
@@ -3,8 +3,10 @@
[wp] Running WP plugin...
[wp] Loading driver 'share/wp.driver'
[wp] Warning: Missing RTE guards
-[wp] tests/wp_acsl/pointer.i:50: Warning: Uncomparable locations p_0 and mem:t
-[wp] tests/wp_acsl/pointer.i:49: Warning: Uncomparable locations p_0 and mem:t
+[wp] tests/wp_acsl/pointer.i:50: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
+[wp] tests/wp_acsl/pointer.i:49: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
[wp] 9 goals scheduled
[wp] [Alt-Ergo 2.0.0] Goal typed_ref_absurd_ensures_qed_ko_Base_oracle_ko : Unsuccess
[wp] [Alt-Ergo 2.0.0] Goal typed_ref_absurd_ensures_qed_ko_Comp_oracle_ko : Unsuccess
@@ -28,5 +30,5 @@ mixed_array_pointer - - 2 0.0%
absurd - - 2 0.0%
-------------------------------------------------------------
[wp] Warning: Memory model hypotheses for function 'absurd':
- /*@ behavior typed_ref: requires \separated(&p,q); */
+ /*@ behavior typed_ref: requires \separated(&p,q+(..)); */
void absurd(int *q);
diff --git a/src/plugins/wp/tests/wp_acsl/oracle_qualif/pointer.1.res.oracle b/src/plugins/wp/tests/wp_acsl/oracle_qualif/pointer.1.res.oracle
index 9d969ebd5f4bdf3fd4692d79f7e8fb2dccb5657d..717d2137042b62d4cfc5e5efefcfa8ca7acbe134 100644
--- a/src/plugins/wp/tests/wp_acsl/oracle_qualif/pointer.1.res.oracle
+++ b/src/plugins/wp/tests/wp_acsl/oracle_qualif/pointer.1.res.oracle
@@ -3,8 +3,10 @@
[wp] Running WP plugin...
[wp] Loading driver 'share/wp.driver'
[wp] Warning: Missing RTE guards
-[wp] tests/wp_acsl/pointer.i:50: Warning: Uncomparable locations p_0 and mem:t
-[wp] tests/wp_acsl/pointer.i:49: Warning: Uncomparable locations p_0 and mem:t
+[wp] tests/wp_acsl/pointer.i:50: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
+[wp] tests/wp_acsl/pointer.i:49: Warning:
+ Uncomparable locations p_0 and mem:t.(0)
[wp] 9 goals scheduled
[wp] [Alt-Ergo 2.0.0] Goal typed_absurd_ensures_qed_ko_Base_oracle_ko : Unsuccess
[wp] [Alt-Ergo 2.0.0] Goal typed_absurd_ensures_qed_ko_Comp_oracle_ko : Unsuccess
@@ -28,5 +30,5 @@ mixed_array_pointer - - 2 0.0%
absurd - - 2 0.0%
-------------------------------------------------------------
[wp] Warning: Memory model hypotheses for function 'absurd':
- /*@ behavior typed: requires \separated(&p,q); */
+ /*@ behavior typed: requires \separated(&p,q+(..)); */
void absurd(int *q);
diff --git a/src/plugins/wp/tests/wp_bts/issue-684-exit.c b/src/plugins/wp/tests/wp_bts/issue-684-exit.c
new file mode 100644
index 0000000000000000000000000000000000000000..9776a3999024830d9fccfad157987f24d84bc50e
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/issue-684-exit.c
@@ -0,0 +1,8 @@
+#include "stdlib.h"
+/*@ assigns \nothing;
+ @ exits \exit_status == state;
+ @ ensures \false;
+*/
+void inconditional_exit(int state) {
+ exit (state);
+}
diff --git a/src/plugins/wp/tests/wp_bts/issue_715_a.i b/src/plugins/wp/tests/wp_bts/issue_715_a.i
new file mode 100644
index 0000000000000000000000000000000000000000..bcadfd9430cafe19ac5a3843d8fc35de91ed4a65
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/issue_715_a.i
@@ -0,0 +1,10 @@
+/*@
+ requires *s >= 0 ;
+*/
+void dummy(int *s);
+
+void foo(void)
+{
+ int p[1] = { 0 };
+ dummy(p);
+}
diff --git a/src/plugins/wp/tests/wp_bts/issue_715_b.i b/src/plugins/wp/tests/wp_bts/issue_715_b.i
new file mode 100644
index 0000000000000000000000000000000000000000..f6f9a524280e52cf28164debe448e82aad2cd517
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/issue_715_b.i
@@ -0,0 +1,12 @@
+//@ predicate isValid(int *s) = \valid(s);
+
+/*@
+ requires isValid(dest);
+ requires dest[0] >= 0;
+*/
+void dummy(int *dest);
+
+void foo(){
+ int p[1] = { 0 } ;
+ dummy(p);
+}
diff --git a/src/plugins/wp/tests/wp_bts/oracle/bts_2110.res.oracle b/src/plugins/wp/tests/wp_bts/oracle/bts_2110.res.oracle
index 6f1d2b5ff9f58712c11ecd95a3b6bdc7a381220a..54d45f3925f1f9d511f7d0f85546683e15f2b689 100644
--- a/src/plugins/wp/tests/wp_bts/oracle/bts_2110.res.oracle
+++ b/src/plugins/wp/tests/wp_bts/oracle/bts_2110.res.oracle
@@ -66,17 +66,17 @@ theory Compound
not q = p -> Load_S2_A p (set mint q v) = Load_S2_A p mint
axiom Q_Load_S2_A_eqmem_Mint :
- forall mint:addr -> int, mint1:addr -> int, k:int, p:addr, q:addr
- [eqmem mint mint1 q k, Load_S2_A p mint| eqmem mint mint1 q k,
- Load_S2_A p mint1].
- included p 1 q k ->
- eqmem mint mint1 q k -> Load_S2_A p mint1 = Load_S2_A p mint
+ forall mint:addr -> int, mint1:addr -> int, n:int, p:addr, q:addr
+ [Load_S2_A p mint, eqmem mint mint1 q n| Load_S2_A p mint1,
+ eqmem mint mint1 q n].
+ included p 1 q n ->
+ eqmem mint mint1 q n -> Load_S2_A p mint1 = Load_S2_A p mint
axiom Q_Load_S2_A_havoc_Mint :
- forall mint:addr -> int, mint1:addr -> int, mint2:addr -> int, k:int, p:
- addr, q:addr [Load_S2_A p mint| Load_S2_A p mint1].
- havoc mint2 mint q k = mint1 ->
- separated p 1 q k -> Load_S2_A p mint1 = Load_S2_A p mint
+ forall mint:addr -> int, mint1:addr -> int, n:int, p:addr, q:addr
+ [Load_S2_A p (havoc mint1 mint q n)].
+ separated p 1 q n ->
+ Load_S2_A p (havoc mint1 mint q n) = Load_S2_A p mint
end
[wp:print-generated]
theory WP
diff --git a/src/plugins/wp/tests/wp_bts/oracle/issue-684-exit.res.oracle b/src/plugins/wp/tests/wp_bts/oracle/issue-684-exit.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..2b2e6c21c2df88606ff2a10ab33ab0e66f8f3272
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle/issue-684-exit.res.oracle
@@ -0,0 +1,28 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_bts/issue-684-exit.c (with preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+------------------------------------------------------------
+ Function inconditional_exit
+------------------------------------------------------------
+
+Goal Post-condition (file tests/wp_bts/issue-684-exit.c, line 4) in 'inconditional_exit':
+Prove: true.
+
+------------------------------------------------------------
+
+Goal Exit-condition (file tests/wp_bts/issue-684-exit.c, line 3) in 'inconditional_exit':
+Prove: true.
+
+------------------------------------------------------------
+
+Goal Assigns nothing in 'inconditional_exit':
+Prove: true.
+
+------------------------------------------------------------
+
+Goal Assigns nothing in 'inconditional_exit':
+Prove: true.
+
+------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_bts/oracle/issue_715_a.res.oracle b/src/plugins/wp/tests/wp_bts/oracle/issue_715_a.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..3d37a96e7d7d04c126f309232865a95e64b7cb7c
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle/issue_715_a.res.oracle
@@ -0,0 +1,16 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_bts/issue_715_a.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[kernel] tests/wp_bts/issue_715_a.i:6: Warning:
+ No code nor implicit assigns clause for function dummy, generating default assigns from the prototype
+[wp] Warning: Missing RTE guards
+------------------------------------------------------------
+ Function foo
+------------------------------------------------------------
+
+Goal Instance of 'Pre-condition (file tests/wp_bts/issue_715_a.i, line 2) in 'dummy'' in 'foo' at call 'dummy' (file tests/wp_bts/issue_715_a.i, line 9)
+:
+Prove: true.
+
+------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_bts/oracle/issue_715_b.res.oracle b/src/plugins/wp/tests/wp_bts/oracle/issue_715_b.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..a786d13c9660cdba5d7c3aa4c91a37260fa83f88
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle/issue_715_b.res.oracle
@@ -0,0 +1,23 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_bts/issue_715_b.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[kernel] tests/wp_bts/issue_715_b.i:9: Warning:
+ No code nor implicit assigns clause for function dummy, generating default assigns from the prototype
+[wp] Warning: Missing RTE guards
+------------------------------------------------------------
+ Function foo
+------------------------------------------------------------
+
+Goal Instance of 'Pre-condition (file tests/wp_bts/issue_715_b.i, line 4) in 'dummy'' in 'foo' at call 'dummy' (file tests/wp_bts/issue_715_b.i, line 11)
+:
+Assume { (* Heap *) Have: linked(Malloc_0). }
+Prove: P_isValid(Malloc_0[L_p_28 <- 1], shift_sint32(global(L_p_28), 0)).
+
+------------------------------------------------------------
+
+Goal Instance of 'Pre-condition (file tests/wp_bts/issue_715_b.i, line 5) in 'dummy'' in 'foo' at call 'dummy' (file tests/wp_bts/issue_715_b.i, line 11)
+:
+Prove: true.
+
+------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_bts/oracle_qualif/issue-684-exit.0.report.json b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue-684-exit.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..43d68882c15550cf2332345a3d4ce10c709184ac
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue-684-exit.0.report.json
@@ -0,0 +1,22 @@
+{ "wp:global": { "qed": { "total": 4, "valid": 4 },
+ "wp:main": { "total": 4, "valid": 4 } },
+ "wp:functions": { "inconditional_exit": { "inconditional_exit_assigns":
+ { "qed": { "total": 2,
+ "valid": 2 },
+ "wp:main": { "total": 2,
+ "valid": 2 } },
+ "inconditional_exit_ensures":
+ { "qed": { "total": 1,
+ "valid": 1 },
+ "wp:main": { "total": 1,
+ "valid": 1 } },
+ "inconditional_exit_exits":
+ { "qed": { "total": 1,
+ "valid": 1 },
+ "wp:main": { "total": 1,
+ "valid": 1 } },
+ "wp:section": { "qed": { "total": 4,
+ "valid": 4 },
+ "wp:main":
+ { "total": 4,
+ "valid": 4 } } } } }
diff --git a/src/plugins/wp/tests/wp_bts/oracle_qualif/issue-684-exit.res.oracle b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue-684-exit.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..798f9dce70e5ef0f33472fa2955b33867aa093f1
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue-684-exit.res.oracle
@@ -0,0 +1,18 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_bts/issue-684-exit.c (with preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 4 goals scheduled
+[wp] [Qed] Goal typed_inconditional_exit_ensures : Valid
+[wp] [Qed] Goal typed_inconditional_exit_exits : Valid
+[wp] [Qed] Goal typed_inconditional_exit_assigns_exit : Valid
+[wp] [Qed] Goal typed_inconditional_exit_assigns_normal : Valid
+[wp] Proved goals: 4 / 4
+ Qed: 4
+[wp] Report in: 'tests/wp_bts/oracle_qualif/issue-684-exit.0.report.json'
+[wp] Report out: 'tests/wp_bts/result_qualif/issue-684-exit.0.report.json'
+-------------------------------------------------------------
+Functions WP Alt-Ergo Total Success
+inconditional_exit 4 - 4 100%
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_a.0.report.json b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_a.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..3acc6c970188c6875b060cde5aeca241e92e5c18
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_a.0.report.json
@@ -0,0 +1,10 @@
+{ "wp:global": { "qed": { "total": 1, "valid": 1 },
+ "wp:main": { "total": 1, "valid": 1 } },
+ "wp:functions": { "foo": { "dummy_requires": { "qed": { "total": 1,
+ "valid": 1 },
+ "wp:main": { "total": 1,
+ "valid": 1 } },
+ "wp:section": { "qed": { "total": 1,
+ "valid": 1 },
+ "wp:main": { "total": 1,
+ "valid": 1 } } } } }
diff --git a/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_a.res.oracle b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_a.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..864eca8deda7cf6c58b43113a232d44863491e0c
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_a.res.oracle
@@ -0,0 +1,17 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_bts/issue_715_a.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[kernel] tests/wp_bts/issue_715_a.i:6: Warning:
+ No code nor implicit assigns clause for function dummy, generating default assigns from the prototype
+[wp] Warning: Missing RTE guards
+[wp] 1 goal scheduled
+[wp] [Qed] Goal typed_foo_call_dummy_requires : Valid
+[wp] Proved goals: 1 / 1
+ Qed: 1
+[wp] Report in: 'tests/wp_bts/oracle_qualif/issue_715_a.0.report.json'
+[wp] Report out: 'tests/wp_bts/result_qualif/issue_715_a.0.report.json'
+-------------------------------------------------------------
+Functions WP Alt-Ergo Total Success
+foo 1 - 1 100%
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.0.report.json b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..f700fbcb428e10658add65020e24732d24ce6dc6
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.0.report.json
@@ -0,0 +1,21 @@
+{ "wp:global": { "why3:Alt-Ergo,2.0.0": { "total": 1, "valid": 1, "rank": 3 },
+ "qed": { "total": 1, "valid": 1 },
+ "wp:main": { "total": 2, "valid": 2, "rank": 3 } },
+ "wp:functions": { "foo": { "dummy_requires_2": { "qed": { "total": 1,
+ "valid": 1 },
+ "wp:main": { "total": 1,
+ "valid": 1 } },
+ "dummy_requires": { "why3:Alt-Ergo,2.0.0":
+ { "total": 1, "valid": 1,
+ "rank": 3 },
+ "wp:main": { "total": 1,
+ "valid": 1,
+ "rank": 3 } },
+ "wp:section": { "why3:Alt-Ergo,2.0.0": { "total": 1,
+ "valid": 1,
+ "rank": 3 },
+ "qed": { "total": 1,
+ "valid": 1 },
+ "wp:main": { "total": 2,
+ "valid": 2,
+ "rank": 3 } } } } }
diff --git a/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.0.session/cache/d16c9211a53fccb4eb65942166fe02a2.json b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.0.session/cache/d16c9211a53fccb4eb65942166fe02a2.json
new file mode 100644
index 0000000000000000000000000000000000000000..5607410e7fdf0e81edd798d7f71dc2c480b399cc
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.0.session/cache/d16c9211a53fccb4eb65942166fe02a2.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0189,
+ "steps": 13 }
diff --git a/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.res.oracle b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..240b17af9dff1fab315506a1b5bfe768900620d5
--- /dev/null
+++ b/src/plugins/wp/tests/wp_bts/oracle_qualif/issue_715_b.res.oracle
@@ -0,0 +1,19 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_bts/issue_715_b.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[kernel] tests/wp_bts/issue_715_b.i:9: Warning:
+ No code nor implicit assigns clause for function dummy, generating default assigns from the prototype
+[wp] Warning: Missing RTE guards
+[wp] 2 goals scheduled
+[wp] [Alt-Ergo 2.0.0] Goal typed_foo_call_dummy_requires : Valid
+[wp] [Qed] Goal typed_foo_call_dummy_requires_2 : Valid
+[wp] Proved goals: 2 / 2
+ Qed: 1
+ Alt-Ergo 2.0.0: 1
+[wp] Report in: 'tests/wp_bts/oracle_qualif/issue_715_b.0.report.json'
+[wp] Report out: 'tests/wp_bts/result_qualif/issue_715_b.0.report.json'
+-------------------------------------------------------------
+Functions WP Alt-Ergo Total Success
+foo 1 1 (8..20) 2 100%
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/09dec9b675cb72a17a7c7f694202bc2a.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/09dec9b675cb72a17a7c7f694202bc2a.json
deleted file mode 100644
index fa5c0688aa29541e24fcadc5716bb839b136f98a..0000000000000000000000000000000000000000
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/09dec9b675cb72a17a7c7f694202bc2a.json
+++ /dev/null
@@ -1,2 +0,0 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 3.0065,
- "steps": 856 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/2932211f5ea4822c1cc4f1d7b5aca14c.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/0c3a16ff3ecb02ed6f91b69f76942a5f.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/2932211f5ea4822c1cc4f1d7b5aca14c.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/0c3a16ff3ecb02ed6f91b69f76942a5f.json
index 97bcecd17ab6f7c514c39bf9cefa558e10ec21d5..5a1b1f7dd70df8229f800765237be67c19c211e9 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/2932211f5ea4822c1cc4f1d7b5aca14c.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/0c3a16ff3ecb02ed6f91b69f76942a5f.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0554,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0314,
"steps": 74 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/214b0fb9511817c8882f41d7586b6bb4.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/214b0fb9511817c8882f41d7586b6bb4.json
new file mode 100644
index 0000000000000000000000000000000000000000..03f152ed73ea0df3011f5f2956eaaa3b4b8774c9
--- /dev/null
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/214b0fb9511817c8882f41d7586b6bb4.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 2.5518,
+ "steps": 856 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1a5d45fc87de676bd6e65e2299275bd8.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/27e2e343658ccf65535b56edee720c46.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1a5d45fc87de676bd6e65e2299275bd8.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/27e2e343658ccf65535b56edee720c46.json
index 0785bafe2151662d4a053c9a58f682a5afb5b79a..25159578e1f869a89a1ca200043f2f9ffeaf2bab 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1a5d45fc87de676bd6e65e2299275bd8.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/27e2e343658ccf65535b56edee720c46.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0833,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0624,
"steps": 96 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/417d31f008385f8de844ebd8a2b26109.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/32f18b2b6ec78668204d73a4ef122549.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/417d31f008385f8de844ebd8a2b26109.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/32f18b2b6ec78668204d73a4ef122549.json
index 7bb9f5b96b8e6f2fbaeb7b363dafa8f8a0efe814..ad485ff38d104b60f6b3457f22a920331d34593b 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/417d31f008385f8de844ebd8a2b26109.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/32f18b2b6ec78668204d73a4ef122549.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0825,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0517,
"steps": 99 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/788de7a3ed5ac15364ec4b0d1d549517.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/41abf1fe4d6a6b46b204b97a55f5ba46.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/788de7a3ed5ac15364ec4b0d1d549517.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/41abf1fe4d6a6b46b204b97a55f5ba46.json
index 4a0fe0253e07d2a53533afbdb5016048727c86d3..63a12236c80c74ebd59b9f7c2940929da036bceb 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/788de7a3ed5ac15364ec4b0d1d549517.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/41abf1fe4d6a6b46b204b97a55f5ba46.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 1.6653,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 1.221,
"steps": 586 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/50198fa843b3c6d73486e1c8e97986fe.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/41db8884cdb35e4120e231fbcf59b7cf.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/50198fa843b3c6d73486e1c8e97986fe.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/41db8884cdb35e4120e231fbcf59b7cf.json
index 189d0bd33804fc2c666a38055ab371b1fd16b1bd..14c6cd80068e6f4c31771a12bec60d7ed9bb5d35 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/50198fa843b3c6d73486e1c8e97986fe.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/41db8884cdb35e4120e231fbcf59b7cf.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.2276,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1436,
"steps": 179 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/720f79b436175dca03ae7858fc5c1f26.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/461fe24ecd8d691d91a96770806ef5ff.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/720f79b436175dca03ae7858fc5c1f26.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/461fe24ecd8d691d91a96770806ef5ff.json
index 1488f15736938024e2f8bca896ea0c7c72438e98..702ecef4ec3780ab1b83b2ed2b414618a2d74ee1 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/720f79b436175dca03ae7858fc5c1f26.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/461fe24ecd8d691d91a96770806ef5ff.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0553,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0538,
"steps": 77 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9d34f304e163ac58156095e675166f3d.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/4995e8c730ee8819901115149d1bb625.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9d34f304e163ac58156095e675166f3d.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/4995e8c730ee8819901115149d1bb625.json
index 5200215dad1ef9f15e0f244d9a4afe4cb9203320..a9cf316c04100e411ebf7d23308e447c1784ff52 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9d34f304e163ac58156095e675166f3d.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/4995e8c730ee8819901115149d1bb625.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0833,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0734,
"steps": 93 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a2409dfdbd49a74d79f3176de0036845.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/520cfa9227ef9a8499ea5907b0f1a23d.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a2409dfdbd49a74d79f3176de0036845.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/520cfa9227ef9a8499ea5907b0f1a23d.json
index f08a403b51571b2d112da532004f2f84fd5380c1..c84a16d022afcb122bdf635c41d0350a22b8b760 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a2409dfdbd49a74d79f3176de0036845.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/520cfa9227ef9a8499ea5907b0f1a23d.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.2383,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1518,
"steps": 222 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f73790b589aedf4d1aa297026d17411a.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/597cff9f1dc565dac843b5ef236377f7.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f73790b589aedf4d1aa297026d17411a.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/597cff9f1dc565dac843b5ef236377f7.json
index b0178e16c84d96d90f8016a878a8fcf1c56b21b3..6903049fadd16ae56e8ab9ad02b55fb8afca6e13 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f73790b589aedf4d1aa297026d17411a.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/597cff9f1dc565dac843b5ef236377f7.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1924,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1081,
"steps": 167 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/078985c01b8321ee067c085a1e9cf2ce.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5a2a0c8957f907ffd6d1208c9bc716c9.json
similarity index 72%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/078985c01b8321ee067c085a1e9cf2ce.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5a2a0c8957f907ffd6d1208c9bc716c9.json
index 377ffd62394faccc376804f41f93d937b87ff610..006402faf3aa9f1094742bd84c688df125703030 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/078985c01b8321ee067c085a1e9cf2ce.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5a2a0c8957f907ffd6d1208c9bc716c9.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.4288,
- "steps": 238 }
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0687,
+ "steps": 108 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b3c26bb27e0fffaaa5110deff2e14300.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5c1973c9a7e767b15e43009917c6851e.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b3c26bb27e0fffaaa5110deff2e14300.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5c1973c9a7e767b15e43009917c6851e.json
index 3e8c5a6c4fce755deea076d119c3fc6500003333..5f84f2d9717e9ef8adaea39adfbf9985e815cd0c 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b3c26bb27e0fffaaa5110deff2e14300.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5c1973c9a7e767b15e43009917c6851e.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0557,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0485,
"steps": 65 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/14ef4399e9eaf6ab84982330b2695be9.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5e8a70a24df8668e3eddea0531ad99e5.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/14ef4399e9eaf6ab84982330b2695be9.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5e8a70a24df8668e3eddea0531ad99e5.json
index ff22fb4a9a392384af661673d45542e10968d56a..888fbc5f5c36ffdec95559f72265fb2a8f8a6f3c 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/14ef4399e9eaf6ab84982330b2695be9.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5e8a70a24df8668e3eddea0531ad99e5.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0367,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0299,
"steps": 64 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/23ea7b534e6e972e901f5d280822c447.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/7df9a56da14d9dd93c12da0522e8e8b3.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/23ea7b534e6e972e901f5d280822c447.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/7df9a56da14d9dd93c12da0522e8e8b3.json
index 9e949102af53ca208400d66d954ab0a7e5ec4dc9..845dbcfd989ab1871ca9d0604925c0e6e261fe1d 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/23ea7b534e6e972e901f5d280822c447.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/7df9a56da14d9dd93c12da0522e8e8b3.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0622,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0329,
"steps": 80 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/3a42861a3ebc3563932adaaefa80583d.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/80d8e9979c233523c50a19ebcad3be19.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/3a42861a3ebc3563932adaaefa80583d.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/80d8e9979c233523c50a19ebcad3be19.json
index d3181803ea05726224233a31cef3965208d8b346..d02b72c658e1a0df71d40e8b465e5728d1de4482 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/3a42861a3ebc3563932adaaefa80583d.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/80d8e9979c233523c50a19ebcad3be19.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.2867,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1793,
"steps": 252 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8bcc8ca7683995ab021498efdff9c7a9.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8167f048a31fdace22ee03da7fa539af.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8bcc8ca7683995ab021498efdff9c7a9.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8167f048a31fdace22ee03da7fa539af.json
index a6c42bf73f3fb69c0265f03dda16dd747f9a719f..8f661693c04653f377d96045a530ffee1b8517af 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8bcc8ca7683995ab021498efdff9c7a9.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8167f048a31fdace22ee03da7fa539af.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0197,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0209,
"steps": 33 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/82b3f47a066db73685d212791359b54d.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/82b3f47a066db73685d212791359b54d.json
new file mode 100644
index 0000000000000000000000000000000000000000..b452c7d49a58bb6dd979bc209e90dff56736f4fe
--- /dev/null
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/82b3f47a066db73685d212791359b54d.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.348,
+ "steps": 212 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/845af4414c6bd5a5b8bb00092dfffa78.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/845af4414c6bd5a5b8bb00092dfffa78.json
deleted file mode 100644
index d245def208eeac3469f6d3492be56d5d3f4f1cdd..0000000000000000000000000000000000000000
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/845af4414c6bd5a5b8bb00092dfffa78.json
+++ /dev/null
@@ -1,2 +0,0 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1146,
- "steps": 106 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8982084a56561a53c5d6455bcda003af.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/85c0b453bc87d1ad6dfe2aa142c4b0ba.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8982084a56561a53c5d6455bcda003af.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/85c0b453bc87d1ad6dfe2aa142c4b0ba.json
index b3d102960bf3457c638a7b40f62061b6d185058b..2a1c1d97bb3f448afc7f3adfae2b7afbbe2d0767 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/8982084a56561a53c5d6455bcda003af.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/85c0b453bc87d1ad6dfe2aa142c4b0ba.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.395,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.2355,
"steps": 267 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/0d901f10aad13b11e2481369a063c076.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/951faf191dfc11e8fc646c586d96289c.json
similarity index 72%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/0d901f10aad13b11e2481369a063c076.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/951faf191dfc11e8fc646c586d96289c.json
index 89a531e9caae449bab92994594cebaeeeac8e517..3d82fce1aa03492447957b5ef223b606c1dcdfca 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/0d901f10aad13b11e2481369a063c076.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/951faf191dfc11e8fc646c586d96289c.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.3412,
- "steps": 249 }
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0784,
+ "steps": 119 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f8d98bcd8d53476d7b4bcd5ee998a283.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9ade3e7bb7e61fe51ea8379e0903d0a3.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f8d98bcd8d53476d7b4bcd5ee998a283.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9ade3e7bb7e61fe51ea8379e0903d0a3.json
index 1920fce8363108a8eab70533220536771920434a..88509a32dbcf88199e487d664dfd0690efe9182e 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f8d98bcd8d53476d7b4bcd5ee998a283.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9ade3e7bb7e61fe51ea8379e0903d0a3.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0889,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.05,
"steps": 95 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/12f261955534946a80dfa69cdf0af7df.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9cf655198880bef2ca355ed1f121fc66.json
similarity index 72%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/12f261955534946a80dfa69cdf0af7df.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9cf655198880bef2ca355ed1f121fc66.json
index 843b66a32693d2a086c9502b727c3e6ddb5e5017..04e8c1bfa4e4e948d58f333afdfdfcb2f04955b0 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/12f261955534946a80dfa69cdf0af7df.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9cf655198880bef2ca355ed1f121fc66.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1377,
- "steps": 133 }
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1134,
+ "steps": 135 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9d2df333d71dd7cc761d785740777970.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9d2df333d71dd7cc761d785740777970.json
new file mode 100644
index 0000000000000000000000000000000000000000..29ddbb59ebe0c79473dd4b4b8f38971b1297b44e
--- /dev/null
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/9d2df333d71dd7cc761d785740777970.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.3665,
+ "steps": 243 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d10fb006c2e7ab1ae79ed39f7a2856e6.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a01c8acaa455eb12c637dfaa78fb6281.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d10fb006c2e7ab1ae79ed39f7a2856e6.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a01c8acaa455eb12c637dfaa78fb6281.json
index 991bdd6f20bb35a7df582e50b0d5d0dcdf4c0a7e..f505851df0b16b78a7074398035698c78702bdb0 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d10fb006c2e7ab1ae79ed39f7a2856e6.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a01c8acaa455eb12c637dfaa78fb6281.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.055,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0537,
"steps": 65 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/eb9e8de8de87cc201e95fc1b82db0191.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a2fed4c123e00a399b2a71264588ae3f.json
similarity index 93%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/eb9e8de8de87cc201e95fc1b82db0191.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a2fed4c123e00a399b2a71264588ae3f.json
index 09a743ded655ba077979243585d58e89861ce0c3..021c0527cdcbdbbff2c7f0b935820ee6d72ad3d9 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/eb9e8de8de87cc201e95fc1b82db0191.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a2fed4c123e00a399b2a71264588ae3f.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.057,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.053,
"steps": 62 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a4c1cf1b26ba59b95dce2092293d58df.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a4c1cf1b26ba59b95dce2092293d58df.json
new file mode 100644
index 0000000000000000000000000000000000000000..83fac27d56de5577d8693954d28397d3fdac08cd
--- /dev/null
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a4c1cf1b26ba59b95dce2092293d58df.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.2842,
+ "steps": 323 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/7293c9e0a0720923a5210c1362dd38f3.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a71babb73b425cb72938455297d27098.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/7293c9e0a0720923a5210c1362dd38f3.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a71babb73b425cb72938455297d27098.json
index 1584919b4858e055a67d6284dc21fd9090248cfc..984ffc993a93a5f3de07e9c04c1c2fd5578bf25d 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/7293c9e0a0720923a5210c1362dd38f3.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a71babb73b425cb72938455297d27098.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1527,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.095,
"steps": 139 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/2d6cb92f2fd6ce2467089566831ba3fa.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b081be9daf7d73611002878d723b3594.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/2d6cb92f2fd6ce2467089566831ba3fa.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b081be9daf7d73611002878d723b3594.json
index f1fa2095778bb0350e9486c575aa7bf6133bc6e9..687204992bc710724e470dc88ef16dfafd81f291 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/2d6cb92f2fd6ce2467089566831ba3fa.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b081be9daf7d73611002878d723b3594.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0407,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0342,
"steps": 61 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a5be279fac32f0b7fee94dffea8f8101.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b6c50154bbca0d093a38a64d7c2bb3fe.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a5be279fac32f0b7fee94dffea8f8101.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b6c50154bbca0d093a38a64d7c2bb3fe.json
index 3f6cb1870ec20e97a67c10493b274b68170b4f61..0824f2ae2922155d2d58fff8f36f3201ccdc1984 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/a5be279fac32f0b7fee94dffea8f8101.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b6c50154bbca0d093a38a64d7c2bb3fe.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0269,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.017,
"steps": 29 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/824309b24946e399494ae77d99d9da7d.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/bb264654a0f79375e32e1f67e7065442.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/824309b24946e399494ae77d99d9da7d.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/bb264654a0f79375e32e1f67e7065442.json
index ec67bb2ba5b0058fd7c33398fe1bafedcfc810d7..719ae1a925db3c3838ef60199d4afc7a8d6e1caa 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/824309b24946e399494ae77d99d9da7d.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/bb264654a0f79375e32e1f67e7065442.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0495,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0351,
"steps": 73 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/6c6d479ce89091eebd496b240d58507a.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/bcd2f5408ea8fd10bdf1a0bde16708e0.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/6c6d479ce89091eebd496b240d58507a.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/bcd2f5408ea8fd10bdf1a0bde16708e0.json
index 4e61eb313dbd2970e2a5e9c4106a809e16864757..17778ee60e38cbf1cecd3270815799e8f9389711 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/6c6d479ce89091eebd496b240d58507a.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/bcd2f5408ea8fd10bdf1a0bde16708e0.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0858,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0701,
"steps": 96 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1958628752b3b6ef861b93e29a4b0740.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c11b57a25c76c5aefd4f4ca106023f8d.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1958628752b3b6ef861b93e29a4b0740.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c11b57a25c76c5aefd4f4ca106023f8d.json
index 811a5cae509221cb77c948ae7b771f3ad756e5fb..da4e3144b8fa5e1ec9e3c4944e41380cc0b4b816 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1958628752b3b6ef861b93e29a4b0740.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c11b57a25c76c5aefd4f4ca106023f8d.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0432,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0351,
"steps": 54 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5d7433204af8e481f7a8887889f7ce55.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c2cb928753e5eb6454e63f3c29c88ec5.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5d7433204af8e481f7a8887889f7ce55.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c2cb928753e5eb6454e63f3c29c88ec5.json
index 64f59330da434ee7786f06da4ef7121ddc40bfcc..2028373e9345f8a930255b6c56a876a449ab7b61 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/5d7433204af8e481f7a8887889f7ce55.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c2cb928753e5eb6454e63f3c29c88ec5.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.078,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0746,
"steps": 91 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b660ee1efdfd8a16a79a7c33e707143b.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c5ca73eda7b61e6faf847606cdfcf53e.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b660ee1efdfd8a16a79a7c33e707143b.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c5ca73eda7b61e6faf847606cdfcf53e.json
index 781a6129b8f74d7ef4f21ed049b6c366314c0890..71af6217dcac1bafeaf7e1fc68e7250eab85c689 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b660ee1efdfd8a16a79a7c33e707143b.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/c5ca73eda7b61e6faf847606cdfcf53e.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1566,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0736,
"steps": 133 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/27853ddb3ca2f0f4ad61cab2d03126b2.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d14fb37372690722d97188281edbd253.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/27853ddb3ca2f0f4ad61cab2d03126b2.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d14fb37372690722d97188281edbd253.json
index 1c63c89a9db768c3849cfd1242320374e61da0a6..3180bf13001ddada1f6b0e9a04566fa649512f9f 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/27853ddb3ca2f0f4ad61cab2d03126b2.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d14fb37372690722d97188281edbd253.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0966,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.082,
"steps": 114 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1a14c3c38306b325267f495a3b96cb22.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d9f6b94c2290c22af167ebadf0b9c8c6.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1a14c3c38306b325267f495a3b96cb22.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d9f6b94c2290c22af167ebadf0b9c8c6.json
index 20ecc6f41bfa8f743c6076fd2339a5f55ff55883..a808230480d5e152a1165c19cdab59e15fe13733 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/1a14c3c38306b325267f495a3b96cb22.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/d9f6b94c2290c22af167ebadf0b9c8c6.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0267,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0245,
"steps": 19 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b0313efe215d188230cbbcc2142dd6ed.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/dccefa8264c6127cfde9ab4406f616ce.json
similarity index 92%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b0313efe215d188230cbbcc2142dd6ed.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/dccefa8264c6127cfde9ab4406f616ce.json
index 763be250ed6a99c835d242f0186dbef2cbf048b3..7e9b39297affebbd4dee1c1adee35ebce2fa450b 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/b0313efe215d188230cbbcc2142dd6ed.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/dccefa8264c6127cfde9ab4406f616ce.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0969,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0743,
"steps": 121 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e1345f50f3bc2ff3a80387d8ffbda596.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e1345f50f3bc2ff3a80387d8ffbda596.json
deleted file mode 100644
index 670b9e65e4fdeff23b2fe0ecf3bf9897e00af300..0000000000000000000000000000000000000000
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e1345f50f3bc2ff3a80387d8ffbda596.json
+++ /dev/null
@@ -1,2 +0,0 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.522,
- "steps": 209 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e904a93fbfc0c12d33cae6f83d3efe25.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e904a93fbfc0c12d33cae6f83d3efe25.json
deleted file mode 100644
index c13a305f3f656d4b2e40e0f1bc8831cab45faff6..0000000000000000000000000000000000000000
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e904a93fbfc0c12d33cae6f83d3efe25.json
+++ /dev/null
@@ -1,2 +0,0 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.1242,
- "steps": 117 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/292e5c2995144e8404ec9571f6249f8e.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/eacfb63f26eb59d486f4b27509498428.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/292e5c2995144e8404ec9571f6249f8e.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/eacfb63f26eb59d486f4b27509498428.json
index 7529b30fb9e14f8b9a92318dbfb02fc85b03f3f2..580d13e0c1ae1a7864667a84742278a023d9a8e3 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/292e5c2995144e8404ec9571f6249f8e.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/eacfb63f26eb59d486f4b27509498428.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0703,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0505,
"steps": 82 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e0bebedc1cebd03d88317637efe09d8d.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f2ed0f1b93feba9c781bb7f0f2119c8e.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e0bebedc1cebd03d88317637efe09d8d.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f2ed0f1b93feba9c781bb7f0f2119c8e.json
index 2108f99e49d78d8caeedb0b0b7397152aebc38b6..9084cb890c92bff37e7790dd8854866de7a66d70 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/e0bebedc1cebd03d88317637efe09d8d.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f2ed0f1b93feba9c781bb7f0f2119c8e.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0367,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0292,
"steps": 74 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/86a33c92a0d8181413212c0955f840e9.json b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f5f0d5b17ac51b44de3a90bf08e03769.json
similarity index 91%
rename from src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/86a33c92a0d8181413212c0955f840e9.json
rename to src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f5f0d5b17ac51b44de3a90bf08e03769.json
index 16e4b03a58d77d91047ccf2b09c95b3aa8bfdb67..89fb35478f0d7cde07da4b95511b69a54ab3dd94 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/86a33c92a0d8181413212c0955f840e9.json
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.0.session/cache/f5f0d5b17ac51b44de3a90bf08e03769.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0675,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0578,
"steps": 77 }
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.res.oracle b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.res.oracle
index a551c80874c5dc909fbc66b4c6143d3a0e826539..3d09ff0d0a33583400382e55c994a9c741c86a50 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.res.oracle
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/frama_c_hashtbl_solved.res.oracle
@@ -118,7 +118,7 @@ eq_string 11 4 (52..64) 15 100%
hash 6 1 (12..24) 7 100%
size 2 - 2 100%
init 8 5 (80..104) 13 100%
-add 24 15 (208..256) 39 100%
+add 24 15 (224..272) 39 100%
mem_binding 18 8 (800..896) 26 100%
-------------------------------------------------------------
[wp] Running WP plugin...
diff --git a/src/plugins/wp/tests/wp_hoare/oracle/logicarr.res.oracle b/src/plugins/wp/tests/wp_hoare/oracle/logicarr.res.oracle
index 1c6d6b15d610bef874863628f574230db7f93207..5e73be63b7df4b15b4f78d60e115f956d60f302d 100644
--- a/src/plugins/wp/tests/wp_hoare/oracle/logicarr.res.oracle
+++ b/src/plugins/wp/tests/wp_hoare/oracle/logicarr.res.oracle
@@ -11,32 +11,30 @@ Goal Post-condition 'PTR' in 'job':
Let a = global(G_arr_33).
Let a_1 = shift_sint32(a, i).
Let x = Mint_0[a_1].
-Let a_2 = shift_sint32(a, 0).
-Let a_3 = shift_sint32(a, j).
-Let m = Mint_0[a_1 <- Mint_0[a_3]][a_3 <- x][shift_sint32(a, k) <- x].
+Let a_2 = shift_sint32(a, j).
+Let m = Mint_0[a_1 <- Mint_0[a_2]][a_2 <- x][shift_sint32(a, k) <- x].
Assume {
- Type: is_sint32(i) /\ is_sint32(j) /\ is_sint32(k) /\ is_sint32(x) /\
- IsArray1_sint32(Array1_int(a_2, 10, Mint_0)) /\
- IsArray1_sint32(Array1_int(a_2, 10, m)).
+ Type: is_sint32(i) /\ is_sint32(j) /\ is_sint32(k) /\
+ IsArray1_sint32(Array1_int(a, 10, Mint_0)) /\ is_sint32(x) /\
+ IsArray1_sint32(Array1_int(a, 10, m)).
(* Pre-condition *)
Have: (0 <= i) /\ (0 <= j) /\ (0 <= k) /\ (i <= 9) /\ (j <= 9) /\ (k <= 9).
}
-Prove: P_p_pointer(m, Mint_0, a_2, i, j).
+Prove: P_p_pointer(m, Mint_0, shift_sint32(a, 0), i, j).
------------------------------------------------------------
Goal Post-condition 'ARR' in 'job':
Let a = global(G_arr_33).
+Let m = Array1_int(a, 10, Mint_0).
Let a_1 = shift_sint32(a, i).
Let x = Mint_0[a_1].
-Let a_2 = shift_sint32(a, 0).
-Let m = Array1_int(a_2, 10, Mint_0).
-Let a_3 = shift_sint32(a, j).
-Let m_1 = Array1_int(a_2, 10,
- Mint_0[a_1 <- Mint_0[a_3]][a_3 <- x][shift_sint32(a, k) <- x]).
+Let a_2 = shift_sint32(a, j).
+Let m_1 = Array1_int(a, 10,
+ Mint_0[a_1 <- Mint_0[a_2]][a_2 <- x][shift_sint32(a, k) <- x]).
Assume {
- Type: is_sint32(i) /\ is_sint32(j) /\ is_sint32(k) /\ is_sint32(x) /\
- IsArray1_sint32(m) /\ IsArray1_sint32(m_1).
+ Type: is_sint32(i) /\ is_sint32(j) /\ is_sint32(k) /\ IsArray1_sint32(m) /\
+ is_sint32(x) /\ IsArray1_sint32(m_1).
(* Pre-condition *)
Have: (0 <= i) /\ (0 <= j) /\ (0 <= k) /\ (i <= 9) /\ (j <= 9) /\ (k <= 9).
}
@@ -48,13 +46,13 @@ Goal Post-condition 'DUM' in 'job':
Let a = global(G_arr_33).
Let a_1 = shift_sint32(a, i).
Let x = Mint_0[a_1].
-Let a_2 = shift_sint32(a, 0).
-Let a_3 = shift_sint32(a, j).
-Let m = Array1_int(a_2, 10,
- Mint_0[a_1 <- Mint_0[a_3]][a_3 <- x][shift_sint32(a, k) <- x]).
+Let a_2 = shift_sint32(a, j).
+Let m = Array1_int(a, 10,
+ Mint_0[a_1 <- Mint_0[a_2]][a_2 <- x][shift_sint32(a, k) <- x]).
Assume {
- Type: is_sint32(i) /\ is_sint32(j) /\ is_sint32(k) /\ is_sint32(x) /\
- IsArray1_sint32(Array1_int(a_2, 10, Mint_0)) /\ IsArray1_sint32(m).
+ Type: is_sint32(i) /\ is_sint32(j) /\ is_sint32(k) /\
+ IsArray1_sint32(Array1_int(a, 10, Mint_0)) /\ is_sint32(x) /\
+ IsArray1_sint32(m).
(* Pre-condition *)
Have: (0 <= i) /\ (0 <= j) /\ (0 <= k) /\ (i <= 9) /\ (j <= 9) /\ (k <= 9).
}
diff --git a/src/plugins/wp/tests/wp_hoare/oracle/reference_array_simple.res.oracle b/src/plugins/wp/tests/wp_hoare/oracle/reference_array_simple.res.oracle
index 90e29f22ce3a3da929a85ed0752e5382eb86f3eb..e71891e1ea8c3057377014b7b78a5fb09e1cff69 100644
--- a/src/plugins/wp/tests/wp_hoare/oracle/reference_array_simple.res.oracle
+++ b/src/plugins/wp/tests/wp_hoare/oracle/reference_array_simple.res.oracle
@@ -8,7 +8,7 @@ Init: { }
Function f1: { p1[] i }
Function call_f1: { tt tmp }
Function f2: { p2[] j }
-Function call_f2: { tt tmp[] __retres }
+Function call_f2: { tt tmp __retres }
Function f3: { p3[] k }
Function call_f3: { tp tmp }
.................................................
diff --git a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/1fed73d94cd3ea7e79e26165deb00a73.json b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/1fed73d94cd3ea7e79e26165deb00a73.json
new file mode 100644
index 0000000000000000000000000000000000000000..04a804cc155768f3b8e794e326ea6c606c2165e8
--- /dev/null
+++ b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/1fed73d94cd3ea7e79e26165deb00a73.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0248,
+ "steps": 28 }
diff --git a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/229a0707b77b3e984c3a781699a1df78.json b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/229a0707b77b3e984c3a781699a1df78.json
new file mode 100644
index 0000000000000000000000000000000000000000..4f55aabc462425d171cc292b57d3f70c39267ddb
--- /dev/null
+++ b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/229a0707b77b3e984c3a781699a1df78.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0206,
+ "steps": 28 }
diff --git a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/38f01fcc3946eedc95de0627fa9e9c8e.json b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/38f01fcc3946eedc95de0627fa9e9c8e.json
deleted file mode 100644
index bb3d1e3d493e679341d7c3935a1c7feea894c897..0000000000000000000000000000000000000000
--- a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/38f01fcc3946eedc95de0627fa9e9c8e.json
+++ /dev/null
@@ -1,2 +0,0 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0442,
- "steps": 39 }
diff --git a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/41a9a847c06c86a1a870724f991b1ea0.json b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/41a9a847c06c86a1a870724f991b1ea0.json
deleted file mode 100644
index eafe55cabc3c0729cfc68b994dc74d7954af3128..0000000000000000000000000000000000000000
--- a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/41a9a847c06c86a1a870724f991b1ea0.json
+++ /dev/null
@@ -1,2 +0,0 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0378,
- "steps": 35 }
diff --git a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/68453e74d36f575702ba0721ff25075e.json b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/68453e74d36f575702ba0721ff25075e.json
new file mode 100644
index 0000000000000000000000000000000000000000..abf443d76a281ae9f003a15d0c2a8c82e1ee035c
--- /dev/null
+++ b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/68453e74d36f575702ba0721ff25075e.json
@@ -0,0 +1,2 @@
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0321,
+ "steps": 27 }
diff --git a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/d30ddbd7a04ea0b23fb737f7bf348101.json b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/d30ddbd7a04ea0b23fb737f7bf348101.json
deleted file mode 100644
index 9331760469135b61493efde123dbffb94105ab0f..0000000000000000000000000000000000000000
--- a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.0.session/cache/d30ddbd7a04ea0b23fb737f7bf348101.json
+++ /dev/null
@@ -1,2 +0,0 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0345,
- "steps": 39 }
diff --git a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.res.oracle b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.res.oracle
index ab5a5a62ec3ed9f0b8802c3227965dde57e121a6..8a545ac23dd41a9877a8c28a01fe66469b1f4336 100644
--- a/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.res.oracle
+++ b/src/plugins/wp/tests/wp_hoare/oracle_qualif/logicarr.res.oracle
@@ -14,5 +14,5 @@
[wp] Report out: 'tests/wp_hoare/result_qualif/logicarr.0.report.json'
-------------------------------------------------------------
Functions WP Alt-Ergo Total Success
-job - 3 (32..44) 3 100%
+job - 3 (24..36) 3 100%
-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_plugin/oracle/dynamic.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle/dynamic.res.oracle
index cd88f4ec2a0806048f28f3598a2984d530930e84..c2bc3a374169220eec347429f24c6bc1ed12db52 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle/dynamic.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle/dynamic.res.oracle
@@ -377,10 +377,10 @@ Prove: true.
/*@ behavior typed: requires \separated(&X,p); */
void guarded_call(struct S *p);
[wp] Warning: Memory model hypotheses for function 'behavior':
- /*@ behavior typed: requires \separated(&X1,p); */
+ /*@ behavior typed: requires \separated(&X1,p+(..)); */
int behavior(int (*p)(void));
[wp] Warning: Memory model hypotheses for function 'some_behaviors':
- /*@ behavior typed: requires \separated(&X1,p); */
+ /*@ behavior typed: requires \separated(&X1,p+(..)); */
int some_behaviors(int (*p)(void));
[wp] Warning: Memory model hypotheses for function 'missing_context':
/*@ behavior typed: requires \separated(&X1,p); */
diff --git a/src/plugins/wp/tests/wp_plugin/oracle/inductive.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle/inductive.res.oracle
index afc65cfdfb348394fd48a23043571ab3d1935ce4..e9c5272c0cdca9ab2197a3eedc111a93dd229da1 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle/inductive.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle/inductive.res.oracle
@@ -7,7 +7,7 @@
[wp:print-generated]
"WPOUT/typed/Compound.v"
(* ---------------------------------------------------------- *)
- (* --- Memory Compound Updates --- *)
+ (* --- Memory Compound Loader --- *)
(* ---------------------------------------------------------- *)
Require Import ZArith.
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/dynamic.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/dynamic.res.oracle
index 7fdb8a52676fac4bfcee9da841bcfb4aab010d13..b7dfadf11d6526e91270534ab65459d29ad4a044 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/dynamic.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/dynamic.res.oracle
@@ -74,10 +74,10 @@ no_call 4 - 4 100%
/*@ behavior typed: requires \separated(&X,p); */
void guarded_call(struct S *p);
[wp] Warning: Memory model hypotheses for function 'behavior':
- /*@ behavior typed: requires \separated(&X1,p); */
+ /*@ behavior typed: requires \separated(&X1,p+(..)); */
int behavior(int (*p)(void));
[wp] Warning: Memory model hypotheses for function 'some_behaviors':
- /*@ behavior typed: requires \separated(&X1,p); */
+ /*@ behavior typed: requires \separated(&X1,p+(..)); */
int some_behaviors(int (*p)(void));
[wp] Warning: Memory model hypotheses for function 'missing_context':
/*@ behavior typed: requires \separated(&X1,p); */
diff --git a/src/plugins/wp/tests/wp_plugin/removed.i b/src/plugins/wp/tests/wp_plugin/removed.i
index dadeb120b00dcd110e99dcd63b1eb270116346e2..863bcebb4efd5720cafe73649a5b455303df55fe 100644
--- a/src/plugins/wp/tests/wp_plugin/removed.i
+++ b/src/plugins/wp/tests/wp_plugin/removed.i
@@ -1,5 +1,5 @@
/* run.config_qualif
- CMD: @frama-c@ -wp-share ./share -wp-msg-key success-only -wp-par 1 -wp-session @PTEST_DIR@/oracle@PTEST_CONFIG@/@PTEST_NAME@.@PTEST_NUMBER@.session -wp-cache offline
+ CMD: @frama-c@ -wp-share ./share -wp-msg-key no-cache-info,success-only -wp-par 1 -wp-session @PTEST_DIR@/oracle@PTEST_CONFIG@/@PTEST_NAME@.@PTEST_NUMBER@.session -wp-cache offline
OPT: -eva -eva-msg-key=-summary -then -wp -then -no-eva -warn-unsigned-overflow -wp
*/
diff --git a/src/plugins/wp/tests/wp_region/README.md b/src/plugins/wp/tests/wp_region/README.md
new file mode 100644
index 0000000000000000000000000000000000000000..54aa9413764131ff977dc1b9539a6f01c5c599fa
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/README.md
@@ -0,0 +1,13 @@
+# Testing WP/Region
+
+Use `./fc.sh -h|--help` to visualize the output before commiting changes.
+
+# Recommanded workflow
+
+With default configuration, put a single 'job' function in each test file.
+Then:
+
+1. Run `./fc.sh test.i -r` to visualize the region graph and check the proofs
+2. Run `./fc.sh test.i -u` to update the region-graph oracle (creates also the oracle directories)
+3. Run `./fc.sh test.i -t` to check test is OK (eventually use `-t -show` or `-t -update`)
+4. Run `./fc.sh test.i -q` to check qualif test is OK
diff --git a/src/plugins/wp/tests/wp_region/annot.i b/src/plugins/wp/tests/wp_region/annot.i
new file mode 100644
index 0000000000000000000000000000000000000000..23463af75a974c021bf5955e9689f873ac0c053e
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/annot.i
@@ -0,0 +1,63 @@
+/* run.config
+ OPT: -region-annot -print
+ EXECNOW: @frama-c@ -region-annot -print @PTEST_DIR@/@PTEST_NAME@.i -ocode @PTEST_DIR@/@PTEST_NAME@/a.i
+ EXECNOW: @frama-c@ -region-annot -print @PTEST_DIR@/@PTEST_NAME@/a.i -ocode @PTEST_DIR@/@PTEST_NAME@/b.i > /dev/null
+ EXECNOW: diff @PTEST_DIR@/@PTEST_NAME@/a.i @PTEST_DIR@/@PTEST_NAME@/b.i > /dev/null
+ */
+
+/* run.config_qualif
+ DONTRUN:
+*/
+
+// This test only checks that annotation are correctly parsed & printed
+
+typedef struct N { double v ; int s ; } *SN ;
+typedef struct L { int v ; int s ; } *SL ;
+
+typedef struct Block {
+ SN prm ;
+ SN inp1 ;
+ SN inp2 ;
+ SN inp3 ;
+ SN out1 ;
+ SN out2 ;
+ SN out3 ;
+ SL idx1 ;
+ SL idx2 ;
+ SL idx3 ;
+ SN sum ;
+} FB ;
+
+//@ region *fb ;
+void fb_ADD(FB *fb)
+{
+ fb->out1->v = fb->out1->v + fb->out2->v ;
+ fb->out1->s = fb->out1->s | fb->out2->s ;
+}
+
+/*@
+ region IN: (fb->inp1 .. fb->inp3), \pattern{PMEM} ;
+ region OUT: (fb->out1 .. fb->out3), \pattern{PVECTOR} ;
+ region IDX: (fb->idx1 .. fb->idx3), \pattern{PVECTOR} ;
+ */
+void fb_SORT(FB *fb)
+{
+ SN *inp = &(fb->inp1) ;
+ SN *out = &(fb->out1) ;
+ SL *idx = &(fb->idx1) ;
+
+ for (int i = 0; i < 3; i++) {
+ out[i]->v = inp[i]->v + fb->prm->v ;
+ out[i]->s = 0 ;
+ idx[i]->v = inp[i]->s ;
+ idx[i]->s = 0 ;
+ }
+
+ fb->sum->v =
+ fb->out1->v +
+ fb->out2->v +
+ fb->out3->v ;
+
+ fb->sum->s = 0 ;
+
+}
diff --git a/src/plugins/wp/tests/wp_region/annot/a.i b/src/plugins/wp/tests/wp_region/annot/a.i
new file mode 100644
index 0000000000000000000000000000000000000000..88fa61563c1be65c5d7db0846e8cb9298e45d8b1
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/annot/a.i
@@ -0,0 +1,58 @@
+/* Generated by Frama-C */
+struct N {
+ double v ;
+ int s ;
+};
+typedef struct N *SN;
+struct L {
+ int v ;
+ int s ;
+};
+typedef struct L *SL;
+struct Block {
+ SN prm ;
+ SN inp1 ;
+ SN inp2 ;
+ SN inp3 ;
+ SN out1 ;
+ SN out2 ;
+ SN out3 ;
+ SL idx1 ;
+ SL idx2 ;
+ SL idx3 ;
+ SN sum ;
+};
+typedef struct Block FB;
+/*@ region *fb; */
+void fb_ADD(FB *fb)
+{
+ (fb->out1)->v += (fb->out2)->v;
+ (fb->out1)->s |= (fb->out2)->s;
+ return;
+}
+
+/*@ region IN: \pattern{PMEM}, (fb->inp1..fb->inp3);
+ region OUT: \pattern{PVECTOR}, (fb->out1..fb->out3);
+ region IDX: \pattern{PVECTOR}, (fb->idx1..fb->idx3);
+ */
+void fb_SORT(FB *fb)
+{
+ SN *inp = & fb->inp1;
+ SN *out = & fb->out1;
+ SL *idx = & fb->idx1;
+ {
+ int i = 0;
+ while (i < 3) {
+ (*(out + i))->v = (*(inp + i))->v + (fb->prm)->v;
+ (*(out + i))->s = 0;
+ (*(idx + i))->v = (*(inp + i))->s;
+ (*(idx + i))->s = 0;
+ i ++;
+ }
+ }
+ (fb->sum)->v = ((fb->out1)->v + (fb->out2)->v) + (fb->out3)->v;
+ (fb->sum)->s = 0;
+ return;
+}
+
+
diff --git a/src/plugins/wp/tests/wp_region/annot/b.i b/src/plugins/wp/tests/wp_region/annot/b.i
new file mode 100644
index 0000000000000000000000000000000000000000..88fa61563c1be65c5d7db0846e8cb9298e45d8b1
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/annot/b.i
@@ -0,0 +1,58 @@
+/* Generated by Frama-C */
+struct N {
+ double v ;
+ int s ;
+};
+typedef struct N *SN;
+struct L {
+ int v ;
+ int s ;
+};
+typedef struct L *SL;
+struct Block {
+ SN prm ;
+ SN inp1 ;
+ SN inp2 ;
+ SN inp3 ;
+ SN out1 ;
+ SN out2 ;
+ SN out3 ;
+ SL idx1 ;
+ SL idx2 ;
+ SL idx3 ;
+ SN sum ;
+};
+typedef struct Block FB;
+/*@ region *fb; */
+void fb_ADD(FB *fb)
+{
+ (fb->out1)->v += (fb->out2)->v;
+ (fb->out1)->s |= (fb->out2)->s;
+ return;
+}
+
+/*@ region IN: \pattern{PMEM}, (fb->inp1..fb->inp3);
+ region OUT: \pattern{PVECTOR}, (fb->out1..fb->out3);
+ region IDX: \pattern{PVECTOR}, (fb->idx1..fb->idx3);
+ */
+void fb_SORT(FB *fb)
+{
+ SN *inp = & fb->inp1;
+ SN *out = & fb->out1;
+ SL *idx = & fb->idx1;
+ {
+ int i = 0;
+ while (i < 3) {
+ (*(out + i))->v = (*(inp + i))->v + (fb->prm)->v;
+ (*(out + i))->s = 0;
+ (*(idx + i))->v = (*(inp + i))->s;
+ (*(idx + i))->s = 0;
+ i ++;
+ }
+ }
+ (fb->sum)->v = ((fb->out1)->v + (fb->out2)->v) + (fb->out3)->v;
+ (fb->sum)->s = 0;
+ return;
+}
+
+
diff --git a/src/plugins/wp/tests/wp_region/array1.i b/src/plugins/wp/tests/wp_region/array1.i
new file mode 100644
index 0000000000000000000000000000000000000000..eac00551a13634c34e79f284c7a0bebb362b0591
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array1.i
@@ -0,0 +1,8 @@
+//@ region *p, *q ;
+int job( int n, int * p , int * q )
+{
+ int s = 0 ;
+ for (int k = 0; k < n; k++)
+ s += p[k] * q[k] ;
+ return s ;
+}
diff --git a/src/plugins/wp/tests/wp_region/array1.i.0.report.json b/src/plugins/wp/tests/wp_region/array1.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array1.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/array2.i b/src/plugins/wp/tests/wp_region/array2.i
new file mode 100644
index 0000000000000000000000000000000000000000..9b8ded175cb723b3fc41dede06d21632206f6e08
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array2.i
@@ -0,0 +1,8 @@
+//@ region *p; region *q ;
+int job( int n, int * p , int * q )
+{
+ int s = 0 ;
+ for (int k = 0; k < n; k++)
+ s += p[k] * q[k] ;
+ return s ;
+}
diff --git a/src/plugins/wp/tests/wp_region/array2.i.0.report.json b/src/plugins/wp/tests/wp_region/array2.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array2.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/array3.i b/src/plugins/wp/tests/wp_region/array3.i
new file mode 100644
index 0000000000000000000000000000000000000000..5035254bf8aaa6b247354033761c93d685946871
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array3.i
@@ -0,0 +1,6 @@
+int job( int * p )
+{
+ int s = 0 ;
+ while (!*p) { s+=*p ; p++; }
+ return s;
+}
diff --git a/src/plugins/wp/tests/wp_region/array3.i.0.report.json b/src/plugins/wp/tests/wp_region/array3.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array3.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/array4.i b/src/plugins/wp/tests/wp_region/array4.i
new file mode 100644
index 0000000000000000000000000000000000000000..bc3b3b68375becdfef9d8e8bbffcc76fe9d9dc30
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array4.i
@@ -0,0 +1,7 @@
+int job( int * p )
+{
+ int s = 0 ;
+ int *q = p ;
+ while (!*q) { s+=*q ; q++; }
+ return s;
+}
diff --git a/src/plugins/wp/tests/wp_region/array4.i.0.report.json b/src/plugins/wp/tests/wp_region/array4.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array4.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/array5.i b/src/plugins/wp/tests/wp_region/array5.i
new file mode 100644
index 0000000000000000000000000000000000000000..9fd9f2aa9f6e13083b6fb42918c613bec93e32c1
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array5.i
@@ -0,0 +1,7 @@
+int job( int * p , int * q )
+{
+ int s = 0 ;
+ q = p ;
+ while (!*q) { s+=*p ; p[s]; q++; }
+ return s;
+}
diff --git a/src/plugins/wp/tests/wp_region/array5.i.0.report.json b/src/plugins/wp/tests/wp_region/array5.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array5.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/array6.i b/src/plugins/wp/tests/wp_region/array6.i
new file mode 100644
index 0000000000000000000000000000000000000000..8136a3c37b0541a2fce551b0c69651d1214258d0
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array6.i
@@ -0,0 +1,9 @@
+int A[10] ;
+int B[20] ;
+
+int job(int k)
+{
+ int s = 0 ;
+ while (!A[k]) { s += A[k]; k++; }
+ return s ;
+}
diff --git a/src/plugins/wp/tests/wp_region/array6.i.0.report.json b/src/plugins/wp/tests/wp_region/array6.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array6.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/array7.i b/src/plugins/wp/tests/wp_region/array7.i
new file mode 100644
index 0000000000000000000000000000000000000000..8178ba26808b9319194fdf1966fd1a6b1ce531cd
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array7.i
@@ -0,0 +1,10 @@
+int A[10] ;
+int B[20] ;
+
+int job(int k)
+{
+ int s = 0 ;
+ int * p = A+k ;
+ while (!*p) { s += *p; p++; }
+ return s ;
+}
diff --git a/src/plugins/wp/tests/wp_region/array7.i.0.report.json b/src/plugins/wp/tests/wp_region/array7.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array7.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/array8.i b/src/plugins/wp/tests/wp_region/array8.i
new file mode 100644
index 0000000000000000000000000000000000000000..2ded4d8661dcd95ee85c15161272ee6de7fc3831
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array8.i
@@ -0,0 +1,10 @@
+int A[10] ;
+int B[20] ;
+
+int job(int c,int k)
+{
+ int s = 0 ;
+ int * p = (c?A:B)+k ;
+ while (!*p) { s += *p; p++; }
+ return s ;
+}
diff --git a/src/plugins/wp/tests/wp_region/array8.i.0.report.json b/src/plugins/wp/tests/wp_region/array8.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/array8.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/fb_ADD.i b/src/plugins/wp/tests/wp_region/fb_ADD.i
new file mode 100644
index 0000000000000000000000000000000000000000..3bab8bad0655f3fcce7b968520c2a3558895f45b
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/fb_ADD.i
@@ -0,0 +1,25 @@
+typedef struct N { double v ; int s ; } *SN ;
+typedef struct L { int v ; int s ; } *SL ;
+
+typedef struct Block {
+ SN prm ;
+ SN inp1 ;
+ SN inp2 ;
+ SN inp3 ;
+ SN out1 ;
+ SN out2 ;
+ SN out3 ;
+ SL idx1 ;
+ SL idx2 ;
+ SL idx3 ;
+ SN sum ;
+} FB ;
+
+/*@
+ region A: fb ;
+*/
+void job(FB *fb)
+{
+ fb->out1->v = fb->out1->v + fb->out2->v ;
+ fb->out1->s = fb->out1->s | fb->out2->s ;
+}
diff --git a/src/plugins/wp/tests/wp_region/fb_ADD.i.0.report.json b/src/plugins/wp/tests/wp_region/fb_ADD.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/fb_ADD.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/fb_SORT.i b/src/plugins/wp/tests/wp_region/fb_SORT.i
new file mode 100644
index 0000000000000000000000000000000000000000..b6289be1c9e2df06aad82783823a748864535063
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/fb_SORT.i
@@ -0,0 +1,44 @@
+typedef struct N { double v ; int s ; } *SN ;
+typedef struct L { int v ; int s ; } *SL ;
+
+typedef struct Block {
+ SN prm ;
+ SN inp1 ;
+ SN inp2 ;
+ SN inp3 ;
+ SN out1 ;
+ SN out2 ;
+ SN out3 ;
+ SL idx1 ;
+ SL idx2 ;
+ SL idx3 ;
+ SN sum ;
+} FB ;
+
+/*@
+ region Shared: *(fb->inp1 .. fb->inp3);
+ region IN: (fb->inp1 .. fb->inp3);
+ region OUT: (fb->out1 .. fb->out3);
+ region IDX: (fb->idx1 .. fb->idx3);
+ */
+void job(FB *fb)
+{
+ SN *inp = &(fb->inp1) ;
+ SN *out = &(fb->out1) ;
+ SL *idx = &(fb->idx1) ;
+
+ for (int i = 0; i < 3; i++) {
+ out[i]->v = inp[i]->v + fb->prm->v ;
+ out[i]->s = 0 ;
+ idx[i]->v = inp[i]->s ;
+ idx[i]->s = 0 ;
+ }
+
+ fb->sum->v =
+ fb->out1->v +
+ fb->out2->v +
+ fb->out3->v ;
+
+ fb->sum->s = 0 ;
+
+}
diff --git a/src/plugins/wp/tests/wp_region/fb_SORT.i.0.report.json b/src/plugins/wp/tests/wp_region/fb_SORT.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/fb_SORT.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/fc.sh b/src/plugins/wp/tests/wp_region/fc.sh
new file mode 100755
index 0000000000000000000000000000000000000000..f070fd5bb55354fb5e143e54c8b4bdc752c274a1
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/fc.sh
@@ -0,0 +1,109 @@
+# Visualize output of WP/Region tests
+
+OPT=
+CMD=fc
+TEST="<none>"
+NAME="none"
+OPEN="none"
+DEFAULT="-wp-msg-key dot,chunk,roots,garbled"
+
+if type open &> /dev/null ; then
+ OPEN=open
+elif type xpdf &> /dev/null ; then
+ OPEN=xpdf
+elif type evince &> /dev/null ; then
+ OPEN=evince
+fi
+
+while [ "$1" != "" ];
+do
+ case $1 in
+ "-h"|"--help")
+ echo "fc.sh [options...] <test.[ic]>" ;
+ echo " -h,--help help and exit" ;
+ echo " -D,--delete clean output directory and exit" ;
+ echo " -g,--gui run in Frama-C Gui" ;
+ echo " -r,--region visualize region graph" ;
+ echo " -u,--update commit region graph in oracle" ;
+ echo " -t,--test run ptests.opt on test file (or all files)" ;
+ echo " -q,--qualif run ptests.opt with test-config qualif" ;
+ echo " --open <cmd> opens pdf with '<cmd>'" ;
+ echo " -k <keys> set message keys" ;
+ echo " * any other Frama-C options" ;
+ exit 0 ;
+ ;;
+ *.i) TEST=${1}; NAME=${TEST/.i/} ;;
+ *.c) TEST=${1}; NAME=${TEST/.c/} ;;
+ "-D"|"--delete") CMD=delete ;;
+ "-u"|"--update") CMD=update ;;
+ "-t"|"--test") CMD=test ;;
+ "-q"|"--qualif") CMD=qualif ;;
+ "-g"|"--gui") CMD=gui ;;
+ "-r"|"--region") CMD=region ; OPT="${OPT} -wp-msg-key pdf" ;;
+ "--open") shift ; CMD=region ; OPEN=${1} ;;
+ "-k") shift ; CMD=region ; DEFAULT="" ; OPT="${OPT} -wp-msg-key $1" ;;
+ *)
+ OPT="${OPT} $1"
+ ;;
+ esac
+ shift
+done
+
+BIN=../../../../../bin
+WP="-wp-region -wp-model Region -wp-fct job -wp-out result/${NAME}"
+
+case $CMD in
+ "fc"|"region")
+ echo "Running frama-c $TEST"
+ $BIN/frama-c $WP $TEST $DEFAULT $OPT
+ PDF="./result/${NAME}/region/job.pdf"
+ if [ $CMD = region ] && [ -f $PDF ]
+ then
+ if [ $OPEN != none ] ; then
+ echo "Source File:"
+ cat $TEST
+ $OPEN $PDF
+ else
+ echo "No command found for opening $PDF"
+ echo "Use --open <cmd> option"
+ fi
+ fi
+ ;;
+ "gui")
+ echo "Running frama-c $TEST (Gui)"
+ $BIN/frama-c-gui $WP $TEST $OPT
+ ;;
+ "test")
+ if [ $TEST == "<none>" ]
+ then
+ echo "Testing directory..."
+ ( cd ../.. ; ../../../bin/ptests.opt tests/wp_region > /dev/null )
+ for test in *.i
+ do
+ name=${test/.i/}
+ oracle=oracle/$name/region/job.dot
+ result=result/$name/region/job.dot
+ if [ -f $oracle ] && !( diff -q $oracle $result > /dev/null )
+ then
+ echo "Diff: ./fc.sh $test -r"
+ fi
+ done
+ else
+ echo "Testing $TEST$OPT"
+ ( cd ../.. ; ../../../bin/ptests.opt tests/wp_region/$TEST $OPT )
+ fi
+ ;;
+ "qualif")
+ echo "Testing $TEST -config qualif$OPT"
+ ( cd ../.. ; ../../../bin/ptests.opt tests/wp_region/$TEST -config qualif $OPT )
+ ;;
+ "update")
+ echo "Update './oracle/$NAME/region/job.dot"
+ mkdir -p ./oracle/$NAME/region
+ cp -f ./result/$NAME/region/job.dot ./oracle/$NAME/region/
+ ;;
+ "delete")
+ echo "Cleaning './result/$NAME'"
+ rm -fr result/$NAME/*
+ ;;
+esac
diff --git a/src/plugins/wp/tests/wp_region/garbled.i b/src/plugins/wp/tests/wp_region/garbled.i
new file mode 100644
index 0000000000000000000000000000000000000000..6b703ba4245ba130e45827ac182b69f5dd03dfdd
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/garbled.i
@@ -0,0 +1,6 @@
+
+
+float job(int *p,int *q)
+{
+ return *q + *(float*)p + *p ;
+}
diff --git a/src/plugins/wp/tests/wp_region/garbled.i.0.report.json b/src/plugins/wp/tests/wp_region/garbled.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/garbled.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/index.i b/src/plugins/wp/tests/wp_region/index.i
new file mode 100644
index 0000000000000000000000000000000000000000..6151de509bc5b4fc3eb172d09db656921aae72fb
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/index.i
@@ -0,0 +1,6 @@
+int A[3][4][5] ;
+
+int job(int i,int j,int k)
+{
+ return A[i][j][k];
+}
diff --git a/src/plugins/wp/tests/wp_region/index.i.0.report.json b/src/plugins/wp/tests/wp_region/index.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/index.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/matrix.i b/src/plugins/wp/tests/wp_region/matrix.i
new file mode 100644
index 0000000000000000000000000000000000000000..f5133222090c0c4e7e9bfc09ca31aa381523eb44
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/matrix.i
@@ -0,0 +1,8 @@
+void job( int cols , int rows , int ** m , int * v , int * r )
+{
+ for (int i = 0; i < rows; i++) {
+ r[i] = 0 ;
+ for (int j = 0; j < cols; j++)
+ r[i] += m[i][j] * v[j] ;
+ }
+}
diff --git a/src/plugins/wp/tests/wp_region/matrix.i.0.report.json b/src/plugins/wp/tests/wp_region/matrix.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/matrix.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/oracle/annot.res.oracle b/src/plugins/wp/tests/wp_region/oracle/annot.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..d552bd47df89c1ee23ac54de7ea541b3e6e9d95b
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/annot.res.oracle
@@ -0,0 +1,59 @@
+[kernel] Parsing tests/wp_region/annot.i (no preprocessing)
+/* Generated by Frama-C */
+struct N {
+ double v ;
+ int s ;
+};
+typedef struct N *SN;
+struct L {
+ int v ;
+ int s ;
+};
+typedef struct L *SL;
+struct Block {
+ SN prm ;
+ SN inp1 ;
+ SN inp2 ;
+ SN inp3 ;
+ SN out1 ;
+ SN out2 ;
+ SN out3 ;
+ SL idx1 ;
+ SL idx2 ;
+ SL idx3 ;
+ SN sum ;
+};
+typedef struct Block FB;
+/*@ region *fb; */
+void fb_ADD(FB *fb)
+{
+ (fb->out1)->v += (fb->out2)->v;
+ (fb->out1)->s |= (fb->out2)->s;
+ return;
+}
+
+/*@ region IN: \pattern{PMEM}, (fb->inp1..fb->inp3);
+ region OUT: \pattern{PVECTOR}, (fb->out1..fb->out3);
+ region IDX: \pattern{PVECTOR}, (fb->idx1..fb->idx3);
+ */
+void fb_SORT(FB *fb)
+{
+ SN *inp = & fb->inp1;
+ SN *out = & fb->out1;
+ SL *idx = & fb->idx1;
+ {
+ int i = 0;
+ while (i < 3) {
+ (*(out + i))->v = (*(inp + i))->v + (fb->prm)->v;
+ (*(out + i))->s = 0;
+ (*(idx + i))->v = (*(inp + i))->s;
+ (*(idx + i))->s = 0;
+ i ++;
+ }
+ }
+ (fb->sum)->v = ((fb->out1)->v + (fb->out2)->v) + (fb->out3)->v;
+ (fb->sum)->s = 0;
+ return;
+}
+
+
diff --git a/src/plugins/wp/tests/wp_region/oracle/array1.res.oracle b/src/plugins/wp/tests/wp_region/oracle/array1.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..4987dd9ae45263a17a6338e3a4cb844be4876e93
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array1.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/array1.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/array1/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/array1/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/array1/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..8061a50b2de13b2a37de192630ce8e3dc7ca4ba7
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array1/region/job.dot
@@ -0,0 +1,57 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="n", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="q", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="s", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="k", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ A000 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _005 [ label="roots:&n", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _005; }
+ _005 -> A000 [ arrowhead="tee" ];
+ _006 [ shape="record", label="Var sint32" ];
+ A000 -> _006:w [ arrowhead="tee" ];
+ A001 [ label="D", shape="oval" ];
+ _007 [ label="roots:&p", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _007; }
+ _007 -> A001 [ arrowhead="tee" ];
+ _008 [ shape="record", label="<_p1> Ref" ];
+ _008:_p1 -> A005:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A001 -> _008:w [ arrowhead="tee" ];
+ A002 [ label="D", shape="oval" ];
+ _009 [ label="roots:&q", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _009; }
+ _009 -> A002 [ arrowhead="tee" ];
+ _010 [ shape="record", label="<_p1> Ref" ];
+ _010:_p1 -> A005:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A002 -> _010:w [ arrowhead="tee" ];
+ A003 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _011 [ shape="record", label="Var sint32" ];
+ A003 -> _011:w [ arrowhead="tee" ];
+ A004 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _012 [ shape="record", label="Var sint32" ];
+ A004 -> _012:w [ arrowhead="tee" ];
+ A005 [ label="R[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _013 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A005; _013; }
+ _013 -> A005 [ arrowhead="tee" ];
+ _014 [ shape="record", label="Mem sint32" ];
+ A005 -> _014:w [ arrowhead="tee" ];
+ R015 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R015; A006; }
+ R015 -> A006 ;
+ A006 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _016 [ shape="record", label="Var sint32" ];
+ A006 -> _016:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/array2.res.oracle b/src/plugins/wp/tests/wp_region/oracle/array2.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..b724073ea5e6c6a7fac7738b6d831e6fc1e177ca
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array2.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/array2.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/array2/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/array2/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/array2/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..4e9b35936cb28e85a2e52c1329c3263720bd15f5
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array2/region/job.dot
@@ -0,0 +1,63 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="n", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="q", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="s", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="k", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ A000 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _005 [ label="roots:&n", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _005; }
+ _005 -> A000 [ arrowhead="tee" ];
+ _006 [ shape="record", label="Var sint32" ];
+ A000 -> _006:w [ arrowhead="tee" ];
+ A001 [ label="D", shape="oval" ];
+ _007 [ label="roots:&p", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _007; }
+ _007 -> A001 [ arrowhead="tee" ];
+ _008 [ shape="record", label="<_p1> Ref" ];
+ _008:_p1 -> A005:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A001 -> _008:w [ arrowhead="tee" ];
+ A002 [ label="D", shape="oval" ];
+ _009 [ label="roots:&q", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _009; }
+ _009 -> A002 [ arrowhead="tee" ];
+ _010 [ shape="record", label="<_p1> Ref" ];
+ _010:_p1 -> A006:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A002 -> _010:w [ arrowhead="tee" ];
+ A003 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _011 [ shape="record", label="Var sint32" ];
+ A003 -> _011:w [ arrowhead="tee" ];
+ A004 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _012 [ shape="record", label="Var sint32" ];
+ A004 -> _012:w [ arrowhead="tee" ];
+ A005 [ label="R[]", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A005; _013; }
+ _013 -> A005 [ arrowhead="tee" ];
+ _014 [ shape="record", label="Mem sint32" ];
+ A005 -> _014:w [ arrowhead="tee" ];
+ A006 [ label="R[]", shape="oval", fillcolor="green", style="filled" ];
+ _015 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A006; _015; }
+ _015 -> A006 [ arrowhead="tee" ];
+ _016 [ shape="record", label="Mem sint32" ];
+ A006 -> _016:w [ arrowhead="tee" ];
+ R017 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R017; A007; }
+ R017 -> A007 ;
+ A007 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _018 [ shape="record", label="Var sint32" ];
+ A007 -> _018:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/array3.res.oracle b/src/plugins/wp/tests/wp_region/oracle/array3.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..fa7682e21183bf98f749787a3ecde94f7c1b3ce3
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array3.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/array3.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/array3/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/array3/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/array3/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..02d81fff4e3f858e95add60a92a064b67aad324f
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array3/region/job.dot
@@ -0,0 +1,33 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="s", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ A000 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _002 [ label="roots:&p", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _002; }
+ _002 -> A000 [ arrowhead="tee" ];
+ _003 [ shape="record", label="<_p1> Var ptr" ];
+ _003:_p1 -> A002:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A000 -> _003:w [ arrowhead="tee" ];
+ A001 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _004 [ shape="record", label="Var sint32" ];
+ A001 -> _004:w [ arrowhead="tee" ];
+ A002 [ label="R[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _005 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _005; }
+ _005 -> A002 [ arrowhead="tee" ];
+ _006 [ shape="record", label="Mem sint32" ];
+ A002 -> _006:w [ arrowhead="tee" ];
+ R007 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R007; A003; }
+ R007 -> A003 ;
+ A003 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _008 [ shape="record", label="Var sint32" ];
+ A003 -> _008:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/array4.res.oracle b/src/plugins/wp/tests/wp_region/oracle/array4.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..f39da987941e0ffab9390a9e6e5329dcc2a9dde6
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array4.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/array4.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/array4/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/array4/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/array4/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..e885c887b4e821e26250b46ada6140d9bf34d4bb
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array4/region/job.dot
@@ -0,0 +1,41 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="s", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="q", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ A000 [ label="D", shape="oval" ];
+ _003 [ label="roots:&p", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _003; }
+ _003 -> A000 [ arrowhead="tee" ];
+ _004 [ shape="record", label="<_p1> Ref" ];
+ _004:_p1 -> A003:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A000 -> _004:w [ arrowhead="tee" ];
+ A001 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _005 [ shape="record", label="Var sint32" ];
+ A001 -> _005:w [ arrowhead="tee" ];
+ A002 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _006 [ shape="record", label="<_p1> Var ptr" ];
+ _006:_p1 -> A003:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A002 -> _006:w [ arrowhead="tee" ];
+ A003 [ label="R[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _007 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A003; _007; }
+ _007 -> A003 [ arrowhead="tee" ];
+ _008 [ shape="record", label="Mem sint32" ];
+ A003 -> _008:w [ arrowhead="tee" ];
+ R009 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R009; A004; }
+ R009 -> A004 ;
+ A004 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _010 [ shape="record", label="Var sint32" ];
+ A004 -> _010:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/array5.res.oracle b/src/plugins/wp/tests/wp_region/oracle/array5.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..5a0a75703bf70121d5cebd897d7699c9d6a6ac96
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array5.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/array5.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/array5/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/array5/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/array5/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..f017daa76b51774c4d4fa9f340f6e92c6b42d810
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array5/region/job.dot
@@ -0,0 +1,49 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="q", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="s", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="tmp", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ A000 [ label="D", shape="oval" ];
+ _004 [ label="roots:&p", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _004; }
+ _004 -> A000 [ arrowhead="tee" ];
+ _005 [ shape="record", label="<_p1> Ref" ];
+ _005:_p1 -> A004:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A000 -> _005:w [ arrowhead="tee" ];
+ A001 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _006 [ label="roots:&q", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _006; }
+ _006 -> A001 [ arrowhead="tee" ];
+ _007 [ shape="record", label="<_p1> Var ptr" ];
+ _007:_p1 -> A004:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A001 -> _007:w [ arrowhead="tee" ];
+ A002 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _008 [ shape="record", label="Var sint32" ];
+ A002 -> _008:w [ arrowhead="tee" ];
+ A003 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _009 [ shape="record", label="Var sint32" ];
+ A003 -> _009:w [ arrowhead="tee" ];
+ A004 [ label="R[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _010 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A004; _010; }
+ _010 -> A004 [ arrowhead="tee" ];
+ _011 [ shape="record", label="Mem sint32" ];
+ A004 -> _011:w [ arrowhead="tee" ];
+ R012 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R012; A005; }
+ R012 -> A005 ;
+ A005 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ shape="record", label="Var sint32" ];
+ A005 -> _013:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/array6.res.oracle b/src/plugins/wp/tests/wp_region/oracle/array6.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..da6ccf4e0f1e820a4d240e64df242b33930b7278
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array6.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/array6.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/array6/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/array6/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/array6/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..a55f8bb5e6ea2b6edd1878b2c9e765168e6aa0e7
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array6/region/job.dot
@@ -0,0 +1,41 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="A", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="k", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="s", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ A000 [ label="", shape="oval" ];
+ _003 [ label="roots:&A", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _003; }
+ _003 -> A000 [ arrowhead="tee" ];
+ _004 [ shape="record", label="<_p1> 0..319: D32[10]" ];
+ _004:_p1 -> A003 [ style="dotted" ];
+ A000 -> _004:w [ arrowhead="tee" ];
+ A001 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _005 [ label="roots:&k", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _005; }
+ _005 -> A001 [ arrowhead="tee" ];
+ _006 [ shape="record", label="Var sint32" ];
+ A001 -> _006:w [ arrowhead="tee" ];
+ A002 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _007 [ shape="record", label="Var sint32" ];
+ A002 -> _007:w [ arrowhead="tee" ];
+ A003 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _008 [ label="roots:&A+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A003; _008; }
+ _008 -> A003 [ arrowhead="tee" ];
+ _009 [ shape="record", label="Mem sint32" ];
+ A003 -> _009:w [ arrowhead="tee" ];
+ R010 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R010; A004; }
+ R010 -> A004 ;
+ A004 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _011 [ shape="record", label="Var sint32" ];
+ A004 -> _011:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/array7.res.oracle b/src/plugins/wp/tests/wp_region/oracle/array7.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..cb757d81d87267e4a38812b6cb8762f8489e6848
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array7.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/array7.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/array7/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/array7/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/array7/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..e4b91ca2a02e735f39c91a531d400469093f4cd9
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array7/region/job.dot
@@ -0,0 +1,47 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="A", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="k", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="s", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ A000 [ label="", shape="oval" ];
+ _004 [ label="roots:&A", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _004; }
+ _004 -> A000 [ arrowhead="tee" ];
+ _005 [ shape="record", label="<_p1> 0..319: D32[10]" ];
+ _005:_p1 -> A004 [ style="dotted" ];
+ A000 -> _005:w [ arrowhead="tee" ];
+ A001 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _006 [ label="roots:&k", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _006; }
+ _006 -> A001 [ arrowhead="tee" ];
+ _007 [ shape="record", label="Var sint32" ];
+ A001 -> _007:w [ arrowhead="tee" ];
+ A002 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _008 [ shape="record", label="Var sint32" ];
+ A002 -> _008:w [ arrowhead="tee" ];
+ A003 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _009 [ shape="record", label="<_p1> Var ptr" ];
+ _009:_p1 -> A004:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A003 -> _009:w [ arrowhead="tee" ];
+ A004 [ label="R[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _010 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A004; _010; }
+ _010 -> A004 [ arrowhead="tee" ];
+ _011 [ shape="record", label="Mem sint32" ];
+ A004 -> _011:w [ arrowhead="tee" ];
+ R012 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R012; A005; }
+ R012 -> A005 ;
+ A005 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ shape="record", label="Var sint32" ];
+ A005 -> _013:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/array8.res.oracle b/src/plugins/wp/tests/wp_region/oracle/array8.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..83dd9d4238255784aba7772b3e57fb754865ad16
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array8.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/array8.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/array8/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/array8/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/array8/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..f062fa1492fad2f399e0458c6bb0dd25153c5714
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/array8/region/job.dot
@@ -0,0 +1,58 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="A", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="B", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A000 ;
+ V002 [ label="c", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A001 ;
+ V003 [ label="k", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A002 ;
+ V004 [ label="s", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A003 ;
+ V005 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V005:e -> A004 ;
+ V006 [ label="tmp", shape="cds", style="filled", fillcolor="yellow" ];
+ V006:e -> A005 ;
+ A000 [ label="R[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _007 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _007; }
+ _007 -> A000 [ arrowhead="tee" ];
+ _008 [ shape="record", label="Mem sint32" ];
+ A000 -> _008:w [ arrowhead="tee" ];
+ A001 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _009 [ label="roots:&c", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _009; }
+ _009 -> A001 [ arrowhead="tee" ];
+ _010 [ shape="record", label="Var sint32" ];
+ A001 -> _010:w [ arrowhead="tee" ];
+ A002 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _011 [ label="roots:&k", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _011; }
+ _011 -> A002 [ arrowhead="tee" ];
+ _012 [ shape="record", label="Var sint32" ];
+ A002 -> _012:w [ arrowhead="tee" ];
+ A003 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ shape="record", label="Var sint32" ];
+ A003 -> _013:w [ arrowhead="tee" ];
+ A004 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _014 [ shape="record", label="<_p1> Var ptr" ];
+ _014:_p1 -> A000:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A004 -> _014:w [ arrowhead="tee" ];
+ A005 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _015 [ shape="record", label="<_p1> Var ptr" ];
+ _015:_p1 -> A000:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A005 -> _015:w [ arrowhead="tee" ];
+ R016 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R016; A006; }
+ R016 -> A006 ;
+ A006 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _017 [ shape="record", label="Var sint32" ];
+ A006 -> _017:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/fb_ADD.res.oracle b/src/plugins/wp/tests/wp_region/oracle/fb_ADD.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..2331b4aae9657c583924d185d3f0c3fb0a9b0bc8
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/fb_ADD.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/fb_ADD.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/fb_ADD/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/fb_ADD/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/fb_ADD/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..eb1fa949b61292f0492473059be5e7da8c88292c
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/fb_ADD/region/job.dot
@@ -0,0 +1,95 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="fb", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ A000 [ label="D", shape="oval" ];
+ _001 [ label="roots:&fb", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _001; }
+ _001 -> A000 [ arrowhead="tee" ];
+ _002 [ shape="record", label="<_p1> Ref" ];
+ _002:_p1 -> A001:w [ taillabel="*", labelangle="+30", color="red" ];
+ A000 -> _002:w [ arrowhead="tee" ];
+ A001 [ label="", shape="oval" ];
+ _003 [ label="roots:&fb", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _003; }
+ _003 -> A001 [ arrowhead="tee" ];
+ _004 [ shape="record", label="<_p1> 128..159: D32|<_p2> 160..191: D32" ];
+ _004:_p2 -> A003 [ style="dotted" ];
+ _004:_p1 -> A002 [ style="dotted" ];
+ A001 -> _004:w [ arrowhead="tee" ];
+ A002 [ label="D", shape="oval" ];
+ _005 [ label="roots:&fb+128", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A002; _005; }
+ _005 -> A002 [ arrowhead="tee" ];
+ _006 [ shape="record", label="<_p1> Ref" ];
+ _006:_p1 -> A004:w [ taillabel="*", labelangle="+30", color="red" ];
+ A002 -> _006:w [ arrowhead="tee" ];
+ A003 [ label="D", shape="oval" ];
+ _007 [ label="roots:&fb+160", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A003; _007; }
+ _007 -> A003 [ arrowhead="tee" ];
+ _008 [ shape="record", label="<_p1> Ref" ];
+ _008:_p1 -> A005:w [ taillabel="*", labelangle="+30", color="red" ];
+ A003 -> _008:w [ arrowhead="tee" ];
+ A004 [ label="", shape="oval" ];
+ _009 [ label="roots:&fb+128", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A004; _009; }
+ _009 -> A004 [ arrowhead="tee" ];
+ _010 [ shape="record", label="<_p1> 0..63: D64|<_p2> 64..95: D32" ];
+ _010:_p2 -> A007 [ style="dotted" ];
+ _010:_p1 -> A006 [ style="dotted" ];
+ A004 -> _010:w [ arrowhead="tee" ];
+ A005 [ label="", shape="oval" ];
+ _011 [ label="roots:&fb+160", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A005; _011; }
+ _011 -> A005 [ arrowhead="tee" ];
+ _012 [ shape="record", label="<_p1> 0..63: D64|<_p2> 64..95: D32" ];
+ _012:_p2 -> A009 [ style="dotted" ];
+ _012:_p1 -> A008 [ style="dotted" ];
+ A005 -> _012:w [ arrowhead="tee" ];
+ A006 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ label="roots:&fb+128", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A006; _013; }
+ _013 -> A006 [ arrowhead="tee" ];
+ _014 [ shape="record", label="Var float64" ];
+ A006 -> _014:w [ arrowhead="tee" ];
+ A007 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _015 [ label="roots:&fb+192", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A007; _015; }
+ _015 -> A007 [ arrowhead="tee" ];
+ _016 [ shape="record", label="Var sint32" ];
+ A007 -> _016:w [ arrowhead="tee" ];
+ A008 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _017 [ label="roots:&fb+160", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A008; _017; }
+ _017 -> A008 [ arrowhead="tee" ];
+ _018 [ shape="record", label="Var float64" ];
+ A008 -> _018:w [ arrowhead="tee" ];
+ A009 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _019 [ label="roots:&fb+224", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A009; _019; }
+ _019 -> A009 [ arrowhead="tee" ];
+ _020 [ shape="record", label="Var sint32" ];
+ A009 -> _020:w [ arrowhead="tee" ];
+ R021 [ label="A", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R021; A000; }
+ R021 -> A000 ;
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/fb_SORT.res.oracle b/src/plugins/wp/tests/wp_region/oracle/fb_SORT.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..ec1a0b83feb62c26278e26829c9a50d83687ef97
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/fb_SORT.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/fb_SORT.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/fb_SORT/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/fb_SORT/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/fb_SORT/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..4cbd5b27d23593f242fbdb78151766885a29f883
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/fb_SORT/region/job.dot
@@ -0,0 +1,204 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="fb", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="inp", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="out", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="idx", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="i", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ A000 [ label="D", shape="oval" ];
+ _005 [ label="roots:&fb", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _005; }
+ _005 -> A000 [ arrowhead="tee" ];
+ _006 [ shape="record", label="<_p1> Ref" ];
+ _006:_p1 -> A005:w [ taillabel="*", labelangle="+30", color="red" ];
+ A000 -> _006:w [ arrowhead="tee" ];
+ A001 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _007 [ shape="record", label="<_p1> Var ptr" ];
+ _007:_p1 -> A006:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A001 -> _007:w [ arrowhead="tee" ];
+ A002 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _008 [ shape="record", label="<_p1> Var ptr" ];
+ _008:_p1 -> A007:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A002 -> _008:w [ arrowhead="tee" ];
+ A003 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _009 [ shape="record", label="<_p1> Var ptr" ];
+ _009:_p1 -> A008:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A003 -> _009:w [ arrowhead="tee" ];
+ A004 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _010 [ shape="record", label="Var sint32" ];
+ A004 -> _010:w [ arrowhead="tee" ];
+ A005 [ label="", shape="oval" ];
+ _011 [ label="roots:&fb", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A005; _011; }
+ _011 -> A005 [ arrowhead="tee" ];
+ _012 [ shape="record",
+ label="<_p1> 0..31: D32|<_p2> 32..127: D32[3]|<_p3> 128..223: D32[3]|<_p4> 224..319: D32[3]|<_p5> 320..351: D32"
+ ];
+ _012:_p5 -> A010 [ style="dotted" ];
+ _012:_p4 -> A008 [ style="dotted" ];
+ _012:_p3 -> A007 [ style="dotted" ];
+ _012:_p2 -> A006 [ style="dotted" ];
+ _012:_p1 -> A009 [ style="dotted" ];
+ A005 -> _012:w [ arrowhead="tee" ];
+ A006 [ label="D[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _013 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A006; _013; }
+ _013 -> A006 [ arrowhead="tee" ];
+ _014 [ shape="record", label="<_p1> Ref" ];
+ _014:_p1 -> A011:w [ taillabel="*", labelangle="+30", color="red" ];
+ A006 -> _014:w [ arrowhead="tee" ];
+ A007 [ label="D[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _015 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A007; _015; }
+ _015 -> A007 [ arrowhead="tee" ];
+ _016 [ shape="record", label="<_p1> Ref" ];
+ _016:_p1 -> A012:w [ taillabel="*", labelangle="+30", color="red" ];
+ A007 -> _016:w [ arrowhead="tee" ];
+ A008 [ label="D[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _017 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A008; _017; }
+ _017 -> A008 [ arrowhead="tee" ];
+ _018 [ shape="record", label="<_p1> Ref" ];
+ _018:_p1 -> A013:w [ taillabel="*", labelangle="+30", color="red" ];
+ A008 -> _018:w [ arrowhead="tee" ];
+ A009 [ label="D", shape="oval" ];
+ _019 [ label="roots:&fb", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A009; _019; }
+ _019 -> A009 [ arrowhead="tee" ];
+ _020 [ shape="record", label="<_p1> Ref" ];
+ _020:_p1 -> A014:w [ taillabel="*", labelangle="+30", color="red" ];
+ A009 -> _020:w [ arrowhead="tee" ];
+ A010 [ label="D", shape="oval" ];
+ _021 [ label="roots:&fb+320", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A010; _021; }
+ _021 -> A010 [ arrowhead="tee" ];
+ _022 [ shape="record", label="<_p1> Ref" ];
+ _022:_p1 -> A015:w [ taillabel="*", labelangle="+30", color="red" ];
+ A010 -> _022:w [ arrowhead="tee" ];
+ A011 [ label="&", shape="oval", fillcolor="orange", style="filled" ];
+ _023 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A011; _023; }
+ _023 -> A011 [ arrowhead="tee" ];
+ _024 [ shape="record", label="<_p1> 0..63: D64|<_p2> 64..95: D32" ];
+ _024:_p2 -> A017 [ style="dotted" ];
+ _024:_p1 -> A016 [ style="dotted" ];
+ A011 -> _024:w [ arrowhead="tee" ];
+ A012 [ label="", shape="oval" ];
+ _025 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A012; _025; }
+ _025 -> A012 [ arrowhead="tee" ];
+ _026 [ shape="record", label="<_p1> 0..63: D64|<_p2> 64..95: D32" ];
+ _026:_p2 -> A019 [ style="dotted" ];
+ _026:_p1 -> A018 [ style="dotted" ];
+ A012 -> _026:w [ arrowhead="tee" ];
+ A013 [ label="", shape="oval" ];
+ _027 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A013; _027; }
+ _027 -> A013 [ arrowhead="tee" ];
+ _028 [ shape="record", label="<_p1> 0..31: D32|<_p2> 32..63: D32" ];
+ _028:_p2 -> A021 [ style="dotted" ];
+ _028:_p1 -> A020 [ style="dotted" ];
+ A013 -> _028:w [ arrowhead="tee" ];
+ A014 [ label="", shape="oval" ];
+ _029 [ label="roots:&fb", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A014; _029; }
+ _029 -> A014 [ arrowhead="tee" ];
+ _030 [ shape="record", label="<_p1> 0..63: D64" ];
+ _030:_p1 -> A022 [ style="dotted" ];
+ A014 -> _030:w [ arrowhead="tee" ];
+ A015 [ label="", shape="oval" ];
+ _031 [ label="roots:&fb+320", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A015; _031; }
+ _031 -> A015 [ arrowhead="tee" ];
+ _032 [ shape="record", label="<_p1> 0..63: D64|<_p2> 64..95: D32" ];
+ _032:_p2 -> A024 [ style="dotted" ];
+ _032:_p1 -> A023 [ style="dotted" ];
+ A015 -> _032:w [ arrowhead="tee" ];
+ A016 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _033 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A016; _033; }
+ _033 -> A016 [ arrowhead="tee" ];
+ _034 [ shape="record", label="Mem float64" ];
+ A016 -> _034:w [ arrowhead="tee" ];
+ A017 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _035 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A017; _035; }
+ _035 -> A017 [ arrowhead="tee" ];
+ _036 [ shape="record", label="Mem sint32" ];
+ A017 -> _036:w [ arrowhead="tee" ];
+ A018 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _037 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A018; _037; }
+ _037 -> A018 [ arrowhead="tee" ];
+ _038 [ shape="record", label="Mem float64" ];
+ A018 -> _038:w [ arrowhead="tee" ];
+ A019 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _039 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A019; _039; }
+ _039 -> A019 [ arrowhead="tee" ];
+ _040 [ shape="record", label="Mem sint32" ];
+ A019 -> _040:w [ arrowhead="tee" ];
+ A020 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _041 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A020; _041; }
+ _041 -> A020 [ arrowhead="tee" ];
+ _042 [ shape="record", label="Mem sint32" ];
+ A020 -> _042:w [ arrowhead="tee" ];
+ A021 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _043 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A021; _043; }
+ _043 -> A021 [ arrowhead="tee" ];
+ _044 [ shape="record", label="Mem sint32" ];
+ A021 -> _044:w [ arrowhead="tee" ];
+ A022 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _045 [ label="roots:&fb", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A022; _045; }
+ _045 -> A022 [ arrowhead="tee" ];
+ _046 [ shape="record", label="Var float64" ];
+ A022 -> _046:w [ arrowhead="tee" ];
+ A023 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _047 [ label="roots:&fb+320", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A023; _047; }
+ _047 -> A023 [ arrowhead="tee" ];
+ _048 [ shape="record", label="Var float64" ];
+ A023 -> _048:w [ arrowhead="tee" ];
+ A024 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _049 [ label="roots:&fb+384", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A024; _049; }
+ _049 -> A024 [ arrowhead="tee" ];
+ _050 [ shape="record", label="Var sint32" ];
+ A024 -> _050:w [ arrowhead="tee" ];
+ R051 [ label="IDX", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R051; A008; }
+ R051 -> A008 ;
+ R052 [ label="IN", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R052; A006; }
+ R052 -> A006 ;
+ R053 [ label="OUT", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R053; A007; }
+ R053 -> A007 ;
+ R054 [ label="Shared", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R054; A011; }
+ R054 -> A011 ;
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/garbled.res.oracle b/src/plugins/wp/tests/wp_region/oracle/garbled.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..13973473a6739603448758d6940000363173431e
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/garbled.res.oracle
@@ -0,0 +1,7 @@
+[kernel] Parsing tests/wp_region/garbled.i (no preprocessing)
+[wp:garbled] Garbled Clusters: A=sint32 B=float32
+[wp:garbled] Garbled Clusters: A=garbled B=sint32
+[wp:garbled] Garbled Clusters: A=garbled B=float32
+[wp] Region Graph: tests/wp_region/result/garbled/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/garbled/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/garbled/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..1f13727a1f33006dd8dc3a85b608b3e74a1b5dc3
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/garbled/region/job.dot
@@ -0,0 +1,48 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="q", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="__retres", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ A000 [ label="D", shape="oval" ];
+ _003 [ label="roots:&p", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _003; }
+ _003 -> A000 [ arrowhead="tee" ];
+ _004 [ shape="record", label="<_p1> Ref" ];
+ _004:_p1 -> A003:w [ taillabel="*", labelangle="+30", color="red" ];
+ A000 -> _004:w [ arrowhead="tee" ];
+ A001 [ label="D", shape="oval" ];
+ _005 [ label="roots:&q", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _005; }
+ _005 -> A001 [ arrowhead="tee" ];
+ _006 [ shape="record", label="<_p1> Ref" ];
+ _006:_p1 -> A004:w [ taillabel="*", labelangle="+30", color="red" ];
+ A001 -> _006:w [ arrowhead="tee" ];
+ A002 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _007 [ shape="record", label="Var float32" ];
+ A002 -> _007:w [ arrowhead="tee" ];
+ A003 [ label="R", shape="oval", color="red", fillcolor="red",
+ style="filled"
+ ];
+ _008 [ label="roots:&p", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A003; _008; }
+ _008 -> A003 [ arrowhead="tee" ];
+ _009 [ shape="record", label="Raw", fillcolor="red", style="filled" ];
+ A003 -> _009:w [ arrowhead="tee" ];
+ A004 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _010 [ label="roots:&q", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A004; _010; }
+ _010 -> A004 [ arrowhead="tee" ];
+ _011 [ shape="record", label="Var sint32" ];
+ A004 -> _011:w [ arrowhead="tee" ];
+ R012 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R012; A005; }
+ R012 -> A005 ;
+ A005 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ shape="record", label="Var float32" ];
+ A005 -> _013:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/index.res.oracle b/src/plugins/wp/tests/wp_region/oracle/index.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..834049467cbde15d83aba42c883878baaa71ed0f
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/index.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/index.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/index/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/index/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/index/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..5aea05755a41cc4c8ae8eaf06c3a06ed763927e8
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/index/region/job.dot
@@ -0,0 +1,57 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="A", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="i", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="j", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="k", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="__retres", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ A000 [ label="", shape="oval" ];
+ _005 [ label="roots:&A", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _005; }
+ _005 -> A000 [ arrowhead="tee" ];
+ _006 [ shape="record", label="<_p1> 0..1919: D32[5,4,3]" ];
+ _006:_p1 -> A005 [ style="dotted" ];
+ A000 -> _006:w [ arrowhead="tee" ];
+ A001 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _007 [ label="roots:&i", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _007; }
+ _007 -> A001 [ arrowhead="tee" ];
+ _008 [ shape="record", label="Var sint32" ];
+ A001 -> _008:w [ arrowhead="tee" ];
+ A002 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _009 [ label="roots:&j", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _009; }
+ _009 -> A002 [ arrowhead="tee" ];
+ _010 [ shape="record", label="Var sint32" ];
+ A002 -> _010:w [ arrowhead="tee" ];
+ A003 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _011 [ label="roots:&k", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A003; _011; }
+ _011 -> A003 [ arrowhead="tee" ];
+ _012 [ shape="record", label="Var sint32" ];
+ A003 -> _012:w [ arrowhead="tee" ];
+ A004 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ shape="record", label="Var sint32" ];
+ A004 -> _013:w [ arrowhead="tee" ];
+ A005 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _014 [ label="roots:&A+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A005; _014; }
+ _014 -> A005 [ arrowhead="tee" ];
+ _015 [ shape="record", label="Mem sint32" ];
+ A005 -> _015:w [ arrowhead="tee" ];
+ R016 [ label="\\result", shape="tab", style="filled", fillcolor="yellow" ];
+ { rank=same; R016; A006; }
+ R016 -> A006 ;
+ A006 [ label="W", shape="oval", fillcolor="green", style="filled" ];
+ _017 [ shape="record", label="Var sint32" ];
+ A006 -> _017:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/matrix.res.oracle b/src/plugins/wp/tests/wp_region/oracle/matrix.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..fe737f1db75548cc56518bebf54a18bc070f442f
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/matrix.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/matrix.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/matrix/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/matrix/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/matrix/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..fcce73f07e94697143a17a714e1605709e77c9f6
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/matrix/region/job.dot
@@ -0,0 +1,93 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="cols", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="rows", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="m", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="v", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="r", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ V005 [ label="i", shape="cds", style="filled", fillcolor="yellow" ];
+ V005:e -> A005 ;
+ V006 [ label="j", shape="cds", style="filled", fillcolor="yellow" ];
+ V006:e -> A006 ;
+ A000 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _007 [ label="roots:&cols", style="filled", color="lightblue", shape="box"
+ ];
+ { rank=same; A000; _007; }
+ _007 -> A000 [ arrowhead="tee" ];
+ _008 [ shape="record", label="Var sint32" ];
+ A000 -> _008:w [ arrowhead="tee" ];
+ A001 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _009 [ label="roots:&rows", style="filled", color="lightblue", shape="box"
+ ];
+ { rank=same; A001; _009; }
+ _009 -> A001 [ arrowhead="tee" ];
+ _010 [ shape="record", label="Var sint32" ];
+ A001 -> _010:w [ arrowhead="tee" ];
+ A002 [ label="D", shape="oval" ];
+ _011 [ label="roots:&m", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _011; }
+ _011 -> A002 [ arrowhead="tee" ];
+ _012 [ shape="record", label="<_p1> Ref" ];
+ _012:_p1 -> A007:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A002 -> _012:w [ arrowhead="tee" ];
+ A003 [ label="D", shape="oval" ];
+ _013 [ label="roots:&v", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A003; _013; }
+ _013 -> A003 [ arrowhead="tee" ];
+ _014 [ shape="record", label="<_p1> Ref" ];
+ _014:_p1 -> A008:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A003 -> _014:w [ arrowhead="tee" ];
+ A004 [ label="D", shape="oval" ];
+ _015 [ label="roots:&r", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A004; _015; }
+ _015 -> A004 [ arrowhead="tee" ];
+ _016 [ shape="record", label="<_p1> Ref" ];
+ _016:_p1 -> A009:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A004 -> _016:w [ arrowhead="tee" ];
+ A005 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _017 [ shape="record", label="Var sint32" ];
+ A005 -> _017:w [ arrowhead="tee" ];
+ A006 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _018 [ shape="record", label="Var sint32" ];
+ A006 -> _018:w [ arrowhead="tee" ];
+ A007 [ label="D[]", shape="oval" ];
+ _019 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A007; _019; }
+ _019 -> A007 [ arrowhead="tee" ];
+ _020 [ shape="record", label="<_p1> Ref" ];
+ _020:_p1 -> A010:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A007 -> _020:w [ arrowhead="tee" ];
+ A008 [ label="R[]", shape="oval", fillcolor="green", style="filled" ];
+ _021 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A008; _021; }
+ _021 -> A008 [ arrowhead="tee" ];
+ _022 [ shape="record", label="Mem sint32" ];
+ A008 -> _022:w [ arrowhead="tee" ];
+ A009 [ label="RW[]", shape="oval", fillcolor="green", style="filled" ];
+ _023 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A009; _023; }
+ _023 -> A009 [ arrowhead="tee" ];
+ _024 [ shape="record", label="Mem sint32" ];
+ A009 -> _024:w [ arrowhead="tee" ];
+ A010 [ label="R[]", shape="oval", fillcolor="green", style="filled" ];
+ _025 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A010; _025; }
+ _025 -> A010 [ arrowhead="tee" ];
+ _026 [ shape="record", label="Mem sint32" ];
+ A010 -> _026:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/structarray1.res.oracle b/src/plugins/wp/tests/wp_region/oracle/structarray1.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..eac3247d2ca75c18f6bdb8de8851ca83750f7ac4
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/structarray1.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/structarray1.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/structarray1/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/structarray1/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/structarray1/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..c9b16ac8ffe732d0e3f0782dc984f4254a571ad3
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/structarray1/region/job.dot
@@ -0,0 +1,70 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="M", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="X", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="R", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="i", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="j", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ A000 [ label="D", shape="oval" ];
+ _005 [ label="roots:&M", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _005; }
+ _005 -> A000 [ arrowhead="tee" ];
+ _006 [ shape="record", label="<_p1> Ref" ];
+ _006:_p1 -> A005:w [ taillabel="*", labelangle="+30", color="red" ];
+ A000 -> _006:w [ arrowhead="tee" ];
+ A001 [ label="D", shape="oval" ];
+ _007 [ label="roots:&X", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _007; }
+ _007 -> A001 [ arrowhead="tee" ];
+ _008 [ shape="record", label="<_p1> Ref" ];
+ _008:_p1 -> A006:w [ taillabel="*", labelangle="+30", color="red" ];
+ A001 -> _008:w [ arrowhead="tee" ];
+ A002 [ label="D", shape="oval" ];
+ _009 [ label="roots:&R", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _009; }
+ _009 -> A002 [ arrowhead="tee" ];
+ _010 [ shape="record", label="<_p1> Ref" ];
+ _010:_p1 -> A006:w [ taillabel="*", labelangle="+30", color="red" ];
+ A002 -> _010:w [ arrowhead="tee" ];
+ A003 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _011 [ shape="record", label="Var sint32" ];
+ A003 -> _011:w [ arrowhead="tee" ];
+ A004 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _012 [ shape="record", label="Var sint32" ];
+ A004 -> _012:w [ arrowhead="tee" ];
+ A005 [ label="", shape="oval" ];
+ _013 [ label="roots:&M", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A005; _013; }
+ _013 -> A005 [ arrowhead="tee" ];
+ _014 [ shape="record", label="<_p1> 0..511: D32[4,4]" ];
+ _014:_p1 -> A007 [ style="dotted" ];
+ A005 -> _014:w [ arrowhead="tee" ];
+ A006 [ label="&", shape="oval", fillcolor="orange", style="filled" ];
+ _015 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A006; _015; }
+ _015 -> A006 [ arrowhead="tee" ];
+ _016 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _016:_p1 -> A008 [ style="dotted" ];
+ A006 -> _016:w [ arrowhead="tee" ];
+ A007 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _017 [ label="roots:&M+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A007; _017; }
+ _017 -> A007 [ arrowhead="tee" ];
+ _018 [ shape="record", label="Mem sint32" ];
+ A007 -> _018:w [ arrowhead="tee" ];
+ A008 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _019 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A008; _019; }
+ _019 -> A008 [ arrowhead="tee" ];
+ _020 [ shape="record", label="Mem sint32" ];
+ A008 -> _020:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/structarray2.res.oracle b/src/plugins/wp/tests/wp_region/oracle/structarray2.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..178fe6a89808245f88bbd916e648129d57347505
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/structarray2.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/structarray2.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/structarray2/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/structarray2/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/structarray2/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..c230c91fe3fba56ccab5ad31aeb5b20e6952036a
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/structarray2/region/job.dot
@@ -0,0 +1,97 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="M", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="X", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="R", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="i", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="j", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ V005 [ label="C", shape="cds", style="filled", fillcolor="yellow" ];
+ V005:e -> A005 ;
+ A000 [ label="D", shape="oval" ];
+ _006 [ label="roots:&M", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _006; }
+ _006 -> A000 [ arrowhead="tee" ];
+ _007 [ shape="record", label="<_p1> Ref" ];
+ _007:_p1 -> A006:w [ taillabel="*", labelangle="+30", color="red" ];
+ A000 -> _007:w [ arrowhead="tee" ];
+ A001 [ label="D", shape="oval" ];
+ _008 [ label="roots:&X", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _008; }
+ _008 -> A001 [ arrowhead="tee" ];
+ _009 [ shape="record", label="<_p1> Ref" ];
+ _009:_p1 -> A007:w [ taillabel="*", labelangle="+30", color="red" ];
+ A001 -> _009:w [ arrowhead="tee" ];
+ A002 [ label="D", shape="oval" ];
+ _010 [ label="roots:&R", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _010; }
+ _010 -> A002 [ arrowhead="tee" ];
+ _011 [ shape="record", label="<_p1> Ref" ];
+ _011:_p1 -> A008:w [ taillabel="*", labelangle="+30", color="red" ];
+ A002 -> _011:w [ arrowhead="tee" ];
+ A003 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _012 [ shape="record", label="Var sint32" ];
+ A003 -> _012:w [ arrowhead="tee" ];
+ A004 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ shape="record", label="Var sint32" ];
+ A004 -> _013:w [ arrowhead="tee" ];
+ A005 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _014 [ shape="record", label="<_p1> Var ptr" ];
+ _014:_p1 -> A009:w [ taillabel="*", labelangle="+30", color="red" ];
+ A005 -> _014:w [ arrowhead="tee" ];
+ A006 [ label="", shape="oval" ];
+ _015 [ label="roots:&M", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A006; _015; }
+ _015 -> A006 [ arrowhead="tee" ];
+ _016 [ shape="record", label="<_p1> 0..511: D32[4,4]" ];
+ _016:_p1 -> A010 [ style="dotted" ];
+ A006 -> _016:w [ arrowhead="tee" ];
+ A007 [ label="", shape="oval" ];
+ _017 [ label="roots:&X", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A007; _017; }
+ _017 -> A007 [ arrowhead="tee" ];
+ _018 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _018:_p1 -> A011 [ style="dotted" ];
+ A007 -> _018:w [ arrowhead="tee" ];
+ A008 [ label="", shape="oval" ];
+ _019 [ label="roots:&R", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A008; _019; }
+ _019 -> A008 [ arrowhead="tee" ];
+ _020 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _020:_p1 -> A012 [ style="dotted" ];
+ A008 -> _020:w [ arrowhead="tee" ];
+ A009 [ label="&", shape="oval", fillcolor="orange", style="filled" ];
+ _021 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _021:_p1 -> A010 [ style="dotted" ];
+ A009 -> _021:w [ arrowhead="tee" ];
+ A010 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _022 [ label="roots:&M+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A010; _022; }
+ _022 -> A010 [ arrowhead="tee" ];
+ _023 [ shape="record", label="Mem sint32" ];
+ A010 -> _023:w [ arrowhead="tee" ];
+ A011 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _024 [ label="roots:&X+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A011; _024; }
+ _024 -> A011 [ arrowhead="tee" ];
+ _025 [ shape="record", label="Mem sint32" ];
+ A011 -> _025:w [ arrowhead="tee" ];
+ A012 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _026 [ label="roots:&R+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A012; _026; }
+ _026 -> A012 [ arrowhead="tee" ];
+ _027 [ shape="record", label="Mem sint32" ];
+ A012 -> _027:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/structarray3.res.oracle b/src/plugins/wp/tests/wp_region/oracle/structarray3.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..1d4865e408e6511794022d8846142fd16724b46e
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/structarray3.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/structarray3.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/structarray3/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/structarray3/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/structarray3/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..8f7746c098f792497d8e861672c41824c426e180
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/structarray3/region/job.dot
@@ -0,0 +1,114 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="c", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="P", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="Q", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="X", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="R", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ V005 [ label="M", shape="cds", style="filled", fillcolor="yellow" ];
+ V005:e -> A005 ;
+ V006 [ label="tmp", shape="cds", style="filled", fillcolor="yellow" ];
+ V006:e -> A006 ;
+ V007 [ label="i", shape="cds", style="filled", fillcolor="yellow" ];
+ V007:e -> A007 ;
+ V008 [ label="j", shape="cds", style="filled", fillcolor="yellow" ];
+ V008:e -> A008 ;
+ A000 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _009 [ label="roots:&c", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _009; }
+ _009 -> A000 [ arrowhead="tee" ];
+ _010 [ shape="record", label="Var sint32" ];
+ A000 -> _010:w [ arrowhead="tee" ];
+ A001 [ label="D", shape="oval" ];
+ _011 [ label="roots:&P", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _011; }
+ _011 -> A001 [ arrowhead="tee" ];
+ _012 [ shape="record", label="<_p1> Ref" ];
+ _012:_p1 -> A009:w [ taillabel="*", labelangle="+30", color="red" ];
+ A001 -> _012:w [ arrowhead="tee" ];
+ A002 [ label="D", shape="oval" ];
+ _013 [ label="roots:&Q", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _013; }
+ _013 -> A002 [ arrowhead="tee" ];
+ _014 [ shape="record", label="<_p1> Ref" ];
+ _014:_p1 -> A009:w [ taillabel="*", labelangle="+30", color="red" ];
+ A002 -> _014:w [ arrowhead="tee" ];
+ A003 [ label="D", shape="oval" ];
+ _015 [ label="roots:&X", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A003; _015; }
+ _015 -> A003 [ arrowhead="tee" ];
+ _016 [ shape="record", label="<_p1> Ref" ];
+ _016:_p1 -> A010:w [ taillabel="*", labelangle="+30", color="red" ];
+ A003 -> _016:w [ arrowhead="tee" ];
+ A004 [ label="D", shape="oval" ];
+ _017 [ label="roots:&R", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A004; _017; }
+ _017 -> A004 [ arrowhead="tee" ];
+ _018 [ shape="record", label="<_p1> Ref" ];
+ _018:_p1 -> A011:w [ taillabel="*", labelangle="+30", color="red" ];
+ A004 -> _018:w [ arrowhead="tee" ];
+ A005 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _019 [ shape="record", label="<_p1> Var ptr" ];
+ _019:_p1 -> A009:w [ taillabel="*", labelangle="+30", color="red" ];
+ A005 -> _019:w [ arrowhead="tee" ];
+ A006 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _020 [ shape="record", label="<_p1> Var ptr" ];
+ _020:_p1 -> A009:w [ taillabel="*", labelangle="+30", color="red" ];
+ A006 -> _020:w [ arrowhead="tee" ];
+ A007 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _021 [ shape="record", label="Var sint32" ];
+ A007 -> _021:w [ arrowhead="tee" ];
+ A008 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _022 [ shape="record", label="Var sint32" ];
+ A008 -> _022:w [ arrowhead="tee" ];
+ A009 [ label="&", shape="oval", fillcolor="orange", style="filled" ];
+ _023 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A009; _023; }
+ _023 -> A009 [ arrowhead="tee" ];
+ _024 [ shape="record", label="<_p1> 0..511: D32[4,4]" ];
+ _024:_p1 -> A012 [ style="dotted" ];
+ A009 -> _024:w [ arrowhead="tee" ];
+ A010 [ label="", shape="oval" ];
+ _025 [ label="roots:&X", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A010; _025; }
+ _025 -> A010 [ arrowhead="tee" ];
+ _026 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _026:_p1 -> A013 [ style="dotted" ];
+ A010 -> _026:w [ arrowhead="tee" ];
+ A011 [ label="", shape="oval" ];
+ _027 [ label="roots:&R", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A011; _027; }
+ _027 -> A011 [ arrowhead="tee" ];
+ _028 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _028:_p1 -> A014 [ style="dotted" ];
+ A011 -> _028:w [ arrowhead="tee" ];
+ A012 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _029 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A012; _029; }
+ _029 -> A012 [ arrowhead="tee" ];
+ _030 [ shape="record", label="Mem sint32" ];
+ A012 -> _030:w [ arrowhead="tee" ];
+ A013 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _031 [ label="roots:&X+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A013; _031; }
+ _031 -> A013 [ arrowhead="tee" ];
+ _032 [ shape="record", label="Mem sint32" ];
+ A013 -> _032:w [ arrowhead="tee" ];
+ A014 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _033 [ label="roots:&R+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A014; _033; }
+ _033 -> A014 [ arrowhead="tee" ];
+ _034 [ shape="record", label="Mem sint32" ];
+ A014 -> _034:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/structarray4.res.oracle b/src/plugins/wp/tests/wp_region/oracle/structarray4.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..2bc45be7e59d5d04cc65b58b30e9b86dea76af19
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/structarray4.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/structarray4.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/structarray4/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/structarray4/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/structarray4/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..7e75e99526513c32b32f184aa7c173118bac28b1
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/structarray4/region/job.dot
@@ -0,0 +1,110 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="M", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="X", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="R", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ V003 [ label="p", shape="cds", style="filled", fillcolor="yellow" ];
+ V003:e -> A003 ;
+ V004 [ label="i", shape="cds", style="filled", fillcolor="yellow" ];
+ V004:e -> A004 ;
+ V005 [ label="j", shape="cds", style="filled", fillcolor="yellow" ];
+ V005:e -> A005 ;
+ V006 [ label="C", shape="cds", style="filled", fillcolor="yellow" ];
+ V006:e -> A006 ;
+ A000 [ label="D", shape="oval" ];
+ _007 [ label="roots:&M", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _007; }
+ _007 -> A000 [ arrowhead="tee" ];
+ _008 [ shape="record", label="<_p1> Ref" ];
+ _008:_p1 -> A007:w [ taillabel="*", labelangle="+30", color="red" ];
+ A000 -> _008:w [ arrowhead="tee" ];
+ A001 [ label="D", shape="oval" ];
+ _009 [ label="roots:&X", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _009; }
+ _009 -> A001 [ arrowhead="tee" ];
+ _010 [ shape="record", label="<_p1> Ref" ];
+ _010:_p1 -> A008:w [ taillabel="*", labelangle="+30", color="red" ];
+ A001 -> _010:w [ arrowhead="tee" ];
+ A002 [ label="D", shape="oval" ];
+ _011 [ label="roots:&R", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A002; _011; }
+ _011 -> A002 [ arrowhead="tee" ];
+ _012 [ shape="record", label="<_p1> Ref" ];
+ _012:_p1 -> A009:w [ taillabel="*", labelangle="+30", color="red" ];
+ A002 -> _012:w [ arrowhead="tee" ];
+ A003 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _013 [ shape="record", label="<_p1> Var ptr" ];
+ _013:_p1 -> A010:w [ taillabel="[..]", labeldistance="1.7",
+ labelangle="+40", color="red"
+ ];
+ A003 -> _013:w [ arrowhead="tee" ];
+ A004 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _014 [ shape="record", label="Var sint32" ];
+ A004 -> _014:w [ arrowhead="tee" ];
+ A005 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _015 [ shape="record", label="Var sint32" ];
+ A005 -> _015:w [ arrowhead="tee" ];
+ A006 [ label="DW", shape="oval", fillcolor="green", style="filled" ];
+ _016 [ shape="record", label="<_p1> Var ptr" ];
+ _016:_p1 -> A011:w [ taillabel="*", labelangle="+30", color="red" ];
+ A006 -> _016:w [ arrowhead="tee" ];
+ A007 [ label="", shape="oval" ];
+ _017 [ label="roots:&M", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A007; _017; }
+ _017 -> A007 [ arrowhead="tee" ];
+ _018 [ shape="record", label="<_p1> 0..511: D32[16]" ];
+ _018:_p1 -> A012 [ style="dotted" ];
+ A007 -> _018:w [ arrowhead="tee" ];
+ A008 [ label="", shape="oval" ];
+ _019 [ label="roots:&X", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A008; _019; }
+ _019 -> A008 [ arrowhead="tee" ];
+ _020 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _020:_p1 -> A013 [ style="dotted" ];
+ A008 -> _020:w [ arrowhead="tee" ];
+ A009 [ label="", shape="oval" ];
+ _021 [ label="roots:&R", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A009; _021; }
+ _021 -> A009 [ arrowhead="tee" ];
+ _022 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _022:_p1 -> A014 [ style="dotted" ];
+ A009 -> _022:w [ arrowhead="tee" ];
+ A010 [ label="[]&", shape="oval", fillcolor="orange", style="filled" ];
+ _023 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A010; _023; }
+ _023 -> A010 [ arrowhead="tee" ];
+ _024 [ shape="record", label="<_p1> 0..511: D32[16]" ];
+ _024:_p1 -> A012 [ style="dotted" ];
+ A010 -> _024:w [ arrowhead="tee" ];
+ A011 [ label="&", shape="oval", fillcolor="orange", style="filled" ];
+ _025 [ shape="record", label="<_p1> 0..127: D32[4]" ];
+ _025:_p1 -> A012 [ style="dotted" ];
+ A011 -> _025:w [ arrowhead="tee" ];
+ A012 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _026 [ label="roots:*", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A012; _026; }
+ _026 -> A012 [ arrowhead="tee" ];
+ _027 [ shape="record", label="Mem sint32" ];
+ A012 -> _027:w [ arrowhead="tee" ];
+ A013 [ label="R", shape="oval", fillcolor="green", style="filled" ];
+ _028 [ label="roots:&X+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A013; _028; }
+ _028 -> A013 [ arrowhead="tee" ];
+ _029 [ shape="record", label="Mem sint32" ];
+ A013 -> _029:w [ arrowhead="tee" ];
+ A014 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _030 [ label="roots:&R+(..)", style="filled", color="lightblue",
+ shape="box"
+ ];
+ { rank=same; A014; _030; }
+ _030 -> A014 [ arrowhead="tee" ];
+ _031 [ shape="record", label="Mem sint32" ];
+ A014 -> _031:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle/swap.res.oracle b/src/plugins/wp/tests/wp_region/oracle/swap.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..d7076d6dbc8cb0e241490c9707bd7bc5470ba1e7
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/swap.res.oracle
@@ -0,0 +1,4 @@
+[kernel] Parsing tests/wp_region/swap.i (no preprocessing)
+[wp] Region Graph: tests/wp_region/result/swap/region/job.dot
+[wp] Running WP plugin...
+[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/tests/wp_region/oracle/swap/region/job.dot b/src/plugins/wp/tests/wp_region/oracle/swap/region/job.dot
new file mode 100644
index 0000000000000000000000000000000000000000..f4e8e067375c647f46f431296f159c8600f387aa
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle/swap/region/job.dot
@@ -0,0 +1,40 @@
+digraph "job" {
+ rankdir="LR" ;
+ node [ fontname="monospace" ];
+ edge [ fontname="monospace" ];
+ V000 [ label="x", shape="cds", style="filled", fillcolor="yellow" ];
+ V000:e -> A000 ;
+ V001 [ label="y", shape="cds", style="filled", fillcolor="yellow" ];
+ V001:e -> A001 ;
+ V002 [ label="t", shape="cds", style="filled", fillcolor="yellow" ];
+ V002:e -> A002 ;
+ A000 [ label="D", shape="oval" ];
+ _003 [ label="roots:&x", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A000; _003; }
+ _003 -> A000 [ arrowhead="tee" ];
+ _004 [ shape="record", label="<_p1> Ref" ];
+ _004:_p1 -> A003:w [ taillabel="*", labelangle="+30", color="red" ];
+ A000 -> _004:w [ arrowhead="tee" ];
+ A001 [ label="D", shape="oval" ];
+ _005 [ label="roots:&y", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A001; _005; }
+ _005 -> A001 [ arrowhead="tee" ];
+ _006 [ shape="record", label="<_p1> Ref" ];
+ _006:_p1 -> A004:w [ taillabel="*", labelangle="+30", color="red" ];
+ A001 -> _006:w [ arrowhead="tee" ];
+ A002 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _007 [ shape="record", label="Var sint32" ];
+ A002 -> _007:w [ arrowhead="tee" ];
+ A003 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _008 [ label="roots:&x", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A003; _008; }
+ _008 -> A003 [ arrowhead="tee" ];
+ _009 [ shape="record", label="Var sint32" ];
+ A003 -> _009:w [ arrowhead="tee" ];
+ A004 [ label="RW", shape="oval", fillcolor="green", style="filled" ];
+ _010 [ label="roots:&y", style="filled", color="lightblue", shape="box" ];
+ { rank=same; A004; _010; }
+ _010 -> A004 [ arrowhead="tee" ];
+ _011 [ shape="record", label="Var sint32" ];
+ A004 -> _011:w [ arrowhead="tee" ];
+}
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/array1.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/array1.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..1104fba8da15783a9af200a808ac6497ae76452b
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/array1.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/array1.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/array1.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/array1.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/array2.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/array2.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..abd77f2e04f52c9431005eba9996abb777f85bee
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/array2.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/array2.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/array2.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/array2.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/array3.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/array3.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..ae12b744a10ff18184e3687712a0364d896970b2
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/array3.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/array3.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/array3.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/array3.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/array4.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/array4.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..27b0fb5624bac6cc7269f18a84f1a3348a7383b6
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/array4.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/array4.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/array4.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/array4.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/array5.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/array5.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..74acbbde6f5560d61df4c43cc7baba4d0e116147
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/array5.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/array5.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/array5.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/array5.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/array6.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/array6.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..5732e647753b6122c337e4a827b660523bc86dac
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/array6.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/array6.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/array6.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/array6.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/array7.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/array7.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..ad26b6b026cda98aa9b737e6ef3cd7611e03425f
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/array7.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/array7.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/array7.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/array7.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/array8.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/array8.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..5c2c5ca7afbd0de1ce75a2dfd14c3c58439f80ad
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/array8.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/array8.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/array8.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/array8.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/fb_ADD.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/fb_ADD.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..33eaf9d7ddab649bf56632e7581860c0c56b8199
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/fb_ADD.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/fb_ADD.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/fb_ADD.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/fb_ADD.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/fb_SORT.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/fb_SORT.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..e0be524f223e42cf1d1eb2c30e56c4b1a4a4d8f7
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/fb_SORT.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/fb_SORT.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/fb_SORT.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/fb_SORT.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/garbled.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/garbled.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..8dd7d80af3d6ea1ea51b43be8c649d5ec4eb59e1
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/garbled.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/garbled.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/garbled.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/garbled.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/index.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/index.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..af97d99c26e36511609936a5f386c9c3db1d3bfd
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/index.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/index.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/index.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/index.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/matrix.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/matrix.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..ad21316f06b9e791d9f2f671e735f3e75d393aeb
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/matrix.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/matrix.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/matrix.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/matrix.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/structarray1.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/structarray1.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..8819e244467624ca0fb1b763841345d163a19e20
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/structarray1.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/structarray1.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/structarray1.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/structarray1.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/structarray2.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/structarray2.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..c416a3c4c89a8995e8cb82833a82132378d8bdcc
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/structarray2.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/structarray2.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/structarray2.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/structarray2.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/structarray3.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/structarray3.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..12107fb88f51cc2db43a3ce9a9deab0d5674a3da
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/structarray3.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/structarray3.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/structarray3.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/structarray3.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/structarray4.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/structarray4.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..4297af9bc0454c0ce34a3fce366f8ba47df91a34
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/structarray4.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/structarray4.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/structarray4.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/structarray4.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/oracle_qualif/swap.res.oracle b/src/plugins/wp/tests/wp_region/oracle_qualif/swap.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..3d6f5d28f72214571ee58af943d1a7d6f2fbe3c6
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/oracle_qualif/swap.res.oracle
@@ -0,0 +1,10 @@
+# frama-c -wp [...]
+[kernel] Parsing tests/wp_region/swap.i (no preprocessing)
+[wp] Running WP plugin...
+[wp] Loading driver 'share/wp.driver'
+[wp] Warning: Missing RTE guards
+[wp] 0 goal scheduled
+[wp] Proved goals: 0 / 0
+[wp] Report in: 'tests/wp_region/oracle_qualif/swap.0.report.json'
+[wp] Report out: 'tests/wp_region/result_qualif/swap.0.report.json'
+-------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_region/structarray1.i b/src/plugins/wp/tests/wp_region/structarray1.i
new file mode 100644
index 0000000000000000000000000000000000000000..d657867ad894507712c52647e6d164a7391f2683
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/structarray1.i
@@ -0,0 +1,18 @@
+typedef struct Vector {
+ int coord[4];
+} * vector ;
+
+typedef struct Matrix {
+ int coef[4][4];
+} * matrix ;
+
+//@ region *X , *R ;
+void job( matrix M , vector X , vector R )
+{
+ for (int i = 0; i < 4; i++) {
+ R->coord[i] = 0 ;
+ for (int j = 0; j < 4; i++) {
+ R->coord[i] += M->coef[i][j] * X->coord[j];
+ }
+ }
+}
diff --git a/src/plugins/wp/tests/wp_region/structarray1.i.0.report.json b/src/plugins/wp/tests/wp_region/structarray1.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/structarray1.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/structarray2.i b/src/plugins/wp/tests/wp_region/structarray2.i
new file mode 100644
index 0000000000000000000000000000000000000000..472077d231c95dd046d466e3f7871abe3e46ad43
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/structarray2.i
@@ -0,0 +1,18 @@
+typedef struct Vector {
+ int coord[4];
+} * vector ;
+
+typedef struct Matrix {
+ int coef[4][4];
+} * matrix ;
+
+void job( matrix M , vector X , vector R )
+{
+ for (int i = 0; i < 4; i++) {
+ R->coord[i] = 0 ;
+ for (int j = 0; j < 4; i++) {
+ vector C = (vector) (M->coef[i]) ;
+ R->coord[i] += C->coord[j] * X->coord[j];
+ }
+ }
+}
diff --git a/src/plugins/wp/tests/wp_region/structarray2.i.0.report.json b/src/plugins/wp/tests/wp_region/structarray2.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/structarray2.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/structarray3.i b/src/plugins/wp/tests/wp_region/structarray3.i
new file mode 100644
index 0000000000000000000000000000000000000000..fc05e0a87a77b692fcd6a4106ffcf7532a7dd039
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/structarray3.i
@@ -0,0 +1,18 @@
+typedef struct Vector {
+ int coord[4];
+} * vector ;
+
+typedef struct Matrix {
+ int coef[4][4];
+} * matrix ;
+
+void job( int c , matrix P , matrix Q , vector X , vector R )
+{
+ matrix M = c ? P : Q ;
+ for (int i = 0; i < 4; i++) {
+ R->coord[i] = 0 ;
+ for (int j = 0; j < 4; i++) {
+ R->coord[i] += M->coef[i][j] * X->coord[j];
+ }
+ }
+}
diff --git a/src/plugins/wp/tests/wp_region/structarray3.i.0.report.json b/src/plugins/wp/tests/wp_region/structarray3.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/structarray3.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/structarray4.i b/src/plugins/wp/tests/wp_region/structarray4.i
new file mode 100644
index 0000000000000000000000000000000000000000..c27ac7ed8f7fa1ea3ea5a52a0c1e87b0a23a1bd9
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/structarray4.i
@@ -0,0 +1,20 @@
+typedef struct Vector {
+ int coord[4];
+} * vector ;
+
+typedef struct Matrix {
+ int coef[4][4];
+} * matrix ;
+
+void job( matrix M , vector X , vector R )
+{
+ int * p = (int *) M->coef ;
+ p[14] = 2 ;
+ for (int i = 0; i < 4; i++) {
+ R->coord[i] = 0 ;
+ for (int j = 0; j < 4; i++) {
+ vector C = (vector) (M->coef[i]) ;
+ R->coord[i] += C->coord[j] * X->coord[j];
+ }
+ }
+}
diff --git a/src/plugins/wp/tests/wp_region/structarray4.i.0.report.json b/src/plugins/wp/tests/wp_region/structarray4.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/structarray4.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/swap.i b/src/plugins/wp/tests/wp_region/swap.i
new file mode 100644
index 0000000000000000000000000000000000000000..f299d9687047b1df56a724cb770bc950972274f0
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/swap.i
@@ -0,0 +1,8 @@
+// Test Config
+
+void job(int *x,int *y)
+{
+ int t = *x ;
+ *x = *y ;
+ *y = t ;
+}
diff --git a/src/plugins/wp/tests/wp_region/swap.i.0.report.json b/src/plugins/wp/tests/wp_region/swap.i.0.report.json
new file mode 100644
index 0000000000000000000000000000000000000000..19765bd501b636fce433540d9e6735f51d66151d
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/swap.i.0.report.json
@@ -0,0 +1 @@
+null
diff --git a/src/plugins/wp/tests/wp_region/test_config b/src/plugins/wp/tests/wp_region/test_config
new file mode 100644
index 0000000000000000000000000000000000000000..36003c91eeff9b752b08515c756f5e0268465e56
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/test_config
@@ -0,0 +1,3 @@
+CMD: @frama-c@ -no-autoload-plugins -load-module wp
+LOG: @PTEST_NAME@/region/job.dot
+OPT: -wp-prover none -wp-region -wp-msg-key dot,chunk,roots,garbled -wp-out @PTEST_DIR@/result/@PTEST_NAME@ -wp-fct job
diff --git a/src/plugins/wp/tests/wp_region/test_config_qualif b/src/plugins/wp/tests/wp_region/test_config_qualif
new file mode 100644
index 0000000000000000000000000000000000000000..a6cc52bc1de6ecd3ad796948a36e74a1c67f1fd9
--- /dev/null
+++ b/src/plugins/wp/tests/wp_region/test_config_qualif
@@ -0,0 +1 @@
+OPT: -wp-region
diff --git a/src/plugins/wp/tests/wp_store/oracle_qualif/struct.0.session/cache/4f3f819897e17d244836052e8e391eeb.json b/src/plugins/wp/tests/wp_store/oracle_qualif/struct.0.session/cache/0397215be1cc2dddcdf43bf1afd9ffe4.json
similarity index 91%
rename from src/plugins/wp/tests/wp_store/oracle_qualif/struct.0.session/cache/4f3f819897e17d244836052e8e391eeb.json
rename to src/plugins/wp/tests/wp_store/oracle_qualif/struct.0.session/cache/0397215be1cc2dddcdf43bf1afd9ffe4.json
index bd18f2d694e48d3b4a4118ffec9d15fadad58200..37a7317f01bf64583e8f6b99bd73f938e4face03 100644
--- a/src/plugins/wp/tests/wp_store/oracle_qualif/struct.0.session/cache/4f3f819897e17d244836052e8e391eeb.json
+++ b/src/plugins/wp/tests/wp_store/oracle_qualif/struct.0.session/cache/0397215be1cc2dddcdf43bf1afd9ffe4.json
@@ -1,2 +1,2 @@
-{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0297,
+{ "prover": "why3:Alt-Ergo,2.0.0", "verdict": "valid", "time": 0.0284,
"steps": 36 }
diff --git a/src/plugins/wp/tests/wp_usage/oracle/code_spec.res.oracle b/src/plugins/wp/tests/wp_usage/oracle/code_spec.res.oracle
index e4ad3f5e78b698aeef68ea6f228af4669314c44f..a812acef1d1948e7e3a67f01b09fdb1b9b3dd2a8 100644
--- a/src/plugins/wp/tests/wp_usage/oracle/code_spec.res.oracle
+++ b/src/plugins/wp/tests/wp_usage/oracle/code_spec.res.oracle
@@ -37,7 +37,7 @@ Function calling_spec:
val_val3 val_ref1 *ref_ref2 array_ref3[] v1 v2 v3 v4 val_array1
array_array2[] array_array3[] }
Function cup:
-{ val *ref &addr array[] &addr_value val_ref array_ref[] value_array[] }
+{ val *ref &addr array[] &addr_value val_ref array_ref[] value_array }
.................................................
[wp] Loading driver 'share/wp.driver'
[wp] [CFG] Goal by_addr_in_code_annotation_requires : Valid (Unreachable)
diff --git a/src/plugins/wp/tests/wp_usage/oracle/issue-189.1.res.oracle b/src/plugins/wp/tests/wp_usage/oracle/issue-189.1.res.oracle
index 5bdfc47271787ced685a23eefa161f3dc81500d6..5e33a1a8de186123c1dcd3b9c71a72a600263d41 100644
--- a/src/plugins/wp/tests/wp_usage/oracle/issue-189.1.res.oracle
+++ b/src/plugins/wp/tests/wp_usage/oracle/issue-189.1.res.oracle
@@ -5,11 +5,10 @@
... Ref Usage
.................................................
Init: { }
-Function f: { *ptr src[] idx }
+Function f: { *ptr src idx }
.................................................
[wp] Loading driver 'share/wp.driver'
[wp] Warning: Missing RTE guards
-[wp] tests/wp_usage/issue-189.i:18: Warning: Undefined array-size (sint8[])
[wp] tests/wp_usage/issue-189.i:17: Warning:
forbidden write to variable 'src' considered in an isolated context.
Use model 'Typed' instead or specify '-wp-unalias-vars src'
diff --git a/src/plugins/wp/tests/wp_usage/oracle/issue-189.2.res.oracle b/src/plugins/wp/tests/wp_usage/oracle/issue-189.2.res.oracle
index efc2cf67736b76fa07d7b1f35e183e277d22b900..ec41c7f550d2d54273da0404d0e7bc613adf0a0d 100644
--- a/src/plugins/wp/tests/wp_usage/oracle/issue-189.2.res.oracle
+++ b/src/plugins/wp/tests/wp_usage/oracle/issue-189.2.res.oracle
@@ -5,7 +5,7 @@
... Ref Usage
.................................................
Init: { }
-Function f: { *ptr src[] idx }
+Function f: { *ptr src idx }
.................................................
[wp] Loading driver 'share/wp.driver'
[wp] Warning: Missing RTE guards
diff --git a/src/plugins/wp/wpPropId.ml b/src/plugins/wp/wpPropId.ml
index ee456686522018f540bd0c8641fa71e1720e1d63..4a154c087a2c207237585752f955d3d57dd00842 100644
--- a/src/plugins/wp/wpPropId.ml
+++ b/src/plugins/wp/wpPropId.ml
@@ -567,7 +567,7 @@ let stmt_hints hs s =
match label with
| Label(a,_,src) -> if src then add_hint hs a
| Default _ -> add_hint hs "default"
- | Case(e,_) -> match Ctypes.get_int e with
+ | Case(e,_) -> match Ctypes.get_int64 e with
| Some k -> add_hint hs ("case-" ^ Int64.to_string k)
| None -> ()
) s.labels
diff --git a/src/plugins/wp/wpStrategy.ml b/src/plugins/wp/wpStrategy.ml
index 250b33fb3df18a539a465aed423a2473ceb190c1..f87b744a61755072dfc906ed4e3e2cd282fb4c1e 100644
--- a/src/plugins/wp/wpStrategy.ml
+++ b/src/plugins/wp/wpStrategy.ml
@@ -35,12 +35,12 @@ type annot_kind =
but not an hypothesis (see Aboth): A /\ ...*)
| Aboth of bool
(* annotation can be used as both hypothesis and goal :
- - with true : considered as both : A /\ A=>..
- - with false : we just want to use it as hyp right now. *)
+ - with true : considered as both : A /\ A=>..
+ - with false : we just want to use it as hyp right now. *)
| AcutB of bool
(* annotation is use as a cut :
- - with true (A is also a goal) -> A (+ proof obligation A => ...)
- - with false (A is an hyp only) -> True (+ proof obligation A => ...) *)
+ - with true (A is also a goal) -> A (+ proof obligation A => ...)
+ - with false (A is an hyp only) -> True (+ proof obligation A => ...) *)
| AcallHyp of kernel_function
(* annotation is a called function property to consider as an Hyp.
* The pre are not here but in AcallPre since they can also
diff --git a/src/plugins/wp/wp_parameters.ml b/src/plugins/wp/wp_parameters.ml
index 008dde9e07fd880217e16b011afd64fa3581ce3c..7a867069661811e172c4368b74c8207599948166 100644
--- a/src/plugins/wp/wp_parameters.ml
+++ b/src/plugins/wp/wp_parameters.ml
@@ -20,8 +20,8 @@
(* *)
(**************************************************************************)
-module Fc_config = Config
-module STRING = String
+module Fc_Config = Config
+
let () = Plugin.is_share_visible ()
let () = Plugin.is_session_visible ()
include Plugin.Register
@@ -105,23 +105,6 @@ module Properties =
end)
let () = on_reset Properties.clear
-type job =
- | WP_None
- | WP_All
- | WP_SkipFct of Cil_datatype.Kf.Set.t
- | WP_Fct of Cil_datatype.Kf.Set.t
-
-let job () =
- if WP.get () || not (Functions.is_empty()) ||
- not (Behaviors.is_empty()) || not (Properties.is_empty())
- then
- if Functions.is_empty() then
- if SkipFunctions.is_empty () then WP_All
- else WP_SkipFct (SkipFunctions.get())
- else
- WP_Fct (Cil_datatype.Kf.Set.diff (Functions.get()) (SkipFunctions.get()))
- else WP_None
-
let () = Parameter_customize.set_group wp_generation
module StatusAll =
False(struct
@@ -150,6 +133,42 @@ module StatusMaybe =
let help = "Select properties with status 'Maybe'."
end)
+(* ------------------------------------------------------------------------ *)
+(* --- Selected Functions --- *)
+(* ------------------------------------------------------------------------ *)
+
+module Fct = Cil_datatype.Kf.Set
+
+type functions =
+ | Fct_none
+ | Fct_all
+ | Fct_skip of Fct.t
+ | Fct_list of Fct.t
+
+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)
+ | Fct_list fs -> Fct.iter phi fs
+
+let get_kf () =
+ if Functions.is_empty() then
+ if SkipFunctions.is_empty () then Fct_all
+ else Fct_skip (SkipFunctions.get())
+ else
+ Fct_list (Fct.diff (Functions.get()) (SkipFunctions.get()))
+
+let get_wp () =
+ if WP.get () || not (Functions.is_empty()) ||
+ not (Behaviors.is_empty()) || not (Properties.is_empty())
+ then get_kf ()
+ else Fct_none
+
+let iter_wp f = iter_fct f (get_wp ())
+let iter_kf f = iter_fct f (get_kf ())
+
(* ------------------------------------------------------------------------ *)
(* --- Memory Models --- *)
(* ------------------------------------------------------------------------ *)
@@ -246,6 +265,83 @@ module Volatile =
Use -wp-no-volatile to ignore volatile attributes."
end)
+(* -------------------------------------------------------------------------- *)
+(* --- Region Model --- *)
+(* -------------------------------------------------------------------------- *)
+
+let wp_region = add_group "Region Analysis"
+
+let () = Parameter_customize.set_group wp_region
+let () = Parameter_customize.do_not_save ()
+module Region =
+ False
+ (struct
+ let option_name = "-wp-region"
+ let help = "Perform Region Analysis (experimental)"
+ end)
+
+let () = Parameter_customize.set_group wp_region
+let () = Parameter_customize.do_not_save ()
+module Region_fixpoint =
+ True
+ (struct
+ let option_name = "-wp-region-fixpoint"
+ let help = "Compute region aliasing fixpoint"
+ end)
+
+let () = Parameter_customize.set_group wp_region
+let () = Parameter_customize.do_not_save ()
+module Region_cluster =
+ True
+ (struct
+ let option_name = "-wp-region-cluster"
+ let help = "Compute region clustering fixpoint"
+ end)
+
+let () = Parameter_customize.set_group wp_region
+let () = Parameter_customize.do_not_save ()
+module Region_inline =
+ True
+ (struct
+ let option_name = "-wp-region-inline"
+ let help = "Inline aliased sub-clusters"
+ end)
+
+let () = Parameter_customize.set_group wp_region
+let () = Parameter_customize.do_not_save ()
+module Region_rw =
+ True
+ (struct
+ let option_name = "-wp-region-rw"
+ let help = "Written region are considered read-write by default"
+ end)
+
+let () = Parameter_customize.set_group wp_region
+let () = Parameter_customize.do_not_save ()
+module Region_pack =
+ True
+ (struct
+ let option_name = "-wp-region-pack"
+ let help = "Pack clusters by default"
+ end)
+
+let () = Parameter_customize.set_group wp_region
+let () = Parameter_customize.do_not_save ()
+module Region_flat =
+ False
+ (struct
+ let option_name = "-wp-region-flat"
+ let help = "Flatten arrays by default"
+ end)
+
+let () = Parameter_customize.set_group wp_region
+module Region_annot =
+ False
+ (struct
+ let option_name = "-region-annot"
+ let help = "Register '@region' ACSL Annotations (auto with -wp-region)"
+ end)
+
(* ------------------------------------------------------------------------ *)
(* --- WP Strategy --- *)
(* ------------------------------------------------------------------------ *)
@@ -717,15 +813,6 @@ module Hints =
let help = "Maximum number of proposed Coq scripts (default 3)"
end)
-let () = Parameter_customize.set_group wp_prover_options
-module Includes =
- String_list
- (struct
- let option_name = "-wp-include"
- let arg_name = "dir,...,++sharedir"
- let help = "Directory where to find libraries and drivers for provers"
- end)
-
let () = Parameter_customize.set_group wp_prover_options
module CoqLibs =
String_list
@@ -735,30 +822,12 @@ module CoqLibs =
let help = "Additional libraries for Coq"
end)
-let () = Parameter_customize.set_group wp_prover_options
-module Why3 =
- String(struct
- let option_name = "-wp-why3"
- let default = "why3"
- let arg_name = "cmd"
- let help = "Command to run Why-3 (default: 'why3')"
- end)
-
-let () = Parameter_customize.set_group wp_prover_options
-module WhyLibs =
- String_list
- (struct
- let option_name = "-wp-why-lib"
- let arg_name = "*.why"
- let help = "Additional libraries for Why"
- end)
-
let () = Parameter_customize.set_group wp_prover_options
let () = Parameter_customize.no_category ()
-module WhyFlags =
+module Why3Flags =
String_list
(struct
- let option_name = "-wp-why-opt"
+ let option_name = "-wp-why3-opt"
let arg_name = "option,..."
let help = "Additional options for Why3"
end)
@@ -894,7 +963,7 @@ module Check =
let () = on_reset Print.clear
(* -------------------------------------------------------------------------- *)
-(* --- OS environment variables --- *)
+(* --- Overflows --- *)
(* -------------------------------------------------------------------------- *)
let active_unless_rte option =
@@ -906,24 +975,13 @@ let active_unless_rte option =
let get_overflows () = Overflows.get () && active_unless_rte "-wp-overflows"
-let dkey = register_category "env"
-
-let get_env ?default var =
- try
- let varval = Sys.getenv var in
- debug ~dkey "ENV %s=%S" var varval ; varval
- with Not_found ->
- debug ~dkey "ENV %s not set." var ;
- match default with
- | Some varval ->
- debug ~dkey "ENV %s default(%S)" var varval ; varval
- | None ->
- debug ~dkey "ENV %s undefined." var ;
- raise Not_found
+(* -------------------------------------------------------------------------- *)
+(* --- Output Dir --- *)
+(* -------------------------------------------------------------------------- *)
let dkey = register_category "prover"
-let is_out () = !Fc_config.is_gui || OutputDir.get() <> ""
+let has_out () = OutputDir.get () <> ""
let make_output_dir dir =
if Sys.file_exists dir then
@@ -978,7 +1036,7 @@ let base_output () =
| None -> let output =
match OutputDir.get () with
| "" ->
- if !Fc_config.is_gui
+ if !Fc_Config.is_gui
then make_gui_dir ()
else make_tmp_dir ()
| dir ->
@@ -988,13 +1046,6 @@ let base_output () =
output
| Some output -> output
-let get_session () = Session.dir ~error:false ()
-
-let get_session_dir d =
- let base = get_session () in
- let path = Printf.sprintf "%s/%s" base d in
- make_output_dir path ; path
-
let get_output () =
let base = base_output () in
let project = Project.current () in
@@ -1009,15 +1060,22 @@ let get_output_dir d =
let path = Printf.sprintf "%s/%s" base d in
make_output_dir path ; path
-let get_includes () =
- List.map
- (fun d ->
- if STRING.get d 0 = '+' then
- Printf.sprintf "%s/%s"
- (Kernel.Share.dir ())
- (STRING.sub d 1 (STRING.length d - 1))
- else d)
- (Includes.get ())
+(* -------------------------------------------------------------------------- *)
+(* --- Session dir --- *)
+(* -------------------------------------------------------------------------- *)
+
+let default = Sys.getcwd () ^ "/.frama-c"
+
+let has_session () =
+ Session.Dir_name.is_set () ||
+ ( Sys.file_exists default && Sys.is_directory default )
+
+let get_session () = Session.dir ~error:false ()
+
+let get_session_dir d =
+ let base = get_session () in
+ let path = Printf.sprintf "%s/%s" base d in
+ make_output_dir path ; path
let cat_print_generated = register_category "print-generated"
diff --git a/src/plugins/wp/wp_parameters.mli b/src/plugins/wp/wp_parameters.mli
index 43db4176f892546d7a789889da12388e74c96846..825c4377f8f0e867338c8c29c19ae3436dc2282b 100644
--- a/src/plugins/wp/wp_parameters.mli
+++ b/src/plugins/wp/wp_parameters.mli
@@ -24,6 +24,20 @@ include Plugin.S
val reset : unit -> unit
+(** {2 Function Selection} *)
+
+type functions =
+ | Fct_none
+ | Fct_all
+ | Fct_skip of Cil_datatype.Kf.Set.t
+ | Fct_list of Cil_datatype.Kf.Set.t
+
+val get_kf : unit -> functions
+val get_wp : unit -> functions
+val iter_fct : (Kernel_function.t -> unit) -> functions -> unit
+val iter_kf : (Kernel_function.t -> unit) -> unit
+val iter_wp : (Kernel_function.t -> unit) -> unit
+
(** {2 Goal Selection} *)
module WP : Parameter_sig.Bool
@@ -34,14 +48,6 @@ module StatusTrue : Parameter_sig.Bool
module StatusFalse : Parameter_sig.Bool
module StatusMaybe : Parameter_sig.Bool
-type job =
- | WP_None
- | WP_All
- | WP_SkipFct of Cil_datatype.Kf.Set.t
- | WP_Fct of Cil_datatype.Kf.Set.t
-
-val job : unit -> job
-
(** {2 Model Selection} *)
val has_dkey : category -> bool
@@ -55,10 +61,15 @@ module InCtxt : Parameter_sig.String_set
module ExternArrays: Parameter_sig.Bool
module Literals : Parameter_sig.Bool
module Volatile : Parameter_sig.Bool
-(* module Overflows : Parameter_sig.Bool *)
-(* use get_overflows() below *)
-(* module BoolRange : Parameter_sig.Bool *)
-(* use get_bool_range() below *)
+
+module Region: Parameter_sig.Bool
+module Region_rw: Parameter_sig.Bool
+module Region_pack: Parameter_sig.Bool
+module Region_flat: Parameter_sig.Bool
+module Region_annot: Parameter_sig.Bool
+module Region_inline: Parameter_sig.Bool
+module Region_fixpoint: Parameter_sig.Bool
+module Region_cluster: Parameter_sig.Bool
(** {2 Computation Strategies} *)
@@ -112,9 +123,7 @@ module CoqLibs: Parameter_sig.String_list
module CoqTactic: Parameter_sig.String
module Hints: Parameter_sig.Int
module TryHints: Parameter_sig.Bool
-module Why3: Parameter_sig.String
-module WhyLibs: Parameter_sig.String_list
-module WhyFlags: Parameter_sig.String_list
+module Why3Flags: Parameter_sig.String_list
module AltErgo: Parameter_sig.String
module AltGrErgo: Parameter_sig.String
module AltErgoLibs: Parameter_sig.String_list
@@ -135,15 +144,14 @@ module ReportName: Parameter_sig.String
module MemoryContext: Parameter_sig.Bool
module Check: Parameter_sig.Bool
-(** {2 Environment Variables} *)
+(** {2 Getters} *)
-val get_env : ?default:string -> string -> string
-val is_out : unit -> bool (* -wp-out <dir> positioned *)
+val has_out : unit -> bool
+val has_session : unit -> bool
val get_session : unit -> string
val get_session_dir : string -> string
val get_output : unit -> string
val get_output_dir : string -> string
-val get_includes : unit -> string list
val make_output_dir : string -> unit
val get_overflows : unit -> bool
diff --git a/tests/libc/oracle/fc_libc.1.res.oracle b/tests/libc/oracle/fc_libc.1.res.oracle
index d0942621eceadea65324eea022577dd0fad7f0f9..f1bb1d42421189f8e087c94215e6f4d70d1cf335 100644
--- a/tests/libc/oracle/fc_libc.1.res.oracle
+++ b/tests/libc/oracle/fc_libc.1.res.oracle
@@ -2346,8 +2346,11 @@ extern void free(void *p);
*/
extern void *realloc(void *ptr, size_t size);
-/*@ ensures never_terminates: \false;
- assigns \nothing; */
+/*@ exits status: \exit_status ≢ 0;
+ ensures never_terminates: \false;
+
+ assigns \exit_status \from \nothing;
+ */
extern __attribute__((__noreturn__)) void abort(void);
/*@ assigns \result;
@@ -2358,8 +2361,11 @@ extern int atexit(void (*func)(void));
assigns \result \from \nothing; */
extern int at_quick_exit(void (*func)(void));
-/*@ ensures never_terminates: \false;
- assigns \nothing; */
+/*@ exits status: \exit_status ≡ \old(status);
+ ensures never_terminates: \false;
+
+ assigns \exit_status \from status;
+ */
extern __attribute__((__noreturn__)) void exit(int status);
/*@ ensures never_terminates: \false;
diff --git a/tests/pretty_printing/annotations.i b/tests/pretty_printing/annotations.i
new file mode 100644
index 0000000000000000000000000000000000000000..1d80a03ba031afea73f4f4f1b3e9d306078df4e5
--- /dev/null
+++ b/tests/pretty_printing/annotations.i
@@ -0,0 +1,113 @@
+/*@ axiomatic A {
+ predicate P(integer x) reads \nothing ;
+ }
+*/
+
+//@ ghost int global_decl ;
+//@ ghost int global_def = 42 ;
+
+/*@
+ requires P(x) && x > 0 ;
+ ensures P(x) ;
+*/
+void function_no_ghost(int x) {
+ int y = 0;
+
+ /*@ loop invariant 0 <= y <= x ;
+ loop assigns y ;
+ loop variant x - y ; */
+ while (y < x) {
+ /*@ assert y < x ; */
+ y++;
+ /*@ assert y <= x ; */
+ }
+
+ //@ assert y == x ;
+
+ /*@ requires y == x ;
+ assigns y ;
+ ensures y != x ;
+ */ {
+ y -- ;
+ y *= 2 ;
+ }
+
+ //@ requires y >= 0 ;
+ y /= y ;
+}
+
+/*@
+ requires P(x) && x > 0 ;
+ ensures P(x) ;
+*/
+void function_with_ghost(int x) {
+ //@ ghost int y = 0;
+
+ /*@ ghost
+ /@ loop invariant 0 <= y <= x ;
+ loop assigns y ;
+ loop variant x - y ; @/
+ while (y < x) {
+ /@ assert y < x ; @/
+ y++;
+ /@ assert y <= x ; @/
+ }
+ */
+
+ //@ assert y == x ;
+
+ /*@ ghost
+ /@ requires y == x ;
+ assigns y ;
+ ensures y != x ;
+ @/ {
+ y -- ;
+ y *= 2 ;
+ }
+ */
+
+ /*@ ghost
+ //@ requires y >= 0 ;
+ y /= y ;
+ */
+}
+
+/* @ ghost TODO: reactivate this test when ghost-functions are supported
+ /@
+ requires P(x) && x > 0 ;
+ ensures P(x) ;
+ @/
+ void ghost_function(int x) {
+ int y = 0;
+
+ /@ loop invariant 0 <= y <= x ;
+ loop assigns y ;
+ loop variant x - y ; @/
+ while (y < x) {
+ /@ assert y < x ; @/
+ y++;
+ /@ assert y <= x ; @/
+ }
+
+ /@ assert y == x ; @/
+
+ /@ requires y == x ;
+ assigns y ;
+ ensures y != x ;
+ @/ {
+ y -- ;
+ y *= 2 ;
+ }
+
+ //@ requires y >= 0 ;
+ y /= y ;
+}
+*/
+
+/* @ ghost TODO: reactivate this test when ghost-functions are supported
+ void function_declaration(int variable) ;
+*/
+
+void reference_function(void){
+ // @ ghost function_declaration(42) ;
+}
diff --git a/tests/pretty_printing/oracle/annotations.res.oracle b/tests/pretty_printing/oracle/annotations.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..e0259ac8679d28eb2dc45f1e187766a9979c90c7
--- /dev/null
+++ b/tests/pretty_printing/oracle/annotations.res.oracle
@@ -0,0 +1,155 @@
+[kernel] Parsing tests/pretty_printing/annotations.i (no preprocessing)
+/* Generated by Frama-C */
+/*@ axiomatic A {
+ predicate P(ℤ x)
+ reads \nothing;
+
+ }
+ */
+/*@ ghost int global_decl; */
+/*@ ghost int global_def = 42; */
+/*@ requires P(x) ∧ x > 0;
+ ensures P(\old(x)); */
+void function_no_ghost(int x)
+{
+ int y = 0;
+ /*@ loop invariant 0 ≤ y ≤ x;
+ loop assigns y;
+ loop variant x - y; */
+ while (y < x) {
+ /*@ assert y < x; */ ;
+ y ++;
+ /*@ assert y ≤ x; */ ;
+ }
+ /*@ assert y ≡ x; */ ;
+ /*@ requires y ≡ x;
+ ensures y ≢ x;
+ assigns y; */
+ {
+ y --;
+ y *= 2;
+ }
+ /*@ requires y ≥ 0; */
+ y /= y;
+ return;
+}
+
+/*@ requires P(x) ∧ x > 0;
+ ensures P(\old(x)); */
+void function_with_ghost(int x)
+{
+ /*@ ghost int y = 0; */
+ /*@ ghost
+ /@ loop invariant 0 ≤ y ≤ x;
+ loop assigns y;
+ loop variant x - y; @/
+ while (y < x) {
+ /@ assert y < x; @/
+ ;
+ y ++;
+ /@ assert y ≤ x; @/
+ ;
+ }
+ */
+ /*@ assert y ≡ x; */ ;
+ /*@ ghost
+ /@ requires y ≡ x;
+ ensures y ≢ x;
+ assigns y; @/
+ {
+ y --;
+ y *= 2;
+ }
+ */
+ /*@ ghost /@ requires y ≥ 0; @/
+ y /= y; */
+ return;
+}
+
+void reference_function(void)
+{
+ return;
+}
+
+
+[kernel] Parsing tests/pretty_printing/result/annotations.c (with preprocessing)
+[kernel] Parsing tests/pretty_printing/annotations.i (no preprocessing)
+[kernel] tests/pretty_printing/annotations.i:13: Warning:
+ def'n of func function_no_ghost at tests/pretty_printing/annotations.i:13 (sum 9297192) conflicts with the one at tests/pretty_printing/result/annotations.c:12 (sum 14988159); keeping the one at tests/pretty_printing/result/annotations.c:12.
+[kernel] tests/pretty_printing/annotations.i:43: Warning:
+ def'n of func function_with_ghost at tests/pretty_printing/annotations.i:43 (sum 9297192) conflicts with the one at tests/pretty_printing/result/annotations.c:38 (sum 14988159); keeping the one at tests/pretty_printing/result/annotations.c:38.
+[kernel] tests/pretty_printing/annotations.i:111: Warning:
+ dropping duplicate def'n of func reference_function at tests/pretty_printing/annotations.i:111 in favor of that at tests/pretty_printing/result/annotations.c:68
+/* Generated by Frama-C */
+/*@ axiomatic A {
+ predicate P(ℤ x)
+ reads \nothing;
+
+ }
+ */
+/*@ ghost int global_decl; */
+/*@ ghost int global_def = 42; */
+/*@ requires P(x) ∧ x > 0;
+ ensures P(\old(x)); */
+void function_no_ghost(int x)
+{
+ int y = 0;
+ /*@ loop invariant 0 ≤ y ≤ x;
+ loop assigns y;
+ loop variant x - y; */
+ while (y < x) {
+ /*@ assert y < x; */ ;
+ y ++;
+ /*@ assert y ≤ x; */ ;
+ }
+ /*@ assert y ≡ x; */ ;
+ /*@ requires y ≡ x;
+ ensures y ≢ x;
+ assigns y; */
+ {
+ y --;
+ y *= 2;
+ }
+ /*@ requires y ≥ 0; */
+ y /= y;
+ return;
+}
+
+/*@ requires P(x) ∧ x > 0;
+ ensures P(\old(x)); */
+void function_with_ghost(int x)
+{
+ /*@ ghost int y = 0; */
+ /*@ ghost
+ /@ loop invariant 0 ≤ y ≤ x;
+ loop assigns y;
+ loop variant x - y; @/
+ while (y < x) {
+ /@ assert y < x; @/
+ ;
+ y ++;
+ /@ assert y ≤ x; @/
+ ;
+ }
+ */
+ /*@ assert y ≡ x; */ ;
+ /*@ ghost
+ /@ requires y ≡ x;
+ ensures y ≢ x;
+ assigns y; @/
+ {
+ y --;
+ y *= 2;
+ }
+ */
+ /*@ ghost /@ requires y ≥ 0; @/
+ y /= y; */
+ return;
+}
+
+void reference_function(void)
+{
+ return;
+}
+
+
diff --git a/tests/spec/oracle/assigns_result.res.oracle b/tests/spec/oracle/assigns_result.res.oracle
index be625108d0cc0a76d746cf2a203d0f00b79b70d4..f492644ff778a0fd8afe7cbcf2d9cd7cf94f4062 100644
--- a/tests/spec/oracle/assigns_result.res.oracle
+++ b/tests/spec/oracle/assigns_result.res.oracle
@@ -11,8 +11,6 @@
[eva] Done for function f
[eva] computing for function g <- main.
Called from tests/spec/assigns_result.i:16.
-[inout] tests/spec/assigns_result.i:16: Warning:
- failed to interpret assigns clause '\exit_status'
[eva] using specification for function g
[eva] tests/spec/assigns_result.i:16: Warning:
cannot interpret assigns clause \exit_status
diff --git a/tests/syntax/oracle/ghost_multiline_annot.0.res.oracle b/tests/syntax/oracle/ghost_multiline_annot.0.res.oracle
index a1b72856b21cf5e086a4bc325f794e87dcaf34cd..c8071303034a8e9a29cd54bb895f61696618c9ae 100644
--- a/tests/syntax/oracle/ghost_multiline_annot.0.res.oracle
+++ b/tests/syntax/oracle/ghost_multiline_annot.0.res.oracle
@@ -3,12 +3,14 @@
int main(int c)
{
int __retres;
- /*@ requires c ≥ 0; */
- /*@ ghost int x = c; */
- /*@ loop invariant x ≥ 0;
- loop assigns x;
- loop variant x; */
- /*@ ghost while (x > 0) x --; */
+ /*@ ghost /@ requires c ≥ 0; @/
+ int x = c; */
+ /*@ ghost
+ /@ loop invariant x ≥ 0;
+ loop assigns x;
+ loop variant x; @/
+ while (x > 0) x --;
+ */
__retres = 0;
return __retres;
}
diff --git a/tests/syntax/oracle/ghost_multiline_annot.6.res.oracle b/tests/syntax/oracle/ghost_multiline_annot.6.res.oracle
index 2a924d8ae0eb5823a84bdd5b62cc660f80758220..a7859b320dda126c06a33ce03c652e7f6000b888 100644
--- a/tests/syntax/oracle/ghost_multiline_annot.6.res.oracle
+++ b/tests/syntax/oracle/ghost_multiline_annot.6.res.oracle
@@ -4,9 +4,10 @@ int main(void)
{
int __retres;
/*@ ghost int x = 10; */
- /*@ loop invariant x ≥ 0;
- loop variant x; */
- /*@ ghost while (x > 0) x --; */
+ /*@ ghost /@ loop invariant x ≥ 0;
+ loop variant x; @/
+ while (x > 0) x --;
+ */
__retres = 0;
return __retres;
}
diff --git a/tests/syntax/oracle/ghost_multiline_annot.7.res.oracle b/tests/syntax/oracle/ghost_multiline_annot.7.res.oracle
index 2019d87badcbe58ff2104e81b12fbf70dae540c7..6ee6fd7133f935cf8d4e05201fd1e2d8abba1d69 100644
--- a/tests/syntax/oracle/ghost_multiline_annot.7.res.oracle
+++ b/tests/syntax/oracle/ghost_multiline_annot.7.res.oracle
@@ -3,12 +3,14 @@
int main(int c)
{
int __retres;
- /*@ requires c ≥ 0; */
- /*@ ghost int x = c; */
- /*@ loop invariant x ≥ 0;
- loop invariant x ≡ x;
- loop variant x; */
- /*@ ghost while (x > 0) x --; */
+ /*@ ghost /@ requires c ≥ 0; @/
+ int x = c; */
+ /*@ ghost
+ /@ loop invariant x ≥ 0;
+ loop invariant x ≡ x;
+ loop variant x; @/
+ while (x > 0) x --;
+ */
__retres = 0;
return __retres;
}
diff --git a/tests/syntax/oracle/ghost_multiline_annot.8.res.oracle b/tests/syntax/oracle/ghost_multiline_annot.8.res.oracle
index 2019d87badcbe58ff2104e81b12fbf70dae540c7..6ee6fd7133f935cf8d4e05201fd1e2d8abba1d69 100644
--- a/tests/syntax/oracle/ghost_multiline_annot.8.res.oracle
+++ b/tests/syntax/oracle/ghost_multiline_annot.8.res.oracle
@@ -3,12 +3,14 @@
int main(int c)
{
int __retres;
- /*@ requires c ≥ 0; */
- /*@ ghost int x = c; */
- /*@ loop invariant x ≥ 0;
- loop invariant x ≡ x;
- loop variant x; */
- /*@ ghost while (x > 0) x --; */
+ /*@ ghost /@ requires c ≥ 0; @/
+ int x = c; */
+ /*@ ghost
+ /@ loop invariant x ≥ 0;
+ loop invariant x ≡ x;
+ loop variant x; @/
+ while (x > 0) x --;
+ */
__retres = 0;
return __retres;
}
diff --git a/tests/value/traces/oracle/test1.res.oracle b/tests/value/traces/oracle/test1.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..371a47f96c36e39e09c8da22b72a8cc9d95178cd
--- /dev/null
+++ b/tests/value/traces/oracle/test1.res.oracle
@@ -0,0 +1,160 @@
+[kernel] Parsing tests/value/traces/test1.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
+ entropy_source ∈ [--..--]
+ g ∈ {42}
+[eva] Recording results for main
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ g ∈ {5; 45}
+ tmp ∈ {5; 45}
+[eva:d-traces] Trace domains:
+ start: 0; globals = g, entropy_source; main_formals = c;
+ {[ 0 -> initialize variable: entropy_source -> 1
+ 1 -> initialize variable using type Library_Global
+entropy_source -> 2
+ 2 -> initialize variable: g -> 3
+ 3 -> Assign: g = 42 -> 4
+ 4 -> initialize variable using type Main_Formal
+c -> 5
+ 5 -> EnterScope: tmp -> 6
+ 6 -> Assign: tmp = 0 -> 7
+ 7 -> Assume: c true -> 8; Assume: c false -> 10
+ 8 -> Assign: tmp = g -> 9
+ 9 -> EnterScope: i -> 12
+ 10 -> Assign: tmp = 2 -> 11
+ 11 -> EnterScope: i -> 15
+ 12 -> initialize variable: i -> 13
+ 13 -> Assign: i = 0 -> 14
+ 14 -> enter_loop -> 19
+ 15 -> initialize variable: i -> 16
+ 16 -> Assign: i = 0 -> 17
+ 17 -> enter_loop -> 18
+ 18 -> Assume: i < 3 true -> 20
+ 19 -> Assume: i < 3 true -> 21
+ 20 -> Assign: tmp = tmp + 1 -> 22
+ 21 -> Assign: tmp = tmp + 1 -> 23
+ 22 -> Assign: i = i + 1 -> 24
+ 23 -> Assign: i = i + 1 -> 25
+ 24 -> Assume: i < 3 true -> 27
+ 25 -> Assume: i < 3 true -> 26
+ 26 -> Assign: tmp = tmp + 1 -> 28
+ 27 -> Assign: tmp = tmp + 1 -> 29
+ 28 -> Assign: i = i + 1 -> 30
+ 29 -> Assign: i = i + 1 -> 31
+ 30 -> Assume: i < 3 true -> 33
+ 31 -> Assume: i < 3 true -> 32
+ 32 -> Assign: tmp = tmp + 1 -> 34
+ 33 -> Assign: tmp = tmp + 1 -> 35
+ 34 -> Assign: i = i + 1 -> 36
+ 35 -> Assign: i = i + 1 -> 37
+ 36 -> Assume: i < 3 false -> 39
+ 37 -> Assume: i < 3 false -> 38
+ 38 -> LeaveScope: i -> 41
+ 39 -> LeaveScope: i -> 40
+ 40 -> LeaveScope: i -> 42
+ 41 -> LeaveScope: i -> 43
+ 42 -> Assign: g = tmp -> 44
+ 43 -> Assign: g = tmp -> 45
+ 44 -> EnterScope: \result<main> -> 46
+ 45 -> EnterScope: \result<main> -> 48
+ 46 -> Assign: \result<main> = tmp -> 47
+ 47 -> join -> 50
+ 48 -> Assign: \result<main> = tmp -> 49
+ 49 -> join -> 50 ]} at 50
+[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 main:
+ g FROM g; c
+ \result FROM g; c
+[from] ====== END OF DEPENDENCIES ======
+[inout] Out (internal) for function main:
+ g; tmp; i
+[inout] Inputs for function main:
+ g
+[eva] Analyzing a complete application starting at main
+[eva] Computing initial state
+[eva] Initial state computed
+[eva:initial-state] Values of globals at initialization
+ entropy_source ∈ [--..--]
+ g ∈ {42}
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ g ∈ {5; 45}
+ __traces_domain_return ∈ {5; 45}
+/* Generated by Frama-C */
+extern int volatile entropy_source;
+
+/*@ requires min ≤ max;
+ ensures \old(min) ≤ \result ≤ \old(max);
+ assigns \result, entropy_source;
+ assigns \result \from min, max, entropy_source;
+ assigns entropy_source \from entropy_source;
+ */
+extern int interval(int min, int max);
+
+int g = 42;
+int main(int c)
+{
+ int __traces_domain_return;
+ g = 42;
+ {
+ int tmp;
+ tmp = 0;
+ if (c) {
+ tmp = g;
+ {
+ int i;
+ i = 0;
+ /*@ assert i < 3; */
+ tmp ++;
+ i ++;
+ /*@ assert i < 3; */
+ tmp ++;
+ i ++;
+ /*@ assert i < 3; */
+ tmp ++;
+ i ++;
+ /*@ assert ¬(i < 3); */
+ g = tmp;
+ {
+ int _result_main_;
+ _result_main_ = tmp;
+ __traces_domain_return = tmp;
+ }
+ }
+ }
+ else {
+ tmp = 2;
+ {
+ int i;
+ i = 0;
+ /*@ assert i < 3; */
+ tmp ++;
+ i ++;
+ /*@ assert i < 3; */
+ tmp ++;
+ i ++;
+ /*@ assert i < 3; */
+ tmp ++;
+ i ++;
+ /*@ assert ¬(i < 3); */
+ g = tmp;
+ {
+ int _result_main_;
+ _result_main_ = tmp;
+ __traces_domain_return = tmp;
+ }
+ }
+ }
+ }
+ return __traces_domain_return;
+}
+
+
diff --git a/tests/value/traces/oracle/test2.res.oracle b/tests/value/traces/oracle/test2.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..c936d8bb9b5ec7356b61cb874df09a8192438bd2
--- /dev/null
+++ b/tests/value/traces/oracle/test2.res.oracle
@@ -0,0 +1,188 @@
+[kernel] Parsing tests/value/traces/test2.i (no 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
+
+[eva] computing for function loop <- main.
+ Called from tests/value/traces/test2.i:18.
+[eva] Recording results for loop
+[eva] Done for function loop
+[eva] computing for function loop <- main.
+ Called from tests/value/traces/test2.i:18.
+[eva] Recording results for loop
+[eva] Done for function loop
+[eva] Recording results for main
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function loop:
+ j ∈ {4; 5}
+[eva:final-states] Values at end of function main:
+ tmp ∈ {4; 5}
+[eva:d-traces] Trace domains:
+ start: 0; globals = ; main_formals = c;
+ {[ 0 -> initialize variable using type Main_Formal
+c -> 1
+ 1 -> EnterScope: tmp -> 2
+ 2 -> Assign: tmp = 0 -> 3
+ 3 -> Assume: c true -> 4; Assume: c false -> 6
+ 4 -> Assign: tmp = 1 -> 5
+ 5 -> start_call: loop (true) -> 8
+ 6 -> Assign: tmp = 2 -> 7
+ 7 -> start_call: loop (true) -> 40
+ 8 -> EnterScope: j -> 9
+ 9 -> Assign: j = tmp -> 10
+ 10 -> EnterScope: i -> 11
+ 11 -> initialize variable: i -> 12
+ 12 -> Assign: i = 0 -> 13
+ 13 -> enter_loop -> 14
+ 14 -> Assume: i < 3 true -> 15
+ 15 -> Assign: j = j + 1 -> 16
+ 16 -> Assign: i = i + 1 -> 17
+ 17 -> Assume: i < 3 true -> 18
+ 18 -> Assign: j = j + 1 -> 19
+ 19 -> Assign: i = i + 1 -> 20
+ 20 -> Assume: i < 3 true -> 21
+ 21 -> Assign: j = j + 1 -> 22
+ 22 -> Assign: i = i + 1 -> 23
+ 23 -> Assume: i < 3 false -> 24
+ 24 -> LeaveScope: i -> 25
+ 25 -> LeaveScope: i -> 26
+ 26 -> EnterScope: \result<loop> -> 27
+ 27 -> Assign: \result<loop> = j -> 28
+ 28 -> LeaveScope: j -> 36
+ 36 -> finalize_call: loop -> 37
+ 37 -> Assign: tmp = \result<loop> -> 38
+ 38 -> LeaveScope: \result<loop> -> 39
+ 39 -> EnterScope: \result<main> -> 80
+ 40 -> EnterScope: j -> 41
+ 41 -> Assign: j = tmp -> 42
+ 42 -> EnterScope: i -> 44
+ 44 -> initialize variable: i -> 45
+ 45 -> Assign: i = 0 -> 46
+ 46 -> enter_loop -> 47
+ 47 -> Assume: i < 3 true -> 48
+ 48 -> Assign: j = j + 1 -> 49
+ 49 -> Assign: i = i + 1 -> 50
+ 50 -> Assume: i < 3 true -> 51
+ 51 -> Assign: j = j + 1 -> 52
+ 52 -> Assign: i = i + 1 -> 53
+ 53 -> Assume: i < 3 true -> 54
+ 54 -> Assign: j = j + 1 -> 55
+ 55 -> Assign: i = i + 1 -> 56
+ 56 -> Assume: i < 3 false -> 57
+ 57 -> LeaveScope: i -> 58
+ 58 -> LeaveScope: i -> 59
+ 59 -> EnterScope: \result<loop> -> 60
+ 60 -> Assign: \result<loop> = j -> 61
+ 61 -> LeaveScope: j -> 76
+ 76 -> finalize_call: loop -> 77
+ 77 -> Assign: tmp = \result<loop> -> 78
+ 78 -> LeaveScope: \result<loop> -> 79
+ 79 -> EnterScope: \result<main> -> 82
+ 80 -> Assign: \result<main> = tmp -> 81
+ 81 -> join -> 84
+ 82 -> Assign: \result<main> = tmp -> 83
+ 83 -> join -> 84 ]} at 84
+[from] Computing for function loop
+[from] Done for function loop
+[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 loop:
+ \result FROM j
+[from] Function main:
+ \result FROM c
+[from] ====== END OF DEPENDENCIES ======
+[inout] Out (internal) for function loop:
+ j; i
+[inout] Inputs for function loop:
+ \nothing
+[inout] Out (internal) for function main:
+ tmp
+[inout] Inputs for function main:
+ \nothing
+[eva] Analyzing a complete application starting at main
+[eva] Computing initial state
+[eva] Initial state computed
+[eva:initial-state] Values of globals at initialization
+
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ __traces_domain_return ∈ {4; 5}
+/* Generated by Frama-C */
+int main(int c)
+{
+ int __traces_domain_return;
+ {
+ int tmp;
+ tmp = 0;
+ if (c) {
+ tmp = 1;
+ {
+ int j;
+ j = tmp;
+ {
+ int i;
+ i = 0;
+ /*@ assert i < 3; */
+ j ++;
+ i ++;
+ /*@ assert i < 3; */
+ j ++;
+ i ++;
+ /*@ assert i < 3; */
+ j ++;
+ i ++;
+ /*@ assert ¬(i < 3); */
+ {
+ int _result_loop_;
+ _result_loop_ = j;
+ tmp = _result_loop_;
+ {
+ int _result_main_;
+ _result_main_ = tmp;
+ __traces_domain_return = tmp;
+ }
+ }
+ }
+ }
+ }
+ else {
+ tmp = 2;
+ {
+ int j;
+ j = tmp;
+ {
+ int i;
+ i = 0;
+ /*@ assert i < 3; */
+ j ++;
+ i ++;
+ /*@ assert i < 3; */
+ j ++;
+ i ++;
+ /*@ assert i < 3; */
+ j ++;
+ i ++;
+ /*@ assert ¬(i < 3); */
+ {
+ int _result_loop_;
+ _result_loop_ = j;
+ tmp = _result_loop_;
+ {
+ int _result_main_;
+ _result_main_ = tmp;
+ __traces_domain_return = tmp;
+ }
+ }
+ }
+ }
+ }
+ }
+ return __traces_domain_return;
+}
+
+
diff --git a/tests/value/traces/oracle/test3.res.oracle b/tests/value/traces/oracle/test3.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..d99315838e92aad39c6e71fdddf12bbbf71b6085
--- /dev/null
+++ b/tests/value/traces/oracle/test3.res.oracle
@@ -0,0 +1,73 @@
+[kernel] Parsing tests/value/traces/test3.i (no 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
+ g ∈ {0}
+[eva] Recording results for main
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ g ∈ {4}
+ tmp ∈ {4}
+ __retres ∈ {5}
+[eva:d-traces] Trace domains:
+ start: 0; globals = g; main_formals = c;
+ {[ 0 -> initialize variable: g -> 1
+ 1 -> initialize variable using type Main_Formal
+c -> 2
+ 2 -> EnterScope: __retres -> 3
+ 3 -> EnterScope: tmp -> 4
+ 4 -> initialize variable: tmp -> 5
+ 5 -> Assign: tmp = 4 -> 6
+ 6 -> Assume: tmp true -> 7
+ 7 -> Assign: g = tmp -> 8
+ 8 -> Assign: __retres = g + 1 -> 9
+ 9 -> EnterScope: \result<main> -> 10
+ 10 -> Assign: \result<main> = __retres -> 11 ]} at 11
+[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 main:
+ g FROM \nothing
+ \result FROM \nothing
+[from] ====== END OF DEPENDENCIES ======
+[inout] Out (internal) for function main:
+ g; tmp; __retres
+[inout] Inputs for function main:
+ g
+[eva] Analyzing a complete application starting at main
+[eva] Computing initial state
+[eva] Initial state computed
+[eva:initial-state] Values of globals at initialization
+ g ∈ {0}
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ g ∈ {4}
+ __traces_domain_return ∈ {5}
+/* Generated by Frama-C */
+int g;
+int main(int c)
+{
+ int __traces_domain_return;
+ {
+ int __retres;
+ {
+ int tmp;
+ tmp = 4;
+ /*@ assert tmp ≢ 0; */
+ g = tmp;
+ __retres = g + 1;
+ {
+ int _result_main_;
+ _result_main_ = __retres;
+ __traces_domain_return = __retres;
+ }
+ }
+ }
+ return __traces_domain_return;
+}
+
+
diff --git a/tests/value/traces/oracle/test4.res.oracle b/tests/value/traces/oracle/test4.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..62f44d1b1031d4d20500bb91b2d631300bead971
--- /dev/null
+++ b/tests/value/traces/oracle/test4.res.oracle
@@ -0,0 +1,276 @@
+[kernel] Parsing tests/value/traces/test4.i (no 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
+
+[eva] tests/value/traces/test4.i:9: starting to merge loop iterations
+[eva:alarm] tests/value/traces/test4.i:11: Warning:
+ signed overflow. assert tmp + 1 ≤ 2147483647;
+[eva:alarm] tests/value/traces/test4.i:14: Warning:
+ signed overflow. assert tmp + 1 ≤ 2147483647;
+[eva:alarm] tests/value/traces/test4.i:17: Warning:
+ signed overflow. assert tmp + 1 ≤ 2147483647;
+[eva:alarm] tests/value/traces/test4.i:20: Warning:
+ signed overflow. assert tmp + 1 ≤ 2147483647;
+[eva:alarm] tests/value/traces/test4.i:23: Warning:
+ signed overflow. assert tmp + 1 ≤ 2147483647;
+[eva:alarm] tests/value/traces/test4.i:25: Warning:
+ signed overflow. assert tmp + 1 ≤ 2147483647;
+[eva] Recording results for main
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ tmp ∈ [46..2147483647]
+[eva:d-traces] Trace domains:
+ start: 0; globals = ; main_formals = c;
+ {[ 0 -> initialize variable using type Main_Formal
+c -> 1
+ 1 -> EnterScope: tmp -> 2
+ 2 -> initialize variable: tmp -> 3
+ 3 -> Assign: tmp = 0 -> 4
+ 4 -> EnterScope: i -> 5
+ 5 -> initialize variable: i -> 6
+ 6 -> Assign: i = 0 -> 7
+ 7 -> enter_loop -> 8
+ 8 -> Assume: i < 100 true -> 9
+ 9 -> Assume: i % 2 false -> 10
+ 10 -> Assume: i % 3 false -> 11
+ 11 -> Assume: i % 5 false -> 12
+ 12 -> Assume: i % 7 false -> 13
+ 13 -> Assume: i % 11 false -> 14
+ 14 -> Assign: tmp = tmp + 1 -> 15
+ 15 -> Assign: i = i + 1 -> 16
+ 16 -> Assume: i < 100 true -> 17
+ 17 -> Assume: i % 2 true -> 18
+ 18 -> Assign: tmp = tmp + 1 -> 19
+ 19 -> Assume: i % 3 true -> 20
+ 20 -> Assign: tmp = tmp + 1 -> 21
+ 21 -> Assume: i % 5 true -> 22
+ 22 -> Assign: tmp = tmp + 1 -> 23
+ 23 -> Assume: i % 7 true -> 24
+ 24 -> Assign: tmp = tmp + 1 -> 25
+ 25 -> Assume: i % 11 true -> 26
+ 26 -> Assign: tmp = tmp + 1 -> 27
+ 27 -> Assign: tmp = tmp + 1 -> 28
+ 28 -> Assign: i = i + 1 -> 29
+ 29 -> Assume: i < 100 true -> 30
+ 30 -> Assume: i % 2 false -> 31
+ 31 -> Assume: i % 3 true -> 32
+ 32 -> Assign: tmp = tmp + 1 -> 33
+ 33 -> Assume: i % 5 true -> 34
+ 34 -> Assign: tmp = tmp + 1 -> 35
+ 35 -> Assume: i % 7 true -> 36
+ 36 -> Assign: tmp = tmp + 1 -> 37
+ 37 -> Assume: i % 11 true -> 38
+ 38 -> Assign: tmp = tmp + 1 -> 39
+ 39 -> Assign: tmp = tmp + 1 -> 40
+ 40 -> Assign: i = i + 1 -> 41
+ 41 -> Assume: i < 100 true -> 42
+ 42 -> Assume: i % 2 true -> 43
+ 43 -> Assign: tmp = tmp + 1 -> 44
+ 44 -> Assume: i % 3 false -> 45
+ 45 -> Assume: i % 5 true -> 46
+ 46 -> Assign: tmp = tmp + 1 -> 47
+ 47 -> Assume: i % 7 true -> 48
+ 48 -> Assign: tmp = tmp + 1 -> 49
+ 49 -> Assume: i % 11 true -> 50
+ 50 -> Assign: tmp = tmp + 1 -> 51
+ 51 -> Assign: tmp = tmp + 1 -> 52
+ 52 -> Assign: i = i + 1 -> 53
+ 53 -> Assume: i < 100 true -> 54
+ 54 -> Assume: i % 2 false -> 55
+ 55 -> Assume: i % 3 true -> 56
+ 56 -> Assign: tmp = tmp + 1 -> 57
+ 57 -> Assume: i % 5 true -> 58
+ 58 -> Assign: tmp = tmp + 1 -> 59
+ 59 -> Assume: i % 7 true -> 60
+ 60 -> Assign: tmp = tmp + 1 -> 61
+ 61 -> Assume: i % 11 true -> 62
+ 62 -> Assign: tmp = tmp + 1 -> 63
+ 63 -> Assign: tmp = tmp + 1 -> 64
+ 64 -> Assign: i = i + 1 -> 65
+ 65 -> Assume: i < 100 true -> 66
+ 66 -> Assume: i % 2 true -> 67
+ 67 -> Assign: tmp = tmp + 1 -> 68
+ 68 -> Assume: i % 3 true -> 69
+ 69 -> Assign: tmp = tmp + 1 -> 70
+ 70 -> Assume: i % 5 false -> 71
+ 71 -> Assume: i % 7 true -> 72
+ 72 -> Assign: tmp = tmp + 1 -> 73
+ 73 -> Assume: i % 11 true -> 74
+ 74 -> Assign: tmp = tmp + 1 -> 75
+ 75 -> Assign: tmp = tmp + 1 -> 76
+ 76 -> Assign: i = i + 1 -> 77
+ 77 -> Assume: i < 100 true -> 78
+ 78 -> Assume: i % 2 false -> 79
+ 79 -> Assume: i % 3 false -> 80
+ 80 -> Assume: i % 5 true -> 81
+ 81 -> Assign: tmp = tmp + 1 -> 82
+ 82 -> Assume: i % 7 true -> 83
+ 83 -> Assign: tmp = tmp + 1 -> 84
+ 84 -> Assume: i % 11 true -> 85
+ 85 -> Assign: tmp = tmp + 1 -> 86
+ 86 -> Assign: tmp = tmp + 1 -> 87
+ 87 -> Assign: i = i + 1 -> 88
+ 88 -> Assume: i < 100 true -> 89
+ 89 -> Assume: i % 2 true -> 90
+ 90 -> Assign: tmp = tmp + 1 -> 91
+ 91 -> Assume: i % 3 true -> 92
+ 92 -> Assign: tmp = tmp + 1 -> 93
+ 93 -> Assume: i % 5 true -> 94
+ 94 -> Assign: tmp = tmp + 1 -> 95
+ 95 -> Assume: i % 7 false -> 96
+ 96 -> Assume: i % 11 true -> 97
+ 97 -> Assign: tmp = tmp + 1 -> 98
+ 98 -> Assign: tmp = tmp + 1 -> 99
+ 99 -> Assign: i = i + 1 -> 100
+ 100 -> Assume: i < 100 true -> 101
+ 101 -> Assume: i % 2 false -> 102
+ 102 -> Assume: i % 3 true -> 103
+ 103 -> Assign: tmp = tmp + 1 -> 104
+ 104 -> Assume: i % 5 true -> 105
+ 105 -> Assign: tmp = tmp + 1 -> 106
+ 106 -> Assume: i % 7 true -> 107
+ 107 -> Assign: tmp = tmp + 1 -> 108
+ 108 -> Assume: i % 11 true -> 109
+ 109 -> Assign: tmp = tmp + 1 -> 110
+ 110 -> Assign: tmp = tmp + 1 -> 111
+ 111 -> Assign: i = i + 1 -> 112
+ 112 -> Assume: i < 100 true -> 113
+ 113 -> Assume: i % 2 true -> 114
+ 114 -> Assign: tmp = tmp + 1 -> 115
+ 115 -> Assume: i % 3 false -> 116
+ 116 -> Assume: i % 5 true -> 117
+ 117 -> Assign: tmp = tmp + 1 -> 118
+ 118 -> Assume: i % 7 true -> 119
+ 119 -> Assign: tmp = tmp + 1 -> 120
+ 120 -> Assume: i % 11 true -> 121
+ 121 -> Assign: tmp = tmp + 1 -> 122
+ 122 -> Assign: tmp = tmp + 1 -> 123
+ 123 -> Assign: i = i + 1 -> 124
+ 124 -> Assume: i < 100 true -> 125; join -> 136
+ 125 -> Assume: i % 2 false -> 126; join -> 138
+ 126 -> Assume: i % 3 true -> 127; join -> 143
+ 127 -> Assign: tmp = tmp + 1 -> 128
+ 128 -> Assume: i % 5 false -> 129; join -> 146
+ 129 -> Assume: i % 7 true -> 130; join -> 151
+ 130 -> Assign: tmp = tmp + 1 -> 131
+ 131 -> Assume: i % 11 true -> 132; join -> 154
+ 132 -> Assign: tmp = tmp + 1 -> 133
+ 133 -> Assign: tmp = tmp + 1 -> 134; join -> 159
+ 134 -> Assign: i = i + 1 -> 135; join -> 161
+ 135 -> join -> 136
+ 136 -> Assume: i < 100 true -> 137; join -> 163
+ 137 -> join -> 138
+ 138 -> Assume: i % 2 true -> 139; Assume: i % 2 false -> 141; join -> 165
+ 139 -> Assign: tmp = tmp + 1 -> 140
+ 140 -> join -> 142
+ 141 -> join -> 142
+ 142 -> join -> 143
+ 143 -> Assume: i % 3 true -> 144; join -> 170
+ 144 -> Assign: tmp = tmp + 1 -> 145
+ 145 -> join -> 146
+ 146 -> Assume: i % 5 true -> 147; Assume: i % 5 false -> 149; join -> 175
+ 147 -> Assign: tmp = tmp + 1 -> 148
+ 148 -> join -> 150
+ 149 -> join -> 150
+ 150 -> join -> 151
+ 151 -> Assume: i % 7 true -> 152; join -> 180
+ 152 -> Assign: tmp = tmp + 1 -> 153
+ 153 -> join -> 154
+ 154 -> Assume: i % 11 true -> 155; Assume: i % 11 false -> 157;
+ join -> 183
+ 155 -> Assign: tmp = tmp + 1 -> 156; join -> 185
+ 156 -> join -> 158
+ 157 -> join -> 158
+ 158 -> join -> 159
+ 159 -> Assign: tmp = tmp + 1 -> 160; join -> 189
+ 160 -> join -> 161
+ 161 -> Assign: i = i + 1 -> 162; join -> 191
+ 162 -> join -> 163
+ 163 -> Assume: i < 100 true -> 164; join -> 193
+ 164 -> join -> 165
+ 165 -> Assume: i % 2 true -> 166; Assume: i % 2 false -> 168; join -> 196
+ 166 -> Assign: tmp = tmp + 1 -> 167
+ 167 -> join -> 169
+ 168 -> join -> 169
+ 169 -> join -> 170
+ 170 -> Assume: i % 3 true -> 171; Assume: i % 3 false -> 173; join -> 201
+ 171 -> Assign: tmp = tmp + 1 -> 172
+ 172 -> join -> 174
+ 173 -> join -> 174
+ 174 -> join -> 175
+ 175 -> Assume: i % 5 true -> 176; Assume: i % 5 false -> 178; join -> 206
+ 176 -> Assign: tmp = tmp + 1 -> 177
+ 177 -> join -> 179
+ 178 -> join -> 179
+ 179 -> join -> 180
+ 180 -> Assume: i % 7 true -> 181; join -> 211
+ 181 -> Assign: tmp = tmp + 1 -> 182; join -> 213
+ 182 -> join -> 183
+ 183 -> Assume: i % 11 true -> 184; Assume: i % 11 false -> 187;
+ join -> 217
+ 184 -> join -> 185
+ 185 -> Assign: tmp = tmp + 1 -> 186; join -> 219
+ 186 -> join -> 188
+ 187 -> join -> 188
+ 188 -> join -> 189
+ 189 -> Assign: tmp = tmp + 1 -> 190; join -> 223
+ 190 -> join -> 191
+ 191 -> Assign: i = i + 1 -> 192; join -> 225
+ 192 -> join -> 193
+ 193 -> join -> 196
+ 196 -> join -> 201
+ 201 -> join -> 206
+ 206 -> join -> 211
+ 211 -> join -> 213
+ 213 -> join -> 217
+ 217 -> join -> 219
+ 219 -> join -> 223
+ 223 -> join -> 225
+ 225 -> Loop(4) 194 {[ 194 -> Assume: i < 100 true -> 195
+ 195 -> Assume: i % 2 true -> 197;
+ Assume: i % 2 false -> 199
+ 197 -> Assign: tmp = tmp + 1 -> 198
+ 198 -> join -> 200
+ 199 -> join -> 200
+ 200 -> Assume: i % 3 true -> 202;
+ Assume: i % 3 false -> 204
+ 202 -> Assign: tmp = tmp + 1 -> 203
+ 203 -> join -> 205
+ 204 -> join -> 205
+ 205 -> Assume: i % 5 true -> 207;
+ Assume: i % 5 false -> 209
+ 207 -> Assign: tmp = tmp + 1 -> 208
+ 208 -> join -> 210
+ 209 -> join -> 210
+ 210 -> Assume: i % 7 true -> 212;
+ Assume: i % 7 false -> 215
+ 212 -> Assign: tmp = tmp + 1 -> 214
+ 214 -> join -> 216
+ 215 -> join -> 216
+ 216 -> Assume: i % 11 true -> 218;
+ Assume: i % 11 false -> 221
+ 218 -> Assign: tmp = tmp + 1 -> 220
+ 220 -> join -> 222
+ 221 -> join -> 222
+ 222 -> Assign: tmp = tmp + 1 -> 224
+ 224 -> Assign: i = i + 1 -> 226 ]} -> 228
+ 228 -> Assume: i < 100 false -> 229
+ 229 -> leave_loop -> 230
+ 230 -> LeaveScope: i -> 231
+ 231 -> LeaveScope: i -> 232
+ 232 -> EnterScope: \result<main> -> 233
+ 233 -> Assign: \result<main> = tmp -> 234 ]} at 234
+[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 main:
+ \result FROM \nothing
+[from] ====== END OF DEPENDENCIES ======
+[inout] Out (internal) for function main:
+ tmp; i
+[inout] Inputs for function main:
+ \nothing
diff --git a/tests/value/traces/oracle/test5.res.oracle b/tests/value/traces/oracle/test5.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..1f021acddb6043e4a0f2f980bb3d3fb69561792d
--- /dev/null
+++ b/tests/value/traces/oracle/test5.res.oracle
@@ -0,0 +1,594 @@
+[kernel] Parsing tests/value/traces/test5.i (no preprocessing)
+[kernel:typing:implicit-function-declaration] tests/value/traces/test5.i:21: Warning:
+ Calling undeclared function my_switch. Old style K&R code?
+[eva] Analyzing a complete application starting at main
+[eva] Computing initial state
+[eva] Initial state computed
+[eva:initial-state] Values of globals at initialization
+
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[kernel:annot:missing-spec] tests/value/traces/test5.i:21: Warning:
+ Neither code nor specification for function my_switch, generating default assigns from the prototype
+[eva] using specification for function my_switch
+[eva] Done for function my_switch
+[eva:alarm] tests/value/traces/test5.i:21: Warning:
+ signed overflow.
+ assert tmp_0 + tmp ≤ 2147483647;
+ (tmp_0 from my_switch(tmp))
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva:alarm] tests/value/traces/test5.i:21: Warning:
+ signed overflow.
+ assert -2147483648 ≤ tmp_0 + tmp;
+ (tmp_0 from my_switch(tmp))
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] tests/value/traces/test5.i:20: starting to merge loop iterations
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] tests/value/traces/test5.i:19: starting to merge loop iterations
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] computing for function my_switch <- main.
+ Called from tests/value/traces/test5.i:21.
+[eva] Done for function my_switch
+[eva] Recording results for main
+[eva] done for function main
+[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function main:
+ tmp ∈ [--..--]
+[eva:d-traces] Trace domains:
+ start: 0; globals = ; main_formals = c;
+ {[ 0 -> initialize variable using type Main_Formal
+c -> 1
+ 1 -> EnterScope: tmp -> 2
+ 2 -> initialize variable: tmp -> 3
+ 3 -> Assign: tmp = 1 -> 4
+ 4 -> EnterScope: i -> 5
+ 5 -> initialize variable: i -> 6
+ 6 -> Assign: i = 0 -> 7
+ 7 -> enter_loop -> 8
+ 8 -> Assume: i < 10 true -> 9
+ 9 -> EnterScope: j -> 10
+ 10 -> initialize variable: j -> 11
+ 11 -> Assign: j = 0 -> 12
+ 12 -> enter_loop -> 13
+ 13 -> Assume: j < 10 true -> 14
+ 14 -> EnterScope: tmp_0 -> 15
+ 15 -> EnterScope: \result<my_switch> -> 16
+ 16 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 17
+ 17 -> Assign: tmp_0 = \result<my_switch> -> 18
+ 18 -> LeaveScope: \result<my_switch> -> 19
+ 19 -> Assign: tmp = tmp_0 + tmp -> 20
+ 20 -> LeaveScope: tmp_0 -> 21
+ 21 -> Assign: j = j + 1 -> 22
+ 22 -> Assume: j < 10 true -> 23
+ 23 -> EnterScope: tmp_0 -> 24
+ 24 -> EnterScope: \result<my_switch> -> 25
+ 25 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 26
+ 26 -> Assign: tmp_0 = \result<my_switch> -> 28
+ 28 -> LeaveScope: \result<my_switch> -> 29
+ 29 -> Assign: tmp = tmp_0 + tmp -> 30
+ 30 -> LeaveScope: tmp_0 -> 31
+ 31 -> Assign: j = j + 1 -> 32
+ 32 -> Assume: j < 10 true -> 33
+ 33 -> EnterScope: tmp_0 -> 34
+ 34 -> EnterScope: \result<my_switch> -> 35
+ 35 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 36
+ 36 -> Assign: tmp_0 = \result<my_switch> -> 38
+ 38 -> LeaveScope: \result<my_switch> -> 39
+ 39 -> Assign: tmp = tmp_0 + tmp -> 40
+ 40 -> LeaveScope: tmp_0 -> 41
+ 41 -> Assign: j = j + 1 -> 42
+ 42 -> Assume: j < 10 true -> 43
+ 43 -> EnterScope: tmp_0 -> 44
+ 44 -> EnterScope: \result<my_switch> -> 45
+ 45 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 46
+ 46 -> Assign: tmp_0 = \result<my_switch> -> 48
+ 48 -> LeaveScope: \result<my_switch> -> 49
+ 49 -> Assign: tmp = tmp_0 + tmp -> 50
+ 50 -> LeaveScope: tmp_0 -> 51
+ 51 -> Assign: j = j + 1 -> 52
+ 52 -> Assume: j < 10 true -> 53
+ 53 -> EnterScope: tmp_0 -> 54
+ 54 -> EnterScope: \result<my_switch> -> 55
+ 55 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 56
+ 56 -> Assign: tmp_0 = \result<my_switch> -> 58
+ 58 -> LeaveScope: \result<my_switch> -> 59
+ 59 -> Assign: tmp = tmp_0 + tmp -> 60
+ 60 -> LeaveScope: tmp_0 -> 61
+ 61 -> Assign: j = j + 1 -> 62
+ 62 -> Assume: j < 10 true -> 63
+ 63 -> EnterScope: tmp_0 -> 64
+ 64 -> EnterScope: \result<my_switch> -> 65
+ 65 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 66
+ 66 -> Assign: tmp_0 = \result<my_switch> -> 68
+ 68 -> LeaveScope: \result<my_switch> -> 69
+ 69 -> Assign: tmp = tmp_0 + tmp -> 70
+ 70 -> LeaveScope: tmp_0 -> 71
+ 71 -> Assign: j = j + 1 -> 72
+ 72 -> Assume: j < 10 true -> 73
+ 73 -> EnterScope: tmp_0 -> 74
+ 74 -> EnterScope: \result<my_switch> -> 75
+ 75 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 76
+ 76 -> Assign: tmp_0 = \result<my_switch> -> 78
+ 78 -> LeaveScope: \result<my_switch> -> 79
+ 79 -> Assign: tmp = tmp_0 + tmp -> 80
+ 80 -> LeaveScope: tmp_0 -> 81
+ 81 -> Assign: j = j + 1 -> 82
+ 82 -> Assume: j < 10 true -> 83
+ 83 -> EnterScope: tmp_0 -> 84
+ 84 -> EnterScope: \result<my_switch> -> 85
+ 85 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 86
+ 86 -> Assign: tmp_0 = \result<my_switch> -> 88
+ 88 -> LeaveScope: \result<my_switch> -> 89
+ 89 -> Assign: tmp = tmp_0 + tmp -> 90
+ 90 -> LeaveScope: tmp_0 -> 91
+ 91 -> Assign: j = j + 1 -> 92
+ 92 -> Assume: j < 10 true -> 93
+ 93 -> EnterScope: tmp_0 -> 94
+ 94 -> EnterScope: \result<my_switch> -> 95
+ 95 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 96
+ 96 -> Assign: tmp_0 = \result<my_switch> -> 98
+ 98 -> LeaveScope: \result<my_switch> -> 99
+ 99 -> Assign: tmp = tmp_0 + tmp -> 100
+ 100 -> LeaveScope: tmp_0 -> 101
+ 101 -> Assign: j = j + 1 -> 102
+ 102 -> Assume: j < 10 true -> 103
+ 103 -> EnterScope: tmp_0 -> 104
+ 104 -> EnterScope: \result<my_switch> -> 105
+ 105 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 106
+ 106 -> Assign: tmp_0 = \result<my_switch> -> 108
+ 108 -> LeaveScope: \result<my_switch> -> 109
+ 109 -> Assign: tmp = tmp_0 + tmp -> 110
+ 110 -> LeaveScope: tmp_0 -> 111
+ 111 -> Assign: j = j + 1 -> 112
+ 112 -> Assume: j < 10 false -> 113; join -> 122
+ 113 -> LeaveScope: j -> 114
+ 114 -> LeaveScope: j -> 115
+ 115 -> Assign: i = i + 1 -> 116
+ 116 -> Assume: i < 10 true -> 117
+ 117 -> EnterScope: j -> 118
+ 118 -> initialize variable: j -> 119
+ 119 -> Assign: j = 0 -> 120
+ 120 -> enter_loop -> 121
+ 121 -> join -> 122
+ 122 -> Assume: j < 10 true -> 123; join -> 133
+ 123 -> EnterScope: tmp_0 -> 124; join -> 135
+ 124 -> EnterScope: \result<my_switch> -> 125; join -> 137
+ 125 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 126
+ 126 -> Assign: tmp_0 = \result<my_switch> -> 128
+ 128 -> LeaveScope: \result<my_switch> -> 129
+ 129 -> Assign: tmp = tmp_0 + tmp -> 130; join -> 143
+ 130 -> LeaveScope: tmp_0 -> 131
+ 131 -> Assign: j = j + 1 -> 132; join -> 146
+ 132 -> join -> 133
+ 133 -> Assume: j < 10 true -> 134; join -> 148
+ 134 -> join -> 135
+ 135 -> EnterScope: tmp_0 -> 136; join -> 151
+ 136 -> join -> 137
+ 137 -> EnterScope: \result<my_switch> -> 138; join -> 153
+ 138 -> CallDeclared: \result<my_switch> = my_switch(tmp) -> 139
+ 139 -> Assign: tmp_0 = \result<my_switch> -> 141
+ 141 -> LeaveScope: \result<my_switch> -> 142
+ 142 -> join -> 143
+ 143 -> Assign: tmp = tmp_0 + tmp -> 144; join -> 159
+ 144 -> LeaveScope: tmp_0 -> 145
+ 145 -> join -> 146
+ 146 -> Assign: j = j + 1 -> 147; join -> 162
+ 147 -> join -> 148
+ 148 -> join -> 151
+ 151 -> join -> 153
+ 153 -> join -> 159
+ 159 -> join -> 162
+ 162 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 166;
+ join -> 177
+ 166 -> Assume: j < 10 false -> 167
+ 167 -> leave_loop -> 168
+ 168 -> LeaveScope: j -> 169
+ 169 -> LeaveScope: j -> 170
+ 170 -> Assign: i = i + 1 -> 171
+ 171 -> Assume: i < 10 true -> 172
+ 172 -> EnterScope: j -> 173
+ 173 -> initialize variable: j -> 174
+ 174 -> Assign: j = 0 -> 175
+ 175 -> enter_loop -> 176
+ 176 -> join -> 177
+ 177 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 179;
+ join -> 190
+ 179 -> Assume: j < 10 false -> 180
+ 180 -> leave_loop -> 181
+ 181 -> LeaveScope: j -> 182
+ 182 -> LeaveScope: j -> 183
+ 183 -> Assign: i = i + 1 -> 184
+ 184 -> Assume: i < 10 true -> 185
+ 185 -> EnterScope: j -> 186
+ 186 -> initialize variable: j -> 187
+ 187 -> Assign: j = 0 -> 188
+ 188 -> enter_loop -> 189
+ 189 -> join -> 190
+ 190 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 192;
+ join -> 203
+ 192 -> Assume: j < 10 false -> 193
+ 193 -> leave_loop -> 194
+ 194 -> LeaveScope: j -> 195
+ 195 -> LeaveScope: j -> 196
+ 196 -> Assign: i = i + 1 -> 197
+ 197 -> Assume: i < 10 true -> 198
+ 198 -> EnterScope: j -> 199
+ 199 -> initialize variable: j -> 200
+ 200 -> Assign: j = 0 -> 201
+ 201 -> enter_loop -> 202
+ 202 -> join -> 203
+ 203 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 205;
+ join -> 216
+ 205 -> Assume: j < 10 false -> 206
+ 206 -> leave_loop -> 207
+ 207 -> LeaveScope: j -> 208
+ 208 -> LeaveScope: j -> 209
+ 209 -> Assign: i = i + 1 -> 210
+ 210 -> Assume: i < 10 true -> 211
+ 211 -> EnterScope: j -> 212
+ 212 -> initialize variable: j -> 213
+ 213 -> Assign: j = 0 -> 214
+ 214 -> enter_loop -> 215
+ 215 -> join -> 216
+ 216 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 218;
+ join -> 229
+ 218 -> Assume: j < 10 false -> 219
+ 219 -> leave_loop -> 220
+ 220 -> LeaveScope: j -> 221
+ 221 -> LeaveScope: j -> 222
+ 222 -> Assign: i = i + 1 -> 223
+ 223 -> Assume: i < 10 true -> 224
+ 224 -> EnterScope: j -> 225
+ 225 -> initialize variable: j -> 226
+ 226 -> Assign: j = 0 -> 227
+ 227 -> enter_loop -> 228
+ 228 -> join -> 229
+ 229 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 231;
+ join -> 242
+ 231 -> Assume: j < 10 false -> 232
+ 232 -> leave_loop -> 233
+ 233 -> LeaveScope: j -> 234
+ 234 -> LeaveScope: j -> 235
+ 235 -> Assign: i = i + 1 -> 236
+ 236 -> Assume: i < 10 true -> 237
+ 237 -> EnterScope: j -> 238
+ 238 -> initialize variable: j -> 239
+ 239 -> Assign: j = 0 -> 240
+ 240 -> enter_loop -> 241
+ 241 -> join -> 242
+ 242 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 244;
+ join -> 255
+ 244 -> Assume: j < 10 false -> 245
+ 245 -> leave_loop -> 246
+ 246 -> LeaveScope: j -> 247
+ 247 -> LeaveScope: j -> 248
+ 248 -> Assign: i = i + 1 -> 249
+ 249 -> Assume: i < 10 true -> 250
+ 250 -> EnterScope: j -> 251
+ 251 -> initialize variable: j -> 252
+ 252 -> Assign: j = 0 -> 253
+ 253 -> enter_loop -> 254
+ 254 -> join -> 255
+ 255 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 257;
+ join -> 268
+ 257 -> Assume: j < 10 false -> 258
+ 258 -> leave_loop -> 259
+ 259 -> LeaveScope: j -> 260
+ 260 -> LeaveScope: j -> 261
+ 261 -> Assign: i = i + 1 -> 262
+ 262 -> Assume: i < 10 true -> 263
+ 263 -> EnterScope: j -> 264
+ 264 -> initialize variable: j -> 265
+ 265 -> Assign: j = 0 -> 266
+ 266 -> enter_loop -> 267
+ 267 -> join -> 268
+ 268 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 270;
+ join -> 281
+ 270 -> Assume: j < 10 false -> 271
+ 271 -> leave_loop -> 272
+ 272 -> LeaveScope: j -> 273
+ 273 -> LeaveScope: j -> 274
+ 274 -> Assign: i = i + 1 -> 275
+ 275 -> Assume: i < 10 true -> 276; join -> 289
+ 276 -> EnterScope: j -> 277; join -> 291
+ 277 -> initialize variable: j -> 278
+ 278 -> Assign: j = 0 -> 279
+ 279 -> enter_loop -> 280
+ 280 -> join -> 281
+ 281 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 283;
+ join -> 296
+ 283 -> Assume: j < 10 false -> 284
+ 284 -> leave_loop -> 285
+ 285 -> LeaveScope: j -> 286; join -> 301
+ 286 -> LeaveScope: j -> 287
+ 287 -> Assign: i = i + 1 -> 288; join -> 304
+ 288 -> join -> 289
+ 289 -> Assume: i < 10 true -> 290; join -> 306
+ 290 -> join -> 291
+ 291 -> EnterScope: j -> 292; join -> 308
+ 292 -> initialize variable: j -> 293
+ 293 -> Assign: j = 0 -> 294
+ 294 -> enter_loop -> 295
+ 295 -> join -> 296
+ 296 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 298;
+ join -> 313
+ 298 -> Assume: j < 10 false -> 299
+ 299 -> leave_loop -> 300
+ 300 -> join -> 301
+ 301 -> LeaveScope: j -> 302; join -> 318
+ 302 -> LeaveScope: j -> 303
+ 303 -> join -> 304
+ 304 -> Assign: i = i + 1 -> 305; join -> 321
+ 305 -> join -> 306
+ 306 -> Assume: i < 10 true -> 307; join -> 323
+ 307 -> join -> 308
+ 308 -> EnterScope: j -> 309; join -> 326
+ 309 -> initialize variable: j -> 310
+ 310 -> Assign: j = 0 -> 311
+ 311 -> enter_loop -> 312
+ 312 -> join -> 313
+ 313 -> Loop(16) 149 {[ 149 -> Assume: j < 10 true -> 150
+ 150 -> EnterScope: tmp_0 -> 152
+ 152 -> EnterScope: \result<my_switch> -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(tmp) -> 155
+ 155 -> Assign: tmp_0 = \result<my_switch> -> 157
+ 157 -> LeaveScope: \result<my_switch> -> 158
+ 158 -> Assign: tmp = tmp_0 + tmp -> 160
+ 160 -> LeaveScope: tmp_0 -> 161
+ 161 -> Assign: j = j + 1 -> 163 ]} -> 315;
+ join -> 331
+ 315 -> Assume: j < 10 false -> 316
+ 316 -> leave_loop -> 317
+ 317 -> join -> 318
+ 318 -> LeaveScope: j -> 319; join -> 336
+ 319 -> LeaveScope: j -> 320
+ 320 -> join -> 321
+ 321 -> Assign: i = i + 1 -> 322; join -> 339
+ 322 -> join -> 323
+ 323 -> join -> 326
+ 326 -> join -> 331
+ 331 -> join -> 336
+ 336 -> join -> 339
+ 339 -> Loop(10) 324 {[ 324 -> Assume: i < 10 true -> 325
+ 325 -> EnterScope: j -> 327
+ 327 -> initialize variable: j -> 328
+ 328 -> Assign: j = 0 -> 329
+ 329 -> enter_loop -> 330
+ 330 -> Loop(16) 149 {[ 149 -> Assume:
+ j < 10 true
+ -> 150
+ 150 -> EnterScope:
+ tmp_0 -> 152
+ 152 -> EnterScope:
+ \result<my_switch>
+ -> 154
+ 154 -> CallDeclared:
+ \result<my_switch> =
+ my_switch(
+ tmp) -> 155
+ 155 -> Assign:
+ tmp_0 = \result<my_switch>
+ -> 157
+ 157 -> LeaveScope:
+ \result<my_switch>
+ -> 158
+ 158 -> Assign:
+ tmp = tmp_0 + tmp
+ -> 160
+ 160 -> LeaveScope:
+ tmp_0 -> 161
+ 161 -> Assign:
+ j = j + 1
+ -> 163 ]}
+ -> 333
+ 333 -> Assume: j < 10 false -> 334
+ 334 -> leave_loop -> 335
+ 335 -> LeaveScope: j -> 337
+ 337 -> LeaveScope: j -> 338
+ 338 -> Assign: i = i + 1 -> 340 ]} -> 343
+ 343 -> Assume: i < 10 false -> 344
+ 344 -> leave_loop -> 345
+ 345 -> LeaveScope: i -> 346
+ 346 -> LeaveScope: i -> 347
+ 347 -> EnterScope: \result<main> -> 348
+ 348 -> Assign: \result<main> = tmp -> 349 ]} at 349
+[from] Computing for function main
+[from] Computing for function my_switch <-main
+[from] Done for function my_switch
+[from] Done for function main
+[from] ====== DEPENDENCIES COMPUTED ======
+ These dependencies hold at termination for the executions that terminate:
+[from] Function my_switch:
+ \result FROM x_0
+[from] Function main:
+ \result FROM \nothing
+[from] ====== END OF DEPENDENCIES ======
+[inout] Out (internal) for function main:
+ tmp; i; j; tmp_0
+[inout] Inputs for function main:
+ \nothing
+[kernel] User Error: no known last created project.
+[kernel] Frama-C aborted: invalid user input.
diff --git a/tests/value/traces/test1.c b/tests/value/traces/test1.c
new file mode 100644
index 0000000000000000000000000000000000000000..7fbd4347cc727b620b12ca1b06733b6ec3dbf427
--- /dev/null
+++ b/tests/value/traces/test1.c
@@ -0,0 +1,28 @@
+/* run.config
+ STDOPT: #"-eva-traces-domain -value-msg-key d-traces -slevel 10 -eva-traces-project" +"-then-last -val -print -value-msg-key=-d-traces"
+*/
+
+extern volatile int entropy_source;
+
+/*@ requires min <= max;
+ assigns \result \from min, max, entropy_source;
+ assigns entropy_source \from entropy_source;
+ ensures min <= \result <= max ;
+ */
+extern int interval(int min, int max);
+
+
+int g = 42;
+
+int main(int c){
+ /* c = interval(0,1); */
+ int tmp;
+ tmp = 0;
+ if (c) tmp = g;
+ else tmp = 2;
+ for(int i = 0; i < 3; i++){
+ tmp ++;
+ }
+ g = tmp;
+ return tmp;
+}
diff --git a/tests/value/traces/test2.i b/tests/value/traces/test2.i
new file mode 100644
index 0000000000000000000000000000000000000000..6369b92fd4c148354a6d23f5c80ec7b2cf5715ce
--- /dev/null
+++ b/tests/value/traces/test2.i
@@ -0,0 +1,20 @@
+/* run.config
+ STDOPT: #"-eva-traces-domain -value-msg-key d-traces -slevel 10 -eva-traces-project" +"-then-last -val -print -value-msg-key=-d-traces"
+*/
+
+
+int loop(int j){
+ for(int i = 0; i < 3; i++){
+ j ++;
+ }
+ return j;
+}
+
+int main(int c){
+ int tmp;
+ tmp = 0;
+ if (c) tmp = 1;
+ else tmp = 2;
+ tmp = loop(tmp);
+ return tmp;
+}
diff --git a/tests/value/traces/test3.i b/tests/value/traces/test3.i
new file mode 100644
index 0000000000000000000000000000000000000000..6cd21d4315dfd93081a0edf0565c44b5aa093d30
--- /dev/null
+++ b/tests/value/traces/test3.i
@@ -0,0 +1,15 @@
+/* run.config
+ STDOPT: #"-eva-traces-domain -value-msg-key d-traces -slevel 10 -eva-traces-project" +"-then-last -val -print -value-msg-key=-d-traces"
+*/
+
+int g;
+
+int main(int c){
+ int tmp = 4;
+ if(tmp){
+ g = tmp;
+ } else {
+ g = 1;
+ }
+ return g+1;
+}
diff --git a/tests/value/traces/test4.i b/tests/value/traces/test4.i
new file mode 100644
index 0000000000000000000000000000000000000000..9d4bc60920adba9604d26d492c44a55c77231b59
--- /dev/null
+++ b/tests/value/traces/test4.i
@@ -0,0 +1,28 @@
+/* run.config
+ STDOPT: #"-eva-traces-domain -value-msg-key d-traces -slevel 10"
+*/
+
+/* Test of join inside a loop */
+
+int main(c){
+ int tmp = 0;
+ for(int i = 0; i < 100; i++){
+ if(i % 2){
+ tmp ++;
+ };
+ if(i % 3){
+ tmp ++;
+ };
+ if(i % 5){
+ tmp ++;
+ };
+ if(i % 7){
+ tmp ++;
+ };
+ if(i % 11){
+ tmp ++;
+ };
+ tmp++;
+ }
+ return tmp;
+}
diff --git a/tests/value/traces/test5.i b/tests/value/traces/test5.i
new file mode 100644
index 0000000000000000000000000000000000000000..046cafc651537cef93274c62a847157b4b495efd
--- /dev/null
+++ b/tests/value/traces/test5.i
@@ -0,0 +1,25 @@
+/* run.config
+ STDOPT: #"-eva-traces-domain -value-msg-key d-traces -slevel 10" +"-then-last -val -slevel 10 -print -no-eva-traces-domain"
+*/
+
+
+/* Check the fix for the creation of expression by dataflows2 for
+ switch (conversion to list of if) */
+
+int myswitch(i){
+ switch(i){
+ case 0: return 0;
+ case 1: return 1;
+ default: return 2;
+ }
+}
+
+int main(c){
+ int tmp = 1;
+ for(int i = 0; i < 10; i++){
+ for(int j = 0; j < 10; j++){
+ tmp = my_switch(tmp) + tmp;
+ }
+ }
+ return tmp;
+}