diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index b93b0d75b691d863742a01e4f0f1c2d1baee15b8..2e7790a93c5eaf8613644d465fb0e625d541cdb7 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -22,7 +22,7 @@ default:
variables:
DEFAULT: "master"
- OCAML: "4.11"
+ OCAML: "4.13"
PUBLISH: "no"
RELEASE: "no"
WEEKLY: "no"
@@ -271,7 +271,7 @@ header-check:
lint:
stage: distrib
script:
- - ./nix/shell-checkers.sh "make -f share/Makefile.linting check-lint"
+ - ./nix/shell-checkers.sh "make -f share/Makefile.linting check-lint LINTCK_EXTRA=-s"
# Manuals
@@ -349,11 +349,12 @@ internal_nightly:
matrix:
- OCAML: ["4.14"]
-.build_template: &ocaml_manual_additional_versions_template
- parallel:
- matrix:
- - OCAML: ["4.12", "4.13"]
- when: manual
+# Uncomment this block when there are intermediate versions to check manully
+#.build_template: &ocaml_manual_additional_versions_template
+# parallel:
+# matrix:
+# - OCAML: ["4.14"]
+# when: manual
.build_template: &ocaml_versions_template
stage: compatibility
@@ -367,9 +368,10 @@ ocaml-versions:
except:
- schedules
-ocaml-versions-more:
- <<: *ocaml_versions_template
- <<: *ocaml_manual_additional_versions_template
+# Uncomment this section when there are additional versions of OCaml to test
+# ocaml-versions-more:
+# <<: *ocaml_versions_template
+# <<: *ocaml_manual_additional_versions_template
ocaml-versions-nightly:
<<: *ocaml_versions_template
@@ -388,7 +390,7 @@ ocaml-versions-nightly:
- sudo apt update
- opam pin . -n
- opam depext frama-c --with-test
- - opam install --jobs 2 frama-c --with-test
+ - opam install --jobs 2 frama-c --with-test --with-doc
- frama-c -version
tags:
- docker
diff --git a/ALL_VERSIONS b/ALL_VERSIONS
index 60647eed75411cc50829b0f82b679f697d190881..8a8ff94767995424b50f31dcd026971ae48a1dd3 100644
--- a/ALL_VERSIONS
+++ b/ALL_VERSIONS
@@ -1,5 +1,7 @@
Version number Date of release Notes
============== =============== =====
+27.1 (Cobalt) 2023, July, 18
+27.0 (Cobalt) 2023, June, 15
26.1 (Iron) 2023, February 15
26.0 (Iron) 2022, November 23
25.0 (Manganese) 2022, June 22
diff --git a/Changelog b/Changelog
index e619fceeedb77c384c4a7f965b2de3e7359104ff..a241d9295b7723d1ee7d85cb036598583542a103 100644
--- a/Changelog
+++ b/Changelog
@@ -18,6 +18,17 @@
Open Source Release <next-release>
###############################################################################
+o Kernel [2023-07-24] Expose Cil functions for type compatibility
+
+###############################################################################
+Open Source Release 27.1 (Cobalt)
+###############################################################################
+
+- Kernel [2023-07-17] New frama-c-script wrapper for make_machdep.py
+-* Ivette [2023-07-06] Fixes crash with multiple instances
+-* GUI [2023-07-05] Fixes freeze when a plugin aborts during splash screen
+-* GUI [2023-07-05] Fixes crash related to tags and undefined types
+
###############################################################################
Open Source Release 27.0 (Cobalt)
###############################################################################
diff --git a/VERSION b/VERSION
index c49dfde59ea4943a4fad4f6f08b7c34f0d01e99d..fac6b38be1992b6403d0b57c5db9d59cb5284938 100644
--- a/VERSION
+++ b/VERSION
@@ -1 +1 @@
-27.0+dev
+27.1+dev
diff --git a/bin/frama-c-script b/bin/frama-c-script
index 669573f5394d1bcd7cae750123a17f013204fbc8..3e2bfc9335f779c6637a22db14df6c23ffad0c30 100755
--- a/bin/frama-c-script
+++ b/bin/frama-c-script
@@ -279,6 +279,11 @@ case "$command" in
shift;
${FRAMAC_LIB}/analysis-scripts/creduce.sh "$@";
;;
+ "make-machdep")
+ shift;
+ ${FRAMAC_LIB}/make_machdep/make_machdep.py \
+ --machdep-schema ${FRAMAC_SHARE}/machdeps/machdep-schema.yaml "$@"
+ ;;
*)
echo "error: unrecognized command: $command";
exit 1
diff --git a/bin/git.sh b/bin/git.sh
index 72cbda5604975202cb1a517993d7d39c05722f57..e3bd5d34017fcfc3b61c088508906514787bce5e 100755
--- a/bin/git.sh
+++ b/bin/git.sh
@@ -35,18 +35,26 @@ then
echo " git.sh -h|--help"
echo " git.sh clone <repo> <dir>"
echo " git.sh remove <dir>"
- echo " git.sh <command>"
+ echo " git.sh exec <command...>"
+ echo " git.sh cat <file> <command...>"
+ echo " git.sh <command...>"
echo ""
- echo "The form 'git.sh clone <repo> <dir>' performs"
+ echo "Command 'git.sh clone <repo> <dir>' performs"
echo "an inner clone of <repo> inside <dir> sub-directory"
echo "and add <dir> to the excluded directories of the root."
echo ""
- echo "The form 'git.sh remove <dir>' removes the git"
+ echo "Command 'git.sh remove <dir>' removes the git"
echo "clone at <dir>, if any."
echo ""
+ echo "Command 'git.sh exec <command>' executes the given command"
+ echo "in each git repository."
+ echo ""
+ echo "Command 'git.sh cat <file> <command>' executes the given command"
+ echo "in each git repository and concat their output to the given file."
+ echo ""
echo "Otherwize, 'git.sh <command>' broadcast the command"
echo "to all '.git' repository accessible from the root."
- echo "The default command is 'git.sh status -s -b'."
+ echo "The default command is 'status -s -b'."
echo ""
exit 0
fi
@@ -94,6 +102,31 @@ then
ACTION="status -s -b"
fi
+if [ "$1" == "exec" ]
+then
+ shift
+ ROOT=`pwd`
+ COMMAND="$*"
+fi
+
+if [ "$1" == "cat" ]
+then
+ shift
+ ROOT=`pwd`
+ case $1 in
+ /*)
+ TARGET="$1"
+ ;;
+ *)
+ TARGET="$ROOT/$1"
+ ;;
+ esac
+ shift
+ COMMAND="$*"
+ rm -f $TARGET
+ touch $TARGET
+fi
+
for pgit in `find . -type d -name .git`
do
@@ -103,7 +136,21 @@ do
echo "-- Repository $plugin"
echo "--------------------------------------------------"
- git -C $plugin $ACTION
+ if [ "$COMMAND" != "" ]
+ then
+ cd $plugin
+ if [ "$TARGET" != "" ]
+ then
+ echo "$ $COMMAND >> $TARGET"
+ $COMMAND >> $TARGET
+ else
+ echo "$ $COMMAND"
+ $COMMAND
+ fi
+ cd $ROOT
+ else
+ git -C $plugin $ACTION
+ fi
done
echo "--------------------------------------------------"
diff --git a/bin/test.sh b/bin/test.sh
index 6faa03802ec431d776bdccf21c4d0c300117f360..ed3665e5275a347b93866410afd5b65b2d988038 100755
--- a/bin/test.sh
+++ b/bin/test.sh
@@ -24,6 +24,9 @@
THIS_SCRIPT="$0"
CONFIG="<all>"
VERBOSE=
+CLEAN=
+PREPARE=
+PULLCACHE=
UPDATE=
LOGS=
COMMIT=
@@ -34,7 +37,7 @@ DUNE_ALIAS=
DUNE_OPT=
DUNE_LOG=./.test-errors.log
ALIAS_NAME=ptests
-CACHEDIR=$(pwd -P)/.wp-cache
+LOCAL_WP_CACHE=$(pwd -P)/.wp-cache
FRAMAC_WP_CACHE_GIT=git@git.frama-c.com:frama-c/wp-cache.git
TEST_DIRS="tests/* src/plugins/*/tests/* src/kernel_internals/parsing/tests"
@@ -56,7 +59,7 @@ function Usage
echo " <DIR> all tests in <DIR>"
echo " <FILE> single test file <FILE>"
echo ""
- echo " -a|--all run all tests"
+ echo " -a|--all run all tests (default behavior)"
echo " -d|--default run tests from default config only"
echo " -c|--config <name> run tests from specified config only"
echo ""
@@ -67,25 +70,21 @@ function Usage
echo " -r|--clean clean (remove all) test results (includes -p)"
echo " -p|--ptests prepare (all) dune files"
echo " -w|--wp-cache prepare (pull) WP-cache"
- echo " -u|--wp-update update (pull+add) WP-cache"
echo " -l|--logs print output of tests (single file, no diff)"
- echo " -k|--commit commit results as oracles (single file, no diff)"
+ echo " -u|--update run tests and update oracles (and WP-cache)"
echo " -s|--save save dune logs into $DUNE_LOG"
echo " -v|--verbose print executed commands"
+ echo " -j|--jobs <jobs> Run no more than <jobs> commands simultaneously."
echo " -h|--help print this help"
echo ""
echo "VARIABLES"
echo ""
echo " FRAMAC_WP_CACHE"
- echo " Management mode of wp-cache ($FRAMAC_WP_CACHE)"
+ echo " Management mode of wp-cache (default is offline or update when -u)"
echo ""
echo " FRAMAC_WP_QUALIF"
echo " FRAMAC_WP_CACHEDIR"
- echo " Absolute path to wp-cache directory ($FRAMAC_WP_CACHEDIR)"
- if [ ! -d $FRAMAC_WP_CACHEDIR ]; then
- echo " About to clone from $FRAMAC_WP_CACHE_GIT"
- fi
- echo " Please, always push to master branch"
+ echo " Absolute path to wp-cache directory (git clone locally by default)"
echo ""
}
@@ -135,6 +134,79 @@ function RequiredTools
done
}
+# --------------------------------------------------------------------------
+# --- Command Line Processing
+# --------------------------------------------------------------------------
+
+while [ "$1" != "" ]
+do
+ case "$1" in
+ "-h"|"-help"|"--help")
+ Usage
+ exit 0
+ ;;
+ "-r"|"--clean")
+ CLEAN=yes
+ PREPARE=yes
+ ;;
+ "-p"|"--ptests")
+ PREPARE=yes
+ ;;
+ "-w"|"--wp-cache")
+ PULLCACHE=yes
+ ;;
+ "-u"|"--update")
+ DUNE_OPT+="--auto-promote "
+ UPDATE=yes
+ ;;
+ "-v"|"--verbose")
+ DUNE_OPT+="--display=short "
+ VERBOSE=yes
+ ;;
+ "-j"|"--jobs")
+ if [[ $2 == "auto" ]] || ([[ $2 != \-* ]] && [[ $2 -ge 1 ]]); then
+ DUNE_OPT+="-j $2 "
+ shift
+ else
+ ErrorUsage \
+ "wrong opt ('$2') for '-j|--jobs', value 'auto' or >= 1 expected"
+ fi
+ ;;
+ "-l"|"--logs")
+ LOGS=yes
+ ;;
+ "-k"|"--commit")
+ COMMIT=yes
+ ;;
+ "-s"|"--save" )
+ SAVE=yes
+ ;;
+ "-d"|"--default")
+ CONFIG="<default>"
+ ;;
+ "-c"|"--config")
+ CONFIG=$2
+ shift
+ ;;
+ "-n"|"--name")
+ ALIAS_NAME=$2
+ shift
+ ;;
+ "-a"|"--all")
+ TESTS=""
+ for dir in $TEST_DIRS ; do
+ if [ -d "$dir" ]; then
+ TESTS="$TESTS $dir"
+ fi
+ done
+ ;;
+ *)
+ TESTS+=" $1"
+ ;;
+ esac
+ shift
+done
+
# --------------------------------------------------------------------------
# --- WP Cache Environment
# --------------------------------------------------------------------------
@@ -142,16 +214,26 @@ function RequiredTools
function SetEnv
{
if [ "$FRAMAC_WP_CACHE" = "" ]; then
- export FRAMAC_WP_CACHE=offline
- Echo "Set FRAMAC_WP_CACHE=$FRAMAC_WP_CACHE"
+ if [ "$UPDATE" = "yes" ]; then
+ Head "FRAMAC_WP_CACHE=update"
+ export FRAMAC_WP_CACHE=update
+ else
+ export FRAMAC_WP_CACHE=offline
+ fi
+ else
+ if [ "$UPDATE" = "yes" ]; then
+ Head "FRAMAC_WP_CACHE=$FRAMAC_WP_CACHE (overrides -u)"
+ else
+ Head "FRAMAC_WP_CACHE=$FRAMAC_WP_CACHE"
+ fi
fi
if [ "$FRAMAC_WP_QUALIF" != "" ]; then
export FRAMAC_WP_CACHEDIR="$FRAMAC_WP_QUALIF"
- Echo "Set FRAMAC_WP_CACHEDIR=$FRAMAC_WP_CACHEDIR"
+ Echo "# FRAMAC_WP_CACHEDIR=$FRAMAC_WP_CACHEDIR"
elif [ "$FRAMAC_WP_CACHEDIR" = "" ]; then
- export FRAMAC_WP_CACHEDIR="$CACHEDIR"
- Echo "Set FRAMAC_WP_CACHEDIR=$FRAMAC_WP_CACHEDIR"
+ export FRAMAC_WP_CACHEDIR="$LOCAL_WP_CACHE"
+ Echo "# FRAMAC_WP_CACHEDIR=$FRAMAC_WP_CACHEDIR"
fi
[ ! -f "$FRAMAC_WP_CACHEDIR" ] || [ -d "$FRAMAC_WP_CACHEDIR" ] \
@@ -161,7 +243,6 @@ function SetEnv
/*);;
*) Error "Requires an absolute path to $FRAMAC_WP_CACHEDIR";;
esac
-
}
function CloneCache
@@ -175,10 +256,31 @@ function CloneCache
function PullCache
{
- CloneCache
- Head "Pull WP cache (to $FRAMAC_WP_CACHEDIR)..."
- RequiredTools git
- Run git -C $FRAMAC_WP_CACHEDIR pull --rebase
+ if [ "$PULLCACHE" = "yes" ]
+ then
+ CloneCache
+ Head "Pull WP cache (to $FRAMAC_WP_CACHEDIR)..."
+ RequiredTools git
+ Run git -C $FRAMAC_WP_CACHEDIR pull --rebase
+ fi
+}
+
+# --------------------------------------------------------------------------
+# --- Test Suite Preparation
+# --------------------------------------------------------------------------
+
+function PrepareTests
+{
+ if [ "$CLEAN" = "yes" ]
+ then
+ Head "Cleaning all tests..."
+ Cmd make clean-tests
+ fi
+ if [ "$PREPARE" = "yes" ]
+ then
+ Head "Generating dune files..."
+ Cmd make run-ptests
+ fi
}
# --------------------------------------------------------------------------
@@ -339,74 +441,15 @@ function Status
}
# --------------------------------------------------------------------------
-# --- Command Line Processing
+# --- Main Program
# --------------------------------------------------------------------------
SetEnv
-while [ "$1" != "" ]
-do
- case "$1" in
- "-h"|"-help"|"--help")
- Usage
- exit 0
- ;;
- "-r"|"--clean")
- Head "Cleaning all tests..."
- Cmd make clean-tests
- Head "Generating dune files..."
- Cmd make run-ptests
- ;;
- "-p"|"--ptests")
- Head "Generating dune files..."
- Cmd make run-ptests
- ;;
- "-w"|"--wp-cache")
- PullCache
- ;;
- "-u"|"--wp-update")
- PullCache
- FRAMAC_WP_CACHE=update
- UPDATE=yes
- ;;
- "-v"|"--verbose")
- DUNE_OPT+="--display=short"
- VERBOSE=yes
- ;;
- "-l"|"--logs")
- LOGS=yes
- ;;
- "-k"|"--commit")
- COMMIT=yes
- ;;
- "-s"|"--save" )
- SAVE=yes
- ;;
- "-d"|"--default")
- CONFIG="<default>"
- ;;
- "-c"|"--config")
- CONFIG=$2
- shift
- ;;
- "-n"|"--name")
- ALIAS_NAME=$2
- shift
- ;;
- "-a"|"--all")
- TESTS=""
- for dir in $TEST_DIRS ; do
- if [ -d "$dir" ]; then
- TESTS="$TESTS $dir"
- fi
- done
- ;;
- *)
- TESTS+=" $1"
- ;;
- esac
- shift
-done
+PullCache
+PrepareTests
Register $TESTS
RunAlias ${DUNE_ALIAS}
Commits ${COMMITS}
Status $DUNE_LOG
+
+# --------------------------------------------------------------------------
diff --git a/configurator.ml b/configurator.ml
index 82db7c709f0569284c40af9b90851a595a451383..4bf225310fb71852fd541c89f62742c9065f17fc 100644
--- a/configurator.ml
+++ b/configurator.ml
@@ -55,52 +55,69 @@ module Temp = struct (* Almost copied from configurator *)
try_name 0
end
-module C_compiler = struct (* This could be put in Dune? *)
+module C_preprocessor = struct (* This could be put in Dune? *)
type t =
- { compiler: string
+ { preprocessor: string
+ ; pp_opt: string option
; is_gnu: bool
}
- let find_compiler configurator =
- let cc_env = try Sys.getenv "CC" with Not_found -> "" in
- if cc_env <> "" then cc_env
+ let stdout_contains out str =
+ let re = Str.regexp_string str in
+ try ignore (Str.search_forward re out 0); true
+ with Not_found -> false
+
+ let find_preprocessor configurator =
+ let cc_env = try Sys.getenv "CPP" with Not_found -> "" in
+ if cc_env <> "" then (cc_env, None) (* assume default CPP needs no args *)
else
- let finder compiler = C.which configurator compiler |> Option.is_some in
- try List.find finder [ "gcc"; "cc"; "cl.exe" ]
- with Not_found -> C.die "Could not find a C compiler"
+ let finder (command, _pp_opt) =
+ C.which configurator command |> Option.is_some
+ in
+ (* Note: We could add 'cl.exe' to the list, but since it requires
+ '/<opt>' and not '-<opt>' for its options, it will fail in every
+ check anyway. So the user may manually specify it if they want it,
+ but having it here brings no benefit.
+ Note: 'cpp' is NOT the POSIX way to call the preprocessor, and it
+ behaves VERY badly on macOS (as if using '-traditional', see
+ https://stackoverflow.com/questions/9508159).
+ Therefore, we try `gcc -E` and `cc -E`, but not 'cpp'.
+ *)
+ try List.find finder [("gcc", Some "-E"); ("cc", Some "-E")]
+ with Not_found -> C.die "Could not find a C preprocessor"
let write_file name code =
let out = open_out name in
Printf.fprintf out "%s" code ;
close_out out
- let call configurator compiler options code =
+ let call configurator preprocessor options code =
let dir = Temp.create_dir () in
let file =
Temp.create ~dir ~suffix:".c" (fun name -> write_file name code) in
- C.Process.run configurator ~dir compiler (options @ [ file ])
-
+ C.Process.run configurator ~dir preprocessor (options @ [ file ])
- let preprocess_flag = "-E"
-
- let is_gnu configurator compiler =
- let code = {|#ifndef __GNUC__
- this is not a gnuc compiler
+ let is_gnu configurator preprocessor =
+ let code = {|#ifdef _FC_UNDEFINED_SYMBOL
+#error This should not remain after preprocessing
#endif
+int kept_after_preprocessing = 42;
|}
in
- (call configurator compiler ["-c"] code).exit_code = 0
+ (* GNU preprocessors are always compatible with '-E'.
+ For 'cpp', the '-E' flag is unnecessary, but still works. *)
+ let result = call configurator preprocessor ["-E"] code in
+ result.exit_code = 0 &&
+ stdout_contains result.stdout "kept_after_preprocessing" &&
+ not (stdout_contains result.stdout "should not remain")
let get configurator =
- let compiler = find_compiler configurator in
- let is_gnu = is_gnu configurator compiler in
- { compiler ; is_gnu }
-
- let preprocess configurator t options =
- call configurator t.compiler (preprocess_flag :: options)
+ let preprocessor, pp_opt = find_preprocessor configurator in
+ let is_gnu = is_gnu configurator preprocessor in
+ { preprocessor ; pp_opt; is_gnu }
- let _compile configurator t options =
- call configurator t.compiler ("-c" :: options)
+ let preprocess configurator t options code =
+ call configurator t.preprocessor (Option.to_list t.pp_opt @ options) code
end
(* Frama-C specific part *)
@@ -113,40 +130,39 @@ module Cpp = struct
int main(){}
|}
- let check configurator compiler =
+ let check configurator preprocessor =
let options = ["-dD" ; "-nostdinc"] in
- (C_compiler.preprocess configurator compiler options code).exit_code = 0
+ (C_preprocessor.preprocess configurator preprocessor options code).exit_code = 0
end
module KeepComments = struct
let code =
{|/* Check whether comments are kept in output */|}
- let check configurator compiler options =
- let result = C_compiler.preprocess configurator compiler options code in
- result.exit_code = 0 &&
- let re = Str.regexp_string "kept" in
- try ignore (Str.search_forward re result.stdout 0); true
- with Not_found -> false
+ let keep_comments_option = "-C"
+
+ let check configurator preprocessor =
+ let result = C_preprocessor.preprocess configurator preprocessor [keep_comments_option] code in
+ result.exit_code = 0 && C_preprocessor.stdout_contains result.stdout "kept"
end
module Archs = struct
let opt_m_code value =
Format.asprintf {|/* Check if preprocessor supports option -m%s */|} value
- let check configurator compiler arch =
+ let check configurator preprocessor arch =
let code = opt_m_code arch in
let options = [ Format.asprintf "-m%s" arch ] in
- if (C_compiler.preprocess configurator compiler options code).exit_code = 0
+ if (C_preprocessor.preprocess configurator preprocessor options code).exit_code = 0
then Some arch else None
- let supported_archs configurator compiler archs =
- let check = check configurator compiler in
+ let supported_archs configurator preprocessor archs =
+ let check = check configurator preprocessor in
List.map (fun s -> "-m" ^ s) @@ List.filter_map check archs
end
type t =
- { compiler : C_compiler.t
+ { preprocessor : C_preprocessor.t
; default_args : string list
; is_gnu_like : bool
; keep_comments : bool
@@ -154,13 +170,13 @@ int main(){}
}
let get configurator =
- let compiler = C_compiler.get configurator in
- let default_args = [ "-C" ; "-I." ] in
- let is_gnu_like = GnuLike.check configurator compiler in
- let keep_comments = KeepComments.check configurator compiler [ "-C" ] in
+ let preprocessor = C_preprocessor.get configurator in
+ let default_args = Option.to_list preprocessor.pp_opt @ [ "-C" ; "-I." ] in
+ let is_gnu_like = GnuLike.check configurator preprocessor in
+ let keep_comments = KeepComments.check configurator preprocessor in
let supported_archs_opts =
- Archs.supported_archs configurator compiler [ "16" ; "32" ; "64" ] in
- { compiler; default_args; is_gnu_like; keep_comments; supported_archs_opts }
+ Archs.supported_archs configurator preprocessor [ "16" ; "32" ; "64" ] in
+ { preprocessor; default_args; is_gnu_like; keep_comments; supported_archs_opts }
let pp_flags fmt =
let pp_sep fmt () = Format.fprintf fmt " " in
@@ -168,8 +184,8 @@ int main(){}
let pp_default_cpp fmt cpp =
Format.fprintf fmt "%s %a"
- cpp.compiler.compiler
- pp_flags (C_compiler.preprocess_flag :: cpp.default_args)
+ cpp.preprocessor.preprocessor
+ pp_flags cpp.default_args
let pp_archs fmt cpp =
let pp_arch fmt arch = Format.fprintf fmt "\"%s\"" arch in
diff --git a/dev/build-release.sh b/dev/build-release.sh
index 7aad889e2cba7fa9ecb4f6ffa46581a9aa168ae8..7fc2ba73fe5290e9662d8c110f51b6b0ea379394 100755
--- a/dev/build-release.sh
+++ b/dev/build-release.sh
@@ -274,7 +274,19 @@ OPAM_FC_DIR="$OPAM_DIR/packages/frama-c/frama-c.$VERSION"
mkdir -p $OPAM_DIR
mkdir -p $OPAM_FC_DIR
-cat opam | grep -v "^version\:" | grep -v "^name\:" > $OPAM_FC_DIR/opam
+OPAM_VERSION="opam-version: \"2.0\""
+if [ "$FINAL_RELEASE" = "yes" ]; then
+ OPAM_VERSION_FIX="$OPAM_VERSION"
+else
+ OPAM_VERSION_FIX="$OPAM_VERSION\navailable: opam-version >= \"2.1.0\"\nflags: avoid-version"
+fi
+
+cat opam \
+ | grep -v "^version\:" \
+ | grep -v "^name\:" \
+ | sed -e "s/$OPAM_VERSION/$OPAM_VERSION_FIX/" \
+ > $OPAM_FC_DIR/opam
+
cat >>$OPAM_FC_DIR/opam << EOL
url {
@@ -356,7 +368,7 @@ cat >$JSON_DATA <<EOL
]
},
EOL
-echo " \"description\": \"# Main changes since $PREVIOUS $PREVIOUS_NAME\n$(jq <"$CHANGES" --raw-input 'sub("^#";"##")' | jq --slurp 'join("\n")' | sed 's/^.//;s/.$//')" >> $JSON_DATA
+echo " \"description\": \"# Main changes since $PREVIOUS $PREVIOUS_NAME\n$(jq <"$CHANGES" --raw-input 'sub("^#";"##")' | jq --slurp 'join("\n")' | sed 's/^.//;s/.$//')\"" >> $JSON_DATA
echo "}" >> $JSON_DATA
echo "Release data file built"
diff --git a/doc/developer/advance.tex b/doc/developer/advance.tex
index 13357f76e11e74b919a909d9d7c617ccaf669c6e..ab2200361f82dd9c2b9e4ffe3e60fab98bf0ecb2 100644
--- a/doc/developer/advance.tex
+++ b/doc/developer/advance.tex
@@ -570,6 +570,12 @@ modify or disable test cases.
& \textit{None}
\\
\hline
+\texttt{ENABLED\_IF}\nscodeidxdef{Test!Directive}{ENABLED\_IF}
+& Conditionally enable subsequent tests, using Dune variables
+ (e.g. \verb|%{bin-available:gcc}|).
+& \texttt{true}
+\\
+\hline
\texttt{\underline{EXECNOW}}\nscodeidxdef{Test!Directive}{EXECNOW}
& Run a custom command.
& \textit{None}
diff --git a/doc/release/branch.tex b/doc/release/branch.tex
index 3c3f9d5943ddb7d0263b27b5b822b22dde8941a9..1435c0834bb20c9414df18d42d154987d0a59058 100644
--- a/doc/release/branch.tex
+++ b/doc/release/branch.tex
@@ -68,21 +68,32 @@ one.
\section{Version}
-Execute the script:
+On the new \texttt{stable} branch, execute the script:
\begin{verbatim}
./dev/set-version.sh NN.M # to be replaced with actual major/minor version
\end{verbatim}
This will:
\begin{itemize}
\item update the \texttt{Changelog}s
- \item update the changes in the manuals (excluding ACSL and E-ACSL references)
+ \item update the changes in the manuals \textbf{(excluding ACSL and E-ACSL references)}
\item update the \texttt{VERSION} and \texttt{VERSION\_CODENAME} files
- \item update the \texttt{opam} file
+ \item update the \texttt{opam} files (Frama-C, lint, hdrck)
\item update the API doc
\end{itemize}
-Merge the branch in \texttt{master} and add a commit to \texttt{master} by
-adding \texttt{"+dev"} in the \texttt{VERSION} file.
+Merge the \texttt{stable} branch in the \texttt{master} branch.
+
+On the \texttt{master} branch, execute the script:
+\begin{verbatim}
+ ./dev/set-version.sh dev
+\end{verbatim}
+This will:
+\begin{itemize}
+ \item update the \texttt{VERSION} file
+ \item update the \texttt{opam} files (Frama-C, lint, hdrck)
+\end{itemize}
+
+Commit this change and push.
\section{Copyright}
diff --git a/doc/release/validation.tex b/doc/release/validation.tex
index bc6ee9d90e10ef028896fa022a20e70cc9aea92c..05638d4a3f4679ad412f4c47c285421b9c4a76a7 100644
--- a/doc/release/validation.tex
+++ b/doc/release/validation.tex
@@ -37,7 +37,6 @@ Change version and codename in the following files:
\begin{itemize}
\item \texttt{ALL\_VERSIONS} (non-beta only)
\item \texttt{VERSION} (for beta releases, add suffix \texttt{\textasciitilde{}beta}, not \texttt{-beta})
- \item \texttt{VERSION\_CODENAME}
\item \texttt{opam}
\begin{itemize}
\item change version (for beta releases, add suffix \texttt{\textasciitilde{}beta}, not \texttt{-beta})
@@ -113,8 +112,9 @@ run of the following targets:
\begin{itemize}
\item manuals
\item opam-pin
+ \item opam-pin-minimal
\end{itemize}
-Both should succeed. Collect the artifacts of the following targets:
+They shall succeed. Collect the artifacts of the following targets:
\begin{itemize}
\item api-doc
\item build-distrib-tarball
@@ -187,6 +187,10 @@ of the website and the wiki page.
Create the version commit, tag it using \texttt{git tag \$(cat VERSION | sed -e "s/\textasciitilde /-/")}
and push it (e.g. via \texttt{git push origin \$(cat VERSION | sed -e "s/\textasciitilde/-/")}).
+\textbf{
+ If the tagged commit itself has not been pushed, remember to push it, else,
+ the release pipeline will fail.
+}
%%%Local Variables:
%%%TeX-master: "release"
diff --git a/ivette/src/dome/main/dome.ts b/ivette/src/dome/main/dome.ts
index 993f45c5bdd104cb3bbe59bad0220b97631643ca..fde22418299c5565e527a09fd89da3ff7a1edec8 100644
--- a/ivette/src/dome/main/dome.ts
+++ b/ivette/src/dome/main/dome.ts
@@ -483,18 +483,15 @@ function createBrowserWindow(
theWindow.off('close', closeHandler);
// Do not close the window yet
event.preventDefault();
-
+ // Save state
handle.frame = theWindow.getBounds();
handle.devtools = webContents.isDevToolsOpened();
- webContents.send('dome.ipc.closing');
+ // Start closing process
+ webContents.send('dome.ipc.closing', wid);
};
theWindow.on('close', closeHandler);
- ipcMain.on('dome.ipc.closing.done', () => {
- theWindow.close();
- });
-
// Keep track of frame positions (in DEVEL)
if (DEVEL) {
const saveFrame = _.debounce(() => {
@@ -509,6 +506,11 @@ function createBrowserWindow(
return theWindow;
}
+ipcMain.on('dome.ipc.closing.done', (_event, wid:number) => {
+ const handle = WindowHandles.get(wid);
+ if (handle !== undefined) handle.window.close();
+});
+
// --------------------------------------------------------------------------
// --- Application Window(s) & Command Line
// --------------------------------------------------------------------------
diff --git a/ivette/src/dome/renderer/dome.tsx b/ivette/src/dome/renderer/dome.tsx
index d05bbd025647811411d424b51848735991eb3992..07d8d0e2c23938c88e33202e92121b1f5ab03dcb 100644
--- a/ivette/src/dome/renderer/dome.tsx
+++ b/ivette/src/dome/renderer/dome.tsx
@@ -251,9 +251,9 @@ export const globalSettings = new Event(Settings.global);
// --- Closing
// --------------------------------------------------------------------------
-ipcRenderer.on('dome.ipc.closing', async () => {
+ipcRenderer.on('dome.ipc.closing', async (_event, wid: number) => {
await System.doExit();
- ipcRenderer.send('dome.ipc.closing.done');
+ ipcRenderer.send('dome.ipc.closing.done', wid);
});
/** Register a callback to be executed when the window is closing. */
diff --git a/ivette/src/frama-c/kernel/Properties.tsx b/ivette/src/frama-c/kernel/Properties.tsx
index 1e32d93af70b1e7c10f85fd7a94e6b938d906064..5be49e7b932d9f44dea7bd4ae0bd4fdbf2ed644b 100644
--- a/ivette/src/frama-c/kernel/Properties.tsx
+++ b/ivette/src/frama-c/kernel/Properties.tsx
@@ -627,7 +627,6 @@ function PropertyColumns(): JSX.Element {
<ColumnTag
id="status"
label="Status"
- fixed
width={100}
align="center"
getter={getStatus}
diff --git a/nix/frama-c.nix b/nix/frama-c.nix
index 34beab7c25ad1b93e0890ec9831a9b19430a5d17..4be82fb950a17b6a28b4a09c0c8834462f96c25d 100644
--- a/nix/frama-c.nix
+++ b/nix/frama-c.nix
@@ -44,6 +44,8 @@
, dos2unix
, doxygen
, python3
+, python3Packages
+, yq
, release_mode ? false
}:
@@ -103,6 +105,8 @@ stdenvNoCC.mkDerivation rec {
dos2unix
doxygen
python3
+ python3Packages.pyaml
+ yq
];
outputs = [ "out" "build_dir" ];
diff --git a/nix/internal-tests.nix b/nix/internal-tests.nix
index 34cf7a9b1e03adc0108942bad1ecc85fcd762175..bef1ffdc48e296581309ef715d9f971583fdf197 100644
--- a/nix/internal-tests.nix
+++ b/nix/internal-tests.nix
@@ -15,6 +15,7 @@
, apron
, camlzip
, camomile
+, clang
, dune_3
, dune-configurator
, dune-site
@@ -47,6 +48,8 @@
, perl
, pkgs
, python3
+, python3Packages
+, yq
, swiProlog
, time
, wp-cache
@@ -74,6 +77,7 @@ stdenvNoCC.mkDerivation rec {
alt-ergo
camlzip
camomile
+ clang
dune_3
dune-configurator
dune-site
@@ -107,6 +111,8 @@ stdenvNoCC.mkDerivation rec {
perl
pkgs.getopt
python3
+ python3Packages.pyaml
+ yq
swiProlog
time
];
diff --git a/nix/mk_tests.nix b/nix/mk_tests.nix
index 81813dc7c9dc5da640e9e654f22b8ea3b71a8106..d56dc7155dc3a698acb0d594c8197a887c152761 100644
--- a/nix/mk_tests.nix
+++ b/nix/mk_tests.nix
@@ -20,6 +20,7 @@
{ lib
, alt-ergo
+, clang
, frama-c
, perl
, stdenvNoCC
@@ -43,6 +44,7 @@ stdenvNoCC.mkDerivation {
sourceRoot = ".";
buildInputs = frama-c.buildInputs ++ [
+ clang
frama-c
perl
time
diff --git a/nix/pkgs.nix b/nix/pkgs.nix
index 8626523577646a6e5dc34237700cfa2a2ab4dde4..8f08f15e2ed2c3ad9c9f176c69dd830e48dae2a3 100644
--- a/nix/pkgs.nix
+++ b/nix/pkgs.nix
@@ -7,7 +7,6 @@ let
headache = oself.callPackage ./headache.nix {};
mlmpfr = oself.callPackage ./mlmpfr.nix {};
why3 = oself.callPackage ./why3.nix {};
- yaml = oself.callPackage ./yaml.nix {};
ppx_deriving_yaml = oself.callPackage ./ppx_deriving_yaml.nix {};
# Helpers
diff --git a/nix/ppx_deriving_yaml.nix b/nix/ppx_deriving_yaml.nix
index 44b6e980ae69201b348aad19bba59a2b4b905e85..4b1e177f30bea44777844c0b7cd2bce8ede92056 100644
--- a/nix/ppx_deriving_yaml.nix
+++ b/nix/ppx_deriving_yaml.nix
@@ -1,12 +1,11 @@
-{ lib, buildDunePackage, fetchurl, ppxlib, alcotest, mdx
-, ppx_deriving, yaml
-}:
+{ lib, buildDunePackage, fetchurl, ppxlib, alcotest, ppx_deriving, yaml }:
buildDunePackage rec {
pname = "ppx_deriving_yaml";
version = "0.2.1";
minimalOCamlVersion = "4.08";
+ duneVersion = "3";
src = fetchurl {
url = "https://github.com/patricoferris/ppx_deriving_yaml/releases/download/v${version}/ppx_deriving_yaml-${version}.tbz";
@@ -15,9 +14,6 @@ buildDunePackage rec {
propagatedBuildInputs = [ ppxlib ppx_deriving yaml ];
- doCheck = true;
- checkInputs = [ alcotest mdx ];
-
meta = {
description = "A YAML codec generator for OCaml";
homepage = "https://github.com/patricoferris/ppx_deriving_yaml";
diff --git a/nix/sources.json b/nix/sources.json
index 52d18208892086ed9f4900f4291307d4e9d6f9b8..f3366def7224ddf86cc72dba0203100ae2053299 100644
--- a/nix/sources.json
+++ b/nix/sources.json
@@ -29,10 +29,10 @@
"homepage": "https://github.com/NixOS/nixpkgs",
"owner": "NixOS",
"repo": "nixpkgs",
- "rev": "d231d18e4aa5e1d00f86b4f484f9e4344538e3ea",
- "sha256": "1ks9h2m6ns6b0wbw6x4cqaqwgfac1n51v3a8vygnm7ynq34ka2l1",
+ "rev": "f292b4964cb71f9dfbbd30dc9f511d6165cd109b",
+ "sha256": "01yzrkrb60dd2y2y3fh4939z374hf5pa92q8axfcygqlnbk3jpb4",
"type": "tarball",
- "url": "https://github.com/NixOS/nixpkgs/archive/d231d18e4aa5e1d00f86b4f484f9e4344538e3ea.tar.gz",
+ "url": "https://github.com/NixOS/nixpkgs/archive/f292b4964cb71f9dfbbd30dc9f511d6165cd109b.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"why3": {
diff --git a/nix/yaml.nix b/nix/yaml.nix
deleted file mode 100644
index bc8c7af164efc3768c615212b47da43ef5c8cfd5..0000000000000000000000000000000000000000
--- a/nix/yaml.nix
+++ /dev/null
@@ -1,32 +0,0 @@
-{ lib, fetchurl, buildDunePackage
-, dune-configurator
-, bos, ctypes, fmt, logs
-, mdx, alcotest, crowbar, junit_alcotest, ezjsonm
-}:
-
-buildDunePackage rec {
- pname = "yaml";
- version = "3.0.1";
-
- src = fetchurl {
- url = "https://github.com/avsm/ocaml-yaml/releases/download/v${version}/yaml-${version}.tbz";
- sha256 = "ku0bpClVmhS2tF4XDzSCGReR+ZrFGJpfIGEuFb+99pU=";
- };
-
- minimalOCamlVersion = "4.05.0";
-
- buildInputs = [ dune-configurator ];
- propagatedBuildInputs = [ bos ctypes ];
-
- doCheck = true;
- nativeCheckInputs = [ mdx.bin ];
- checkInputs = [ fmt logs alcotest crowbar junit_alcotest ezjsonm ];
-
- meta = {
- description = "Parse and generate YAML 1.1 files";
- homepage = "https://github.com/avsm/ocaml-yaml";
- license = lib.licenses.isc;
- maintainers = [ lib.maintainers.vbgl ];
- };
-
-}
diff --git a/opam b/opam
index 1483c4466ca49ad7bafddc56f46be8f6ac65b27e..8ccaa3669bc50deb9d57482d14938f8583ffb088 100644
--- a/opam
+++ b/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: "27.0+dev"
+version: "27.1+dev"
description:"""
Frama-C gathers several analysis techniques in a single collaborative
framework, based on analyzers (called "plug-ins") that can build upon the
@@ -53,6 +53,7 @@ authors: [
"Melody Méaulle"
"Benjamin Monate"
"Yannick Moy"
+ "Pierre Nigron"
"Anne Pacalet"
"Valentin Perrelle"
"Guillaume Petiot"
@@ -71,7 +72,7 @@ authors: [
homepage: "https://frama-c.com/"
license: "LGPL-2.1-only"
dev-repo: "git+https://git.frama-c.com/pub/frama-c.git"
-doc: "http://frama-c.com/download/user-manual-27.0-Cobalt.pdf"
+doc: "http://frama-c.com/download/user-manual-27.1-Cobalt.pdf"
bug-reports: "https://git.frama-c.com/pub/frama-c/issues"
tags: [
"deductive"
@@ -91,13 +92,18 @@ tags: [
build: [
["bash" "dev/disable-plugins.sh" "e-acsl"] { os-family = "windows" }
- ["dune" "build" "-j%{jobs}%" "--release" "--promote-install-files=false" "@install"]
- [make "-C" "doc" "download"] {with-doc}
+ ["dune" "build" "-j%{jobs}%" "--release" "--promote-install-files=false"
+ "@install"
+ "@doc" { with-doc }
+ ]
]
install: [
- [make "PREFIX=%{prefix}%" "MANDIR=%{mandir}%" "install"]
- [make "PREFIX=%{prefix}%" "-C" "doc" "install"] {with-doc}
+ [make
+ "RELEASE=yes" "PREFIX=%{prefix}%" "MANDIR=%{man}%"
+ "DOCDIR=%{doc}%" { with-doc }
+ "install"
+ ]
]
remove: [
@@ -120,8 +126,9 @@ depends: [
"conf-graphviz" { post }
"conf-time" { with-test }
"menhir" { >= "20181006" & build }
- "ocaml" { >= "4.11.1" }
+ "ocaml" { >= "4.13.1" }
"ocamlgraph" { >= "1.8.8" }
+ "odoc" { with-doc }
"unionFind" { >= "20220107" }
"why3" { >= "1.6.0" }
"yaml" { >= "3.0.0" }
diff --git a/reference-configuration.md b/reference-configuration.md
index a42c129d996338d181509daec2e1e9a241980e1d..b85304514189864476d23ecbdfc24428927afdeb 100644
--- a/reference-configuration.md
+++ b/reference-configuration.md
@@ -3,17 +3,14 @@ compiling Frama-C+dev.
- OCaml 4.13.1
- alt-ergo-free.2.2.0 (for wp, optional)
-- apron.v0.9.13 (for eva, optional)
- dune.3.5.0
- dune-configurator.3.5.0
- dune-site.3.5.0
-- lablgtk3.3.1.2
-- lablgtk3-sourceview3.3.1.2
+- lablgtk3.3.1.3
+- lablgtk3-sourceview3.3.1.3
- menhir.20211128
-- mlmpfr.4.1.0+bugfix2 (for eva, optional)
-- ocamlfind.1.9.5
+- ocamlfind.1.9.6
- ocamlgraph.2.0.0
-- ocp-indent.1.8.1 (for linting, optional)
- ppx_deriving_yaml.0.2.1
- ppx_deriving_yojson.3.7.0
- ppx_import.1.10.0
diff --git a/releases/27.1.md b/releases/27.1.md
new file mode 100644
index 0000000000000000000000000000000000000000..ebb9cb30038f6c510c78e9fd0d3ea9ce449e3406
--- /dev/null
+++ b/releases/27.1.md
@@ -0,0 +1,6 @@
+# Kernel
+- Fixes a crash and a freeze in the GTK GUI
+- Add a wrapper in `frama-c-script` for `make_machdep.py`
+
+# Ivette
+- Fixes a crash with multiple instances of Ivette
diff --git a/share/Makefile.documentation b/share/Makefile.documentation
index 47b6802b367e3fdc54fea9c2948a4f9d1df211d0..817de5190cb5f9692038652bbb5aa5bfadc48659 100644
--- a/share/Makefile.documentation
+++ b/share/Makefile.documentation
@@ -33,6 +33,14 @@ doc:
@echo "Generated Documentation:"
@echo " file:///$(PWD)/_build/default/_doc/_html/index.html"
+ifneq (${DOCDIR},)
+
+install:: doc
+ @mkdir -p ${DOCDIR}/frama-c
+ @cp -r _build/default/_doc/_html/* ${DOCDIR}/frama-c
+
+endif
+
##########################################################################
# #
# Generate Documentation for Server Requests and Protocols. #
@@ -41,7 +49,7 @@ doc:
.PHONY: server-doc-md server-doc-html server-doc
-ifeq (NO_BUILD_FRAMAC,yes)
+ifeq (${NO_BUILD_FRAMAC},yes)
# Make sure that Frama-C is not rebuilt essentially for CI purpose
server-doc-md:
else
diff --git a/share/analysis-scripts/build.py b/share/analysis-scripts/build.py
index 33c5ea5268bcde3224934f1f39cdb39579d3a9f6..a373e31c752c4b188bfa33e7e75f29a37d86adb5 100755
--- a/share/analysis-scripts/build.py
+++ b/share/analysis-scripts/build.py
@@ -366,7 +366,7 @@ for target, sources in sources_map.items():
main,
prettify(target),
)
- for (filename, line, _) in main_definitions[target]:
+ for filename, line, _ in main_definitions[target]:
print(f"- definition at {filename}:{line}")
# End of checks; start writing GNUmakefile and stubs from templates ###########
diff --git a/share/analysis-scripts/build_callgraph.py b/share/analysis-scripts/build_callgraph.py
index 1e19584263fa17e72a39295ed40a9090c498a195..d0b796e20dd2ee7ca7bc5b5c39455128e366f5e6 100755
--- a/share/analysis-scripts/build_callgraph.py
+++ b/share/analysis-scripts/build_callgraph.py
@@ -93,7 +93,7 @@ def compute(files):
def print_edge(cg: Callgraph, caller, called, padding="", end="\n") -> None:
locs = cg.edges[(caller, called)]
- for (filename, line) in locs:
+ for filename, line in locs:
print(
f"{padding}{os.path.relpath(filename)}:{line}: {caller} -> {called}",
end=end,
@@ -101,14 +101,14 @@ def print_edge(cg: Callgraph, caller, called, padding="", end="\n") -> None:
def print_cg(cg: Callgraph) -> None:
- for (caller, called) in cg.edges:
+ for caller, called in cg.edges:
print_edge(cg, caller, called)
# note: out _must_ exist (the caller must create it if needed)
def print_cg_dot(cg: Callgraph, out=sys.stdout) -> None:
print("digraph callgraph {", file=out)
- for (caller, called) in cg.edges:
+ for caller, called in cg.edges:
print(f" {caller} -> {called};", file=out)
print("}", file=out)
@@ -177,7 +177,7 @@ def detect_recursion(cg) -> None:
if cycle:
has_cycle = True
print("recursive cycle detected: ")
- for (caller, called) in cycle:
+ for caller, called in cycle:
print_edge(cg, caller, called, padding=" ")
to_visit -= visited
if not has_cycle:
diff --git a/share/analysis-scripts/estimate_difficulty.py b/share/analysis-scripts/estimate_difficulty.py
index 7e5af576871f38379a95dc129f8e00bf4bf862bf..a4fb891a9f0077da691860b6125ae3f5b88f42a2 100755
--- a/share/analysis-scripts/estimate_difficulty.py
+++ b/share/analysis-scripts/estimate_difficulty.py
@@ -176,7 +176,7 @@ with open(framac_share / "compliance" / "posix_identifiers.json", encoding="utf-
recursive_cycles: list[tuple[tuple[str, int], list[tuple[str, str]]]] = []
reported_recursive_pairs = set()
build_callgraph.compute_recursive_cycles(cg, recursive_cycles)
-for (cycle_start_loc, cycle) in recursive_cycles:
+for cycle_start_loc, cycle in recursive_cycles:
# Note: in larger code bases, many cycles are reported for the same final
# function (e.g. for the calls 'g -> g', we may have 'f -> g -> g',
# 'h -> g -> g', etc; to minimize this, we print just the first one.
@@ -188,7 +188,7 @@ for (cycle_start_loc, cycle) in recursive_cycles:
(filename, line) = cycle_start_loc
(x, y) = cycle[0]
pretty_cycle = f"{x} -> {y}"
- for (x, y) in cycle[1:]:
+ for x, y in cycle[1:]:
pretty_cycle += f" -> {y}"
print(f"[recursion] found recursive cycle near {filename}:{line}: {pretty_cycle}")
diff --git a/share/analysis-scripts/frama_c_results.py b/share/analysis-scripts/frama_c_results.py
index 241a1cbd361feca4d0f7902afd9ffa3e8a8cdb8f..e5d807b9805291086b394e459bdbb7bfeff09118 100644
--- a/share/analysis-scripts/frama_c_results.py
+++ b/share/analysis-scripts/frama_c_results.py
@@ -30,7 +30,7 @@ def load(filename):
try:
with open(filename, "r") as file:
content = file.read()
- for (key, value) in stat_file_re.findall(content):
+ for key, value in stat_file_re.findall(content):
data[key] = value
except OSError:
pass
diff --git a/share/analysis-scripts/function_finder.py b/share/analysis-scripts/function_finder.py
index 2c50fe7a5e467e73360cd3b67e4941b6d51b66cd..0ee97baef6321fcfb2e0b254933c40f2b6e37a08 100644
--- a/share/analysis-scripts/function_finder.py
+++ b/share/analysis-scripts/function_finder.py
@@ -53,6 +53,7 @@ argument_list = r"\([^)]*\)"
debug = os.getenv("DEBUG", False)
+
# Precomputes the regex for 'fname'
def prepare_re_specific_name(fname):
re_fun = re.compile(
@@ -106,6 +107,7 @@ def compute_re_def_or_decl(funcname):
# matches function calls
re_funcall = re.compile("(" + c_identifier + ")" + whitespace + r"\(")
+
# Computes the offset (in bytes) of each '\n' in the file,
# returning them as a list
def compute_newline_offsets(file_lines):
@@ -223,6 +225,7 @@ def find_definitions_and_declarations(
# list of identifiers which are never function calls
calls_blacklist = ["if", "while", "for", "return", "sizeof", "switch", "_Alignas"]
+
# Returns a list of tuples (fname, line, offset) for each function call.
#
# Note: this may include the function prototype itself;
@@ -246,7 +249,7 @@ def find_calls(file_content, newlines):
# [defs] must be sorted in ascending order.
def find_caller(defs, call):
(_called, line, offset) = call
- for (fname, _is_def, start, end, brace_offset) in defs:
+ for fname, _is_def, start, end, brace_offset in defs:
if start <= line <= end and offset > brace_offset:
return fname
elif start > line:
diff --git a/share/analysis-scripts/heuristic_list_functions.py b/share/analysis-scripts/heuristic_list_functions.py
index f3ce02728c6745eeed60db3b57f3fa9a8b32a588..2778f5b2111b7008f88a015ed185ebaf31b41c7a 100755
--- a/share/analysis-scripts/heuristic_list_functions.py
+++ b/share/analysis-scripts/heuristic_list_functions.py
@@ -59,7 +59,7 @@ for f in files:
defs_and_decls = function_finder.find_definitions_and_declarations(
want_defs, want_decls, f, file_content, file_lines, newlines
)
- for (funcname, is_def, start, end, _offset) in defs_and_decls:
+ for funcname, is_def, start, end, _offset in defs_and_decls:
if is_def:
print(f"{os.path.relpath(f)}:{start}:{end}: {funcname} (definition)")
else:
diff --git a/share/analysis-scripts/list_files.py b/share/analysis-scripts/list_files.py
index 14cf8de095176dfe218c63f10cfe055b8ac8a3ad..37e5a8bc7ffba6a2ebac8897df3aed5efa6dd32b 100755
--- a/share/analysis-scripts/list_files.py
+++ b/share/analysis-scripts/list_files.py
@@ -42,6 +42,7 @@ else:
if not arg.exists():
sys.exit(f"error: file '{arg}' not found")
+
# check if arg has a known extension
def is_known_c_extension(ext):
return ext in (".c", ".i", ".ci", ".h")
@@ -79,7 +80,7 @@ print("")
files_defining_main = set()
re_main = re.compile(r"(int|void)\s+main\s*\([^)]*\)\s*\{")
-for (fname, file_for_fcmake) in files:
+for fname, file_for_fcmake in files:
assert os.path.exists(fname), "file does not exist: %s" % fname
with open(fname, "r") as content_file:
content = content_file.read()
diff --git a/share/dune b/share/dune
index 77f771002d1b2e413dd411f13512b51fbf62f5b9..f00d3b92a5ed96459a035d8ca93acd082c366e9c 100644
--- a/share/dune
+++ b/share/dune
@@ -339,7 +339,9 @@
(machdeps/machdep_gcc_x86_32.yaml as share/machdeps/machdep_gcc_x86_32.yaml)
(machdeps/machdep_gcc_x86_64.yaml as share/machdeps/machdep_gcc_x86_64.yaml)
(machdeps/machdep_msvc_x86_64.yaml as share/machdeps/machdep_msvc_x86_64.yaml)
- (machdeps/machdep_ppc_32.yaml as share/machdeps/machdep_ppc_32.yaml))
+ (machdeps/machdep_ppc_32.yaml as share/machdeps/machdep_ppc_32.yaml)
+ (machdeps/machdep-schema.yaml as share/machdeps/machdep-schema.yaml)
+ )
)
; machdep generation script
@@ -368,9 +370,21 @@
(machdeps/make_machdep/alignof_str.c as lib/make_machdep/alignof_str.c)
(machdeps/make_machdep/char_is_unsigned.c as lib/make_machdep/char_is_unsigned.c)
(machdeps/make_machdep/const_string_literals.c as lib/make_machdep/const_string_literals.c)
+ (machdeps/make_machdep/errno.c as lib/make_machdep/errno.c)
(machdeps/make_machdep/has__builtin_va_list.c as lib/make_machdep/has__builtin_va_list.c)
+ (machdeps/make_machdep/int_fast16_t.c as lib/make_machdep/int_fast16_t.c)
+ (machdeps/make_machdep/int_fast32_t.c as lib/make_machdep/int_fast32_t.c)
+ (machdeps/make_machdep/int_fast64_t.c as lib/make_machdep/int_fast64_t.c)
+ (machdeps/make_machdep/int_fast8_t.c as lib/make_machdep/int_fast8_t.c)
+ (machdeps/make_machdep/intptr_t.c as lib/make_machdep/intptr_t.c)
+ (machdeps/make_machdep/limits_macros.c as lib/make_machdep/limits_macros.c)
(machdeps/make_machdep/little_endian.c as lib/make_machdep/little_endian.c)
+ (machdeps/make_machdep/make_machdep_common.h as lib/make_machdep/make_machdep_common.h)
+ (machdeps/make_machdep/nsig.c as lib/make_machdep/nsig.c)
+ (machdeps/make_machdep/posix_version.c as lib/make_machdep/posix_version.c)
(machdeps/make_machdep/ptrdiff_t.c as lib/make_machdep/ptrdiff_t.c)
+ (machdeps/make_machdep/sanity_check.c as lib/make_machdep/sanity_check.c)
+ (machdeps/make_machdep/sig_atomic_t.c as lib/make_machdep/sig_atomic_t.c)
(machdeps/make_machdep/sizeof_double.c as lib/make_machdep/sizeof_double.c)
(machdeps/make_machdep/sizeof_float.c as lib/make_machdep/sizeof_float.c)
(machdeps/make_machdep/sizeof_fun.c as lib/make_machdep/sizeof_fun.c)
@@ -382,6 +396,17 @@
(machdeps/make_machdep/sizeof_short.c as lib/make_machdep/sizeof_short.c)
(machdeps/make_machdep/sizeof_void.c as lib/make_machdep/sizeof_void.c)
(machdeps/make_machdep/size_t.c as lib/make_machdep/size_t.c)
+ (machdeps/make_machdep/ssize_t.c as lib/make_machdep/ssize_t.c)
+ (machdeps/make_machdep/stdio_macros.c as lib/make_machdep/stdio_macros.c)
+ (machdeps/make_machdep/stdlib_macros.c as lib/make_machdep/stdlib_macros.c)
+ (machdeps/make_machdep/time_t.c as lib/make_machdep/time_t.c)
+ (machdeps/make_machdep/uint_fast16_t.c as lib/make_machdep/uint_fast16_t.c)
+ (machdeps/make_machdep/uint_fast32_t.c as lib/make_machdep/uint_fast32_t.c)
+ (machdeps/make_machdep/uint_fast64_t.c as lib/make_machdep/uint_fast64_t.c)
+ (machdeps/make_machdep/uint_fast8_t.c as lib/make_machdep/uint_fast8_t.c)
+ (machdeps/make_machdep/uintptr_t.c as lib/make_machdep/uintptr_t.c)
(machdeps/make_machdep/wchar_t.c as lib/make_machdep/wchar_t.c)
- (machdeps/make_machdep/make_machdep_common.h as lib/make_machdep/make_machdep_common.h)
+ (machdeps/make_machdep/weof.c as lib/make_machdep/weof.c)
+ (machdeps/make_machdep/wint_t.c as lib/make_machdep/wint_t.c)
+ (machdeps/make_machdep/wordsize.c as lib/make_machdep/wordsize.c)
))
diff --git a/share/machdeps/machdep_avr_16.yaml b/share/machdeps/machdep_avr_16.yaml
index f5ee3f6c8487f9c21f3de15a75d7255d4ff617d8..055d78e85c3d33563175e3c2c5f2e8d3c2508b8a 100644
--- a/share/machdeps/machdep_avr_16.yaml
+++ b/share/machdeps/machdep_avr_16.yaml
@@ -16,6 +16,7 @@ cpp_arch_flags:
- -target
- avr
- -m16
+- -mmcu=atmega16
custom_defs: |
#undef AVR
#define AVR 1
@@ -33,6 +34,8 @@ custom_defs: |
#define __ATOMIC_SEQ_CST 5
#undef __AVR
#define __AVR 1
+ #undef __AVR_ATmega16__
+ #define __AVR_ATmega16__ 1
#undef __AVR__
#define __AVR__ 1
#undef __BIGGEST_ALIGNMENT__
@@ -645,6 +648,8 @@ custom_defs: |
#define __clang_version__ "15.0.7 "
#undef __clang_wide_literal_encoding__
#define __clang_wide_literal_encoding__ "UTF-16"
+ #undef __flash
+ #define __flash __attribute__((address_space(1)))
#undef __llvm__
#define __llvm__ 1
eof: (-1)
diff --git a/share/machdeps/machdep_avr_8.yaml b/share/machdeps/machdep_avr_8.yaml
index 9a9268a4d5590425281b29da80561ab9d037b8cd..cbaeb67bbd3b9626e1cba28f416efded67c9cd79 100644
--- a/share/machdeps/machdep_avr_8.yaml
+++ b/share/machdeps/machdep_avr_8.yaml
@@ -15,6 +15,7 @@ compiler: clang
cpp_arch_flags:
- -target
- avr
+- -mmcu=atmega8
custom_defs: |
#undef AVR
#define AVR 1
@@ -32,6 +33,8 @@ custom_defs: |
#define __ATOMIC_SEQ_CST 5
#undef __AVR
#define __AVR 1
+ #undef __AVR_ATmega8__
+ #define __AVR_ATmega8__ 1
#undef __AVR__
#define __AVR__ 1
#undef __BIGGEST_ALIGNMENT__
@@ -644,6 +647,8 @@ custom_defs: |
#define __clang_version__ "15.0.7 "
#undef __clang_wide_literal_encoding__
#define __clang_wide_literal_encoding__ "UTF-16"
+ #undef __flash
+ #define __flash __attribute__((address_space(1)))
#undef __llvm__
#define __llvm__ 1
eof: (-1)
diff --git a/share/machdeps/make_machdep/make_machdep.py b/share/machdeps/make_machdep/make_machdep.py
index bd0b6cefa82eeebfdbf575326681d26122018c34..c6045ab856a81cc991fbda527d32ca5648914719 100755
--- a/share/machdeps/make_machdep/make_machdep.py
+++ b/share/machdeps/make_machdep/make_machdep.py
@@ -49,8 +49,6 @@ from yaml.representer import Representer
my_path = Path(sys.argv[0]).parent
-logging.basicConfig(format="%(levelname)s: %(message)s")
-
parser = argparse.ArgumentParser(prog="make_machdep")
parser.add_argument("-v", "--verbose", action="store_true")
parser.add_argument("-o", type=argparse.FileType("w"), dest="dest_file")
@@ -61,6 +59,12 @@ parser.add_argument(
help="option to pass to the compiler to obtain its version; default is --version",
)
+parser.add_argument(
+ "--machdep-schema",
+ default="machdep-schema.yaml",
+ help="location of the schema file describing a machdep; default is 'machdep-schema.yaml'",
+)
+
parser.add_argument(
"--from-file",
help="reads compiler and arch flags from existing yaml file. Use -i to update it in place",
@@ -98,6 +102,11 @@ parser.add_argument(
args, other_args = parser.parse_known_args()
+if args.verbose:
+ logging.basicConfig(format="%(levelname)s: %(message)s", level=logging.INFO)
+else:
+ logging.basicConfig(format="%(levelname)s: %(message)s")
+
if not args.compiler_flags:
args.compiler_flags = ["-c"]
@@ -106,8 +115,7 @@ if not args.cpp_arch_flags:
def make_schema():
- schema_filename = my_path.parent / "machdep-schema.yaml"
- with open(schema_filename, "r") as schema:
+ with open(args.machdep_schema, "r") as schema:
return yaml.safe_load(schema)
@@ -275,11 +283,9 @@ def find_value(name, typ, output):
machdep[name] = value
else:
logging.warning(
- f"cannot find value of field '{name}', using default value: '{default}'"
+ f"cannot find value of field '{name}', using default value: '{default}'\ncompiler output is:\n{output}"
)
machdep[name] = default
- if args.verbose:
- print(f"compiler output is:{output}")
else:
logging.warning(f"unexpected symbol '{name}', ignoring")
@@ -331,9 +337,9 @@ for f, typ in source_files:
continue
if typ == "macro":
if proc.returncode != 0:
- logging.warning(f"error in preprocessing value '{p}', some values won't be filled")
- if args.verbose:
- print(f"compiler output is:{proc.stderr.decode()}")
+ logging.warning(
+ f"error in preprocessing value '{p}', some values won't be filled\ncompiler output is:\n{proc.stderr.decode()}"
+ )
name = p.stem
if name in machdep:
machdep[name] = ""
@@ -343,9 +349,9 @@ for f, typ in source_files:
if typ == "macrolist":
name = p.stem
if proc.returncode != 0:
- logging.warning(f"error in preprocessing value '{p}', some value might not be filled")
- if args.verbose:
- print(f"compiler output is:{proc.stderr.decode()}")
+ logging.warning(
+ f"error in preprocessing value '{p}', some values might not be filled\ncompiler output is:{proc.stderr.decode()}"
+ )
if name in machdep:
machdep[name] = {}
continue
@@ -416,9 +422,7 @@ if proc.returncode == 0:
lines += f"{line.strip()}\n"
machdep["custom_defs"] = custom_defs(lines)
else:
- logging.warning("could not determine predefined macros")
- if args.verbose:
- print(f"compiler output is:{proc.stderr}")
+ logging.warning(f"could not determine predefined macros. compiler output is:\n{proc.stderr}")
if args.from_file and args.in_place:
machdep["machdep_name"] = Path(args.from_file).stem
diff --git a/src/dune b/src/dune
index 599d3f7423ac6a0e1daba6de1ea8c204345e76e3..7cd55aa0b825af3628b942e63f2e0b5503c955a6 100644
--- a/src/dune
+++ b/src/dune
@@ -39,6 +39,7 @@
(echo " - dune-site.plugins:" %{lib-available:dune-site.plugins} "\n")
(echo " - ppx_import:" %{lib-available:ppx_import} "\n")
(echo " - ppx_deriving.eq:" %{lib-available:ppx_deriving.eq} "\n")
+ (echo " - ppx_deriving.ord:" %{lib-available:ppx_deriving.ord} "\n")
(echo " - ppx_deriving_yaml:" %{lib-available:ppx_deriving_yaml} "\n")
)
)
@@ -51,7 +52,7 @@
(flags :standard -w -9)
(libraries frama-c.init fpath str unix zarith ocamlgraph dynlink bytes yaml.unix yojson menhirLib dune-site dune-site.plugins)
(instrumentation (backend landmarks))
- (preprocess (staged_pps ppx_import ppx_deriving.eq ppx_deriving_yaml))
+ (preprocess (staged_pps ppx_import ppx_deriving.eq ppx_deriving.ord ppx_deriving_yaml))
)
(generate_sites_module (module config_data) (sites frama-c) (plugins (frama-c plugins) (frama-c plugins_gui)))
diff --git a/src/kernel_internals/parsing/logic_preprocess.mll b/src/kernel_internals/parsing/logic_preprocess.mll
index cd002187e43431277bc588b19294850edaff5c0e..02ed925af56edaf6bd9f2d163523963be355960a 100644
--- a/src/kernel_internals/parsing/logic_preprocess.mll
+++ b/src/kernel_internals/parsing/logic_preprocess.mll
@@ -122,14 +122,15 @@
let content = Buffer.create 80 in
let rec ignore_content () =
let s = input_line file in
- if not (Extlib.string_prefix annot_beg s) then ignore_content ()
+ if not (String.starts_with ~prefix:annot_beg s) then ignore_content ()
in
let rec get_annot first =
let s = input_line file in
- if Extlib.string_prefix annot_end s then false, Buffer.contents content
- else if Extlib.string_prefix annot_end_nl s then
+ if String.starts_with ~prefix:annot_end s then
+ false, Buffer.contents content
+ else if String.starts_with ~prefix:annot_end_nl s then
true, Buffer.contents content
- else if Extlib.string_prefix annot_end_comment s then begin
+ else if String.starts_with ~prefix:annot_end_comment s then begin
Buffer.add_char content '\n';
false, Buffer.contents content
end else begin
diff --git a/src/kernel_internals/runtime/fc_config.ml.in b/src/kernel_internals/runtime/fc_config.ml.in
index 6ac18e7a8e3d0617c4d11126c594cf2eead2973c..790125b2c8241464fb6008b05bff228637308511 100644
--- a/src/kernel_internals/runtime/fc_config.ml.in
+++ b/src/kernel_internals/runtime/fc_config.ml.in
@@ -63,7 +63,13 @@ let preprocessor = env_or_default (fun x -> x) default_cpp
let using_default_cpp = env_or_default (fun _ -> false) true
let preprocessor_is_gnu_like =
- env_or_default (fun _ -> false) @FRAMAC_GNU_CPP@
+ env_or_default
+ (fun _ ->
+ (* be more lenient when trying to determine if the preprocessor
+ is gnu-like: in Cygwin, for instance, CC is "<prefix>-gcc" but
+ CPP is "<prefix>-cpp", so this extra test allows proper detection. *)
+ let env = Sys.getenv "CC" ^ default_cpp_args in
+ env=default_cpp) @FRAMAC_GNU_CPP@
let preprocessor_supported_arch_options = [@DEFAULT_CPP_SUPPORTED_ARCH_OPTS@]
diff --git a/src/kernel_internals/typing/cabs2cil.ml b/src/kernel_internals/typing/cabs2cil.ml
index b6422e8030749d9da9814f232e4a68fa14bc868f..05f104b08484bb6ac8710710f55e482d15519b9a 100644
--- a/src/kernel_internals/typing/cabs2cil.ml
+++ b/src/kernel_internals/typing/cabs2cil.ml
@@ -333,7 +333,7 @@ let get_current_stdheader () =
let rec aux = function
| [] -> ""
| [ s ] -> s
- | s :: l when Extlib.string_prefix ~strict:true "__fc_" s -> aux l
+ | s :: l when String.starts_with ~prefix:"__fc_" s -> aux l
| s :: _ -> s
in
aux !current_stdheader
@@ -818,20 +818,7 @@ let get_formals vi =
let initGlobals () =
theFile := [];
theFileTypes := [];
- Cil_datatype.Varinfo.Hashtbl.clear theFileVars;
-;;
-
-let cabsPushGlobal (g: global) =
- pushGlobal g ~types:theFileTypes ~variables:theFile;
- (match g with
- | GVar (vi, _, _) | GVarDecl (vi, _)
- | GFun ({svar = vi}, _) | GFunDecl (_, vi, _) ->
- (* Do 'add' and not 'replace' here, as we may store both
- declarations and definitions for the same varinfo *)
- Cil_datatype.Varinfo.Hashtbl.add theFileVars vi g
- | _ -> ()
- );
-;;
+ Cil_datatype.Varinfo.Hashtbl.clear theFileVars
(* Keep track of some variable ids that must be turned into definitions. We
@@ -845,6 +832,8 @@ let mustTurnIntoDef: bool IH.t = IH.create 117
(* Globals that have already been defined. Indexed by the variable name. *)
let alreadyDefined: (string, location) H.t = H.create 117
+let isDefined vi = H.mem alreadyDefined vi.vorig_name
+
(* Globals that were created due to static local variables. We chose their
* names to be distinct from any global encountered at the time. But we might
* see a global with conflicting name later in the file. *)
@@ -876,6 +865,54 @@ let fileGlobals () =
revonto (revonto [] !theFile) !theFileTypes
+class checkGlobal = object
+ inherit nopCilVisitor
+
+
+ method! vglob = function
+ | GVar _ -> DoChildren
+ | _ -> SkipChildren
+
+ method! vexpr exp =
+ begin
+ match exp.enode with
+ | SizeOfE _ ->
+ (* sizeOf doesn't depend on the definitions *)
+ ()
+ | _ ->
+ let problematic_var : string option ref = ref None in
+ let is_varinfo_cst vi =
+ let res = Cil.isConstType vi.vtype && isDefined vi in
+ if not res then problematic_var := Some vi.vorig_name;
+ res
+ in
+ if not(isConstant ~is_varinfo_cst exp)
+ then
+ match !problematic_var with
+ | Some name ->
+ Kernel.error ~once:true ~current:true
+ ("%s is not a compile-time constant") name
+ | None ->
+ Kernel.error ~once:true ~current:true
+ "Initializer element is not a compile-time constant";
+ end;
+ SkipChildren
+
+end
+
+let cabsPushGlobal (g: global) =
+ ignore (visitCilGlobal (new checkGlobal) g);
+ pushGlobal g ~types:theFileTypes ~variables:theFile;
+ (match g with
+ | GVar (vi, _, _) | GVarDecl (vi, _)
+ | GFun ({svar = vi}, _) | GFunDecl (_, vi, _) ->
+ (* Do 'add' and not 'replace' here, as we may store both
+ declarations and definitions for the same varinfo *)
+ Cil_datatype.Varinfo.Hashtbl.add theFileVars vi g
+ | _ -> ()
+ )
+
+
(********* ENVIRONMENTS ***************)
(* The environment is kept in two distinct data structures. A hash table maps
@@ -2531,30 +2568,6 @@ let cabsAddAttributes al0 (al: attributes) : attributes =
al
al0
-type combineWhat =
- CombineFundef of bool
- (* The new definition is for a function definition. The old
- * is for a prototype. arg is [true] for an old-style declaration *)
- | CombineFunarg of bool
- (* Comparing a function argument type with an old prototype argument.
- arg is [true] for an old-style declaration, which
- triggers some ad hoc treatment in GCC mode. *)
- | CombineFunret (* Comparing the return of a function with that from an old
- * prototype *)
- | CombineOther
-
-(* [combineAttributes what olda a] combines the attributes in [olda] and [a]
- according to [what]:
- - if [what == CombineFunarg], then override old attributes;
- this is used to ensure that attributes from formal argument types in a
- function definition are not mixed with attributes from arguments in other
- (compatible, but with different qualifiers) declarations;
- - else, perform the union of old and new attributes. *)
-let combineAttributes what olda a =
- match what with
- | CombineFunarg _ -> a (* override old attributes with new ones *)
- | _ -> cabsAddAttributes olda a (* union of attributes *)
-
(* BY: nothing cabs here, plus seems to duplicate most of Cil.typeAddAttributes *)
(* see [combineAttributes] above for details about the [what] argument *)
let rec cabsTypeCombineAttributes what a0 t =
@@ -2642,266 +2655,11 @@ and cabsArrayPushAttributes what al = function
let cabsTypeAddAttributes =
cabsTypeCombineAttributes CombineOther
-exception Cannot_combine of string
(* Do types *)
-(* Combine the types. Raises the Cannot_combine exception with an error message.
- [what] is used to recursively deal with function return types and function
- arguments in special ways.
- Note: we cannot force the qualifiers of oldt and t to be the same here,
- because in some cases (e.g. string literals and char pointers) it is
- allowed to have differences, while in others we want to be more strict. *)
-let rec combineTypes ?(strictReturnTypes=false) (what: combineWhat) (oldt: typ) (t: typ) : typ =
- match oldt, t with
- | TVoid olda, TVoid a -> TVoid (combineAttributes what olda a)
- (* allows ignoring a returned value *)
- | _ , TVoid _ when what = CombineFunret && not strictReturnTypes -> t
- | TInt (oldik, olda), TInt (ik, a) ->
- let combineIK oldk k =
- if oldk = k then oldk else
- (match what with
- | CombineFunarg b when
- Cil.gccMode () && oldk = IInt
- && bytesSizeOf t <= (bytesSizeOfInt IInt) && b ->
- (* GCC allows a function definition to have a more precise integer
- * type than a prototype that says "int" *)
- k
- | _ ->
- raise (Cannot_combine
- (Format.asprintf
- "different integer types:@ '%a' and '%a'"
- Cil_printer.pp_ikind oldk Cil_printer.pp_ikind k)))
- in
- TInt (combineIK oldik ik, combineAttributes what olda a)
- | TFloat (oldfk, olda), TFloat (fk, a) ->
- let combineFK oldk k =
- if oldk = k then oldk else
- ( match what with
- | CombineFunarg b when
- Cil.gccMode () && oldk = FDouble && k = FFloat && b ->
- (* GCC allows a function definition to have a more precise float
- * type than a prototype that says "double" *)
- k
- | _ ->
- raise (Cannot_combine "different floating point types"))
- in
- TFloat (combineFK oldfk fk, combineAttributes what olda a)
- | TEnum (_, olda), TEnum (ei, a) ->
- TEnum (ei, combineAttributes what olda a)
-
- (* Strange one. But seems to be handled by GCC *)
- | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
- combineAttributes what olda a)
- (* Strange one. But seems to be handled by GCC *)
- | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, combineAttributes what olda a)
-
-
- | TComp (oldci, olda) , TComp (ci, a) ->
- if oldci.cstruct <> ci.cstruct then
- raise (Cannot_combine "different struct/union types");
- let comb_a = combineAttributes what olda a in
- if oldci.cname = ci.cname then
- TComp (oldci, comb_a)
- else
- raise (Cannot_combine (Format.sprintf "%ss with different tags"
- (if oldci.cstruct then "struct" else "union")))
-
- | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
- let newbt = combineTypes ~strictReturnTypes CombineOther oldbt bt in
- let newsz =
- match oldsz, sz with
- | None, Some _ -> sz
- | Some _, None -> oldsz
- | None, None -> sz
- | Some oldsz', Some sz' ->
- (* They are not structurally equal. But perhaps they are equal if we
- evaluate them. Check first machine independent comparison. *)
- let checkEqualSize (machdep: bool) =
- let size_t = Cil.theMachine.Cil.typeOfSizeOf in
- let size_t_oldsz' = Cil.mkCast ~force:false ~newt:size_t oldsz' in
- let size_t_sz' = Cil.mkCast ~force:false ~newt:size_t sz' in
- ExpStructEq.equal
- (constFold machdep size_t_oldsz')
- (constFold machdep size_t_sz')
- in
- if checkEqualSize false then
- oldsz
- else if checkEqualSize true then begin
- Kernel.warning ~current:true
- "Array type comparison succeeds only based on machine-dependent \
- constant evaluation: %a and %a\n"
- Cil_printer.pp_exp oldsz' Cil_printer.pp_exp sz';
- oldsz
- end else
- raise (Cannot_combine "different array lengths")
-
- in
- TArray (newbt, newsz, combineAttributes what olda a)
-
- | TPtr (oldbt, olda), TPtr (bt, a) ->
- TPtr (combineTypes ~strictReturnTypes CombineOther oldbt bt, combineAttributes what olda a)
-
- | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
- let newrt = combineTypes ~strictReturnTypes CombineFunret oldrt rt in
- if oldva != va then
- raise (Cannot_combine "different vararg specifiers");
- (* If one does not have arguments, believe the one with the
- * arguments *)
- let newargs, olda' =
- if oldargs = None then args, olda else
- if args = None then oldargs, olda else
- let (oldargslist, oldghostargslist) = argsToPairOfLists oldargs in
- let (argslist, ghostargslist) = argsToPairOfLists args in
- if List.length oldargslist <> List.length argslist then
- raise (Cannot_combine "different number of arguments")
- else if List.length oldghostargslist <> List.length ghostargslist then
- raise (Cannot_combine "different number of ghost arguments")
- else begin
- let oldargslist = oldargslist @ oldghostargslist in
- let argslist = argslist @ ghostargslist in
- (* Construct a mapping between old and new argument names. *)
- let map = H.create 5 in
- List.iter2
- (fun (on, _, _) (an, _, _) -> H.replace map on an)
- oldargslist argslist;
- (* Go over the arguments and update the old ones with the
- * adjusted types *)
- (* Format.printf "new type is %a@." Cil_datatype.Typ.pretty t; *)
- let what =
- match what with
- | CombineFundef b -> CombineFunarg b
- | _ -> CombineOther
- in
- Some
- (List.map2
- (fun (on, ot, oa) (an, at, aa) ->
- (* Update the names. Always prefer the new name. This is
- * very important if the prototype uses different names than
- * the function definition. *)
- let n = if an <> "" then an else on in
- let t = combineTypes ~strictReturnTypes what ot at in
- let a = addAttributes oa aa in
- (n, t, a))
- oldargslist argslist),
- olda
- end
- in
- (* Drop missingproto as soon as one of the type is a properly declared one*)
- let olda =
- if not (Cil.hasAttribute "missingproto" a) then
- Cil.dropAttribute "missingproto" olda'
- else olda'
- in
- let a =
- if not (Cil.hasAttribute "missingproto" olda') then
- Cil.dropAttribute "missingproto" a
- else a
- in
- TFun (newrt, newargs, oldva, combineAttributes what olda a)
-
- | TNamed (oldt, olda), TNamed (t, a) when oldt.tname = t.tname ->
- TNamed (oldt, combineAttributes what olda a)
-
- | TBuiltin_va_list olda, TBuiltin_va_list a ->
- TBuiltin_va_list (combineAttributes what olda a)
-
- (* Unroll first the new type *)
- | _, TNamed (t, a) ->
- let res = combineTypes what oldt t.ttype in
- cabsTypeCombineAttributes what a res
-
- (* And unroll the old type as well if necessary *)
- | TNamed (oldt, a), _ ->
- let res = combineTypes what oldt.ttype t in
- cabsTypeCombineAttributes what a res
-
- | _ -> raise (Cannot_combine
- (Format.asprintf "different type constructors:@ %a and %a"
- Cil_datatype.Typ.pretty oldt Cil_datatype.Typ.pretty t))
let get_qualifiers t = Cil.filter_qualifier_attributes (Cil.typeAttrs t)
-(* how type qualifiers must be checked *)
-type qualifier_check_context =
- | Identical (* identical qualifiers. *)
- | IdenticalToplevel (* ignore at toplevel, use Identical when going under a
- pointer. *)
- | Covariant (* first type can have const-qualifications
- the second doesn't have. *)
- | CovariantToplevel
- (* accepts everything for current type, use Covariant when going under a
- pointer. *)
- | Contravariant (* second type can have const-qualifications
- the first doesn't have. *)
- | ContravariantToplevel
- (* accepts everything for current type, use Contravariant when going under
- a pointer. *)
-
-let qualifier_context_fun_arg = function
- | Identical | IdenticalToplevel -> IdenticalToplevel
- | Covariant | CovariantToplevel -> ContravariantToplevel
- | Contravariant | ContravariantToplevel -> CovariantToplevel
-
-let qualifier_context_fun_ret = function
- | Identical | IdenticalToplevel -> IdenticalToplevel
- | Covariant | CovariantToplevel -> CovariantToplevel
- | Contravariant | ContravariantToplevel -> ContravariantToplevel
-
-let qualifier_context_ptr = function
- | Identical | IdenticalToplevel -> Identical
- | Covariant | CovariantToplevel -> Covariant
- | Contravariant | ContravariantToplevel -> Contravariant
-
-let included_qualifiers ?(context=Identical) a1 a2 =
- let a1 = Cil.filter_qualifier_attributes a1 in
- let a2 = Cil.filter_qualifier_attributes a2 in
- let a1 = Cil.dropAttribute "restrict" a1 in
- let a2 = Cil.dropAttribute "restrict" a2 in
- let a1_no_cv = Cil.dropAttributes ["const"; "volatile"] a1 in
- let a2_no_cv = Cil.dropAttributes ["const"; "volatile"] a2 in
- let is_equal = Cil_datatype.Attributes.equal a1 a2 in
- if is_equal then true
- else begin
- match context with
- | Identical -> false
- | Covariant -> Cil_datatype.Attributes.equal a1_no_cv a2
- | Contravariant -> Cil_datatype.Attributes.equal a1 a2_no_cv
- | CovariantToplevel | ContravariantToplevel | IdenticalToplevel -> true
- end
-
-(* precondition: t1 and t2 must be "compatible" as per combineTypes, i.e.
- you must have called [combineTypes t1 t2] before calling this function. *)
-let rec have_compatible_qualifiers_deep ?(context=Identical) t1 t2 =
- match unrollType t1, unrollType t2 with
- | TFun (tres1, Some args1, _, _), TFun (tres2, Some args2, _, _) ->
- have_compatible_qualifiers_deep
- ~context:(qualifier_context_fun_ret context) tres1 tres2 &&
- let context = qualifier_context_fun_arg context in
- List.for_all2 (fun (_, t1', a1) (_, t2', a2) ->
- have_compatible_qualifiers_deep ~context t1' t2' &&
- included_qualifiers ~context a1 a2)
- args1 args2
- | TPtr (t1', a1), TPtr (t2', a2)
- | TArray (t1', _, a1), TArray (t2', _, a2) ->
- (included_qualifiers ~context a1 a2) &&
- let context = qualifier_context_ptr context in
- have_compatible_qualifiers_deep ~context t1' t2'
- | _, _ -> included_qualifiers ~context (Cil.typeAttrs t1) (Cil.typeAttrs t2)
-
-let compatibleTypes ?strictReturnTypes ?context t1 t2 =
- let r = combineTypes ?strictReturnTypes CombineOther t1 t2 in
- (* C99, 6.7.3 §9: "... to be compatible, both shall have the identically
- qualified version of a compatible type;" *)
- if not (have_compatible_qualifiers_deep ?context t1 t2) then
- raise (Cannot_combine "different qualifiers");
- (* Note: different non-qualifier attributes will be silently dropped. *)
- r
-
-let areCompatibleTypes ?strictReturnTypes ?context t1 t2 =
- try
- ignore (compatibleTypes ?strictReturnTypes ?context t1 t2); true
- with Cannot_combine _ -> false
-
(* Specify whether the cast is from the source code *)
let rec castTo ?context ?(fromsource=false)
(ot : typ) (nt : typ) (e : exp) : (typ * exp ) =
@@ -8899,9 +8657,9 @@ and createGlobal ghost logic_spec ((t,s,b,attr_list) : (typ * storage * bool * C
if vi.vstorage = Extern then
vi.vstorage <- NoStorage; (* equivalent and canonical *)
- H.add alreadyDefined vi.vname (CurrentLoc.get ());
IH.remove mustTurnIntoDef vi.vid;
cabsPushGlobal (GVar(vi, {init = init}, CurrentLoc.get ()));
+ H.add alreadyDefined vi.vname (CurrentLoc.get ());
vi
end else begin
if not (isFunctionType vi.vtype) &&
@@ -9066,7 +8824,7 @@ and createLocal ghost ((_, sto, _, _) as specs)
let full_name =
(* Mangled symbols (that is, starting with '_Z') are unique by
construction. No need to add current function name as prefix. *)
- if Extlib.string_prefix ~strict:true "_Z" n
+ if String.starts_with ~prefix:"_Z" n && n <> "_Z"
then n
else !currentFunctionFDEC.svar.vname ^ "_" ^ n
in
diff --git a/src/kernel_internals/typing/mergecil.ml b/src/kernel_internals/typing/mergecil.ml
index 0ef1c773dbe80583e455cda43402ac07cdd8f31d..dd129eb2dbce0d9d995854f84a7922144b86964e 100644
--- a/src/kernel_internals/typing/mergecil.ml
+++ b/src/kernel_internals/typing/mergecil.ml
@@ -561,10 +561,6 @@ module ModelMerging =
Format.fprintf fmt "model@ %a@ { %s }" Cil_printer.pp_typ t s
end)
-let same_int64 e1 e2 =
- match constFoldToInt e1, constFoldToInt e2 with
- | Some i, Some i' -> Integer.equal i i'
- | _ -> false
let compare_int e1 e2 =
match (constFold true e1), (constFold true e2) with
@@ -959,217 +955,90 @@ let intEnumInfoNode =
EnumMerging.getNode eEq eSyn 0 intEnumInfo intEnumInfo
(Some (Cil_datatype.Location.unknown, 0))
-(* Combine the types. Raises the Failure exception with an error message.
- * isdef says whether the new type is for a definition *)
-type combineWhat =
- CombineFundef (* The new definition is for a function definition. The old
- * is for a prototype *)
- | CombineFunarg (* Comparing a function argument type with an old prototype
- * arg *)
- | CombineFunret (* Comparing the return of a function with that from an old
- * prototype *)
- | CombineOther
-
-let rec combineTypes (what: combineWhat)
- (oldfidx: int) (oldt: typ)
- (fidx: int) (t: typ) : typ =
- match oldt, t with
- | TVoid olda, TVoid a -> TVoid (addAttributes olda a)
- | TInt (oldik, olda), TInt (ik, a) ->
- let combineIK oldk k =
- if oldk == k
- then oldk
- else
- if bytesSizeOfInt oldk=bytesSizeOfInt k && isSigned oldk=isSigned k
- then
- (* the types contain the same sort of values but are not equal.
- For example on x86_16 machdep unsigned short and unsigned int. *)
- if rank oldk<rank k then k else oldk
- else
- (* GCC allows a function definition to have a more precise integer
- * type than a prototype that says "int" *)
- if Cil.gccMode () && oldk = IInt && bitsSizeOf t <= 32
- && (what = CombineFunarg || what = CombineFunret)
- then
- k
- else (
- let msg =
- Format.asprintf
- "different integer types %a and %a"
- Cil_printer.pp_typ oldt Cil_printer.pp_typ t
- in
- raise (Failure msg))
- in
- TInt (combineIK oldik ik, addAttributes olda a)
-
- | TFloat (oldfk, olda), TFloat (fk, a) ->
- let combineFK oldk k =
- if oldk == k then oldk else
- (* GCC allows a function definition to have a more precise integer
- * type than a prototype that says "double" *)
- if Cil.gccMode () && oldk = FDouble && k = FFloat &&
- (what = CombineFunarg || what = CombineFunret)
- then
- k
- else
- raise (Failure "different floating point types")
- in
- TFloat (combineFK oldfk fk, addAttributes olda a)
-
- | TEnum (oldei, olda), TEnum (ei, a) ->
- (* Matching enumerations always succeeds. But sometimes it maps both
- * enumerations to integers *)
- matchEnumInfo oldfidx oldei fidx ei;
- TEnum (oldei, addAttributes olda a)
-
-
- (* Strange one. But seems to be handled by GCC *)
- | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
- addAttributes olda a)
-
- (* Strange one. But seems to be handled by GCC. Warning. Here we are
- * leaking types from new to old *)
- | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, addAttributes olda a)
-
- | TComp (oldci, olda) , TComp (ci, a) ->
- matchCompInfo oldfidx oldci fidx ci;
- (* If we get here we were successful *)
- TComp (oldci, addAttributes olda a)
-
- | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
- let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in
- let combinesz =
- match oldsz, sz with
- None, Some _ -> sz
- | Some _, None -> oldsz
- | None, None -> oldsz
- | Some oldsz', Some sz' ->
- if same_int64 oldsz' sz' then oldsz else
- raise (Failure "different array sizes")
- in
- TArray (combbt, combinesz, addAttributes olda a)
-
- | TPtr (oldbt, olda), TPtr (bt, a) ->
- TPtr (combineTypes CombineOther oldfidx oldbt fidx bt,
- addAttributes olda a)
-
- | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
- let newrt =
- combineTypes
- (if what = CombineFundef then CombineFunret else CombineOther)
- oldfidx oldrt fidx rt
- in
- if oldva != va then
- raise (Failure "different vararg specifiers");
- (* If one does not have arguments, believe the one with the
- * arguments *)
- let newargs =
- if oldargs = None then args else
- if args = None then oldargs else
- let oldargslist = argsToList oldargs in
- let argslist = argsToList args in
- if List.length oldargslist <> List.length argslist then
- raise (Failure "different number of arguments")
- else begin
- (* Go over the arguments and update the old ones with the
- * adjusted types *)
- Some
- (List.map2
- (fun (on, ot, oa) (an, at, aa) ->
- let n = if an <> "" then an else on in
- let t =
- combineTypes
- (if what = CombineFundef then CombineFunarg
- else CombineOther)
- oldfidx ot fidx at
- in
- let a = addAttributes oa aa in
- (n, t, a))
- oldargslist argslist)
- end
- in
- let olda =
- if Cil.hasAttribute "missingproto" a then olda
- else Cil.dropAttribute "missingproto" olda
- in
- let a =
- if Cil.hasAttribute "missingproto" olda then a
- else Cil.dropAttribute "missingproto" a
- in
- TFun (newrt, newargs, oldva, addAttributes olda a)
-
- | TBuiltin_va_list olda, TBuiltin_va_list a ->
- TBuiltin_va_list (addAttributes olda a)
-
- | TNamed (oldt, olda), TNamed (t, a) ->
- matchTypeInfo oldfidx oldt fidx t;
- (* If we get here we were able to match *)
- TNamed(oldt, addAttributes olda a)
-
- (* Unroll first the new type *)
- | _, TNamed (t, a) ->
- let res = combineTypes what oldfidx oldt fidx t.ttype in
- typeAddAttributes a res
-
- (* And unroll the old type as well if necessary *)
- | TNamed (oldt, a), _ ->
- let res = combineTypes what oldfidx oldt.ttype fidx t in
- typeAddAttributes a res
-
- | _ -> (
- (* raise (Failure "different type constructors") *)
- let msg:string =
- Format.asprintf
- "different type constructors: %a vs. %a"
- Cil_printer.pp_typ oldt Cil_printer.pp_typ t
- in
- raise (Failure msg))
(* When comparing composite types for equality, we tolerate
some differences related to packed/aligned attributes:
if the offsets of each field are the same regardless of these
attributes, we allow them to merge (arbitrarily choosing whether
to keep or to drop such attributes). *)
-and equalModuloPackedAlign attrs1 attrs2 =
+let equalModuloPackedAlign attrs1 attrs2 =
let drop = Cil.dropAttributes ["packed"; "aligned"] in
equal_attributes_for_merge (drop attrs1) (drop attrs2)
+
+
(* Checks if fields [f1] and [f2] (contained in the composite types
[typ_ci1] and [typ_ci2] respectively) are equal except for
alignment-related attributes.
Raises [Failure] if the fields are not equivalent.
If [mustCheckOffsets] is true, then there is already a difference in the
composite type, so each field must be checked. *)
-and checkFieldsEqualModuloPackedAlign ~mustCheckOffsets f1 f2 =
+let checkFieldsEqualModuloPackedAlign ~mustCheckOffsets f1 f2 =
if f1.fbitfield <> f2.fbitfield then
raise (Failure "different bitfield info");
if mustCheckOffsets || not (equal_attributes_for_merge f1.fattr f2.fattr) then
(* different attributes: check if the difference is only due
to aligned/packed attributes, and if the offsets are the same,
in which case the difference may be safely ignored *)
- begin
- try
- let offs1, width1 = Cil.fieldBitsOffset f1
- and offs2, width2 = Cil.fieldBitsOffset f2
- in
- if not (equalModuloPackedAlign f1.fattr f2.fattr)
- || offs1 <> offs2 || width1 <> width2 then
- if mustCheckOffsets then
- let err = "incompatible attributes in composite types "
- ^ "and/or field " ^ f1.fname in
- raise (Failure err)
- else
- let err = "incompatible attributes for field " ^ f1.fname in
- raise (Failure err)
- with Not_found ->
- Kernel.fatal
- "field offset not found in table: %a or %a"
- Printer.pp_field f1 Printer.pp_field f2
- end
+ try
+ let offs1, width1 = Cil.fieldBitsOffset f1
+ and offs2, width2 = Cil.fieldBitsOffset f2
+ in
+ if not (equalModuloPackedAlign f1.fattr f2.fattr)
+ || offs1 <> offs2 || width1 <> width2 then
+ if mustCheckOffsets then
+ let err = "incompatible attributes in composite types and/or field "
+ ^ f1.fname in
+ raise (Failure err)
+ else
+ let err = "incompatible attributes for field " ^ f1.fname in
+ raise (Failure err)
+ with Not_found ->
+ Kernel.fatal
+ "field offset not found in table: %a or %a"
+ Printer.pp_field f1 Printer.pp_field f2
-(* Match two compinfos and throw a Failure if they do not match *)
-and matchCompInfo (oldfidx: int) (oldci: compinfo)
- (fidx: int) (ci: compinfo) : unit =
+let oldfidx = ref 0
+let fidx = ref 0
+
+(* Match two enuminfos and throw a Failure if they do not match *)
+let matchEnumInfoGen (oldei: enuminfo) (ei: enuminfo) : unit =
+ (* Find the node for this enum, no path compression. *)
+ let oldeinode = EnumMerging.getNode eEq eSyn !oldfidx oldei oldei None in
+ let einode = EnumMerging.getNode eEq eSyn !fidx ei ei None in
+ if oldeinode == einode then (* We already know they are the same *)
+ ()
+ else
+ (* Replace with the representative data *)
+ let oldei = oldeinode.ndata in
+ let ei = einode.ndata in
+ (* Try to match them. But if you cannot just make them both integers *)
+ try
+ have_same_enum_items oldei ei;
+ (* Set the representative *)
+ let newrep, _ = EnumMerging.union oldeinode einode in
+ (* We get here if the enumerations match *)
+ newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr
+ with (Cannot_combine msg | Failure msg) ->
+ let pp_items = Pretty_utils.pp_list ~pre:"{" ~suf:"}" ~sep:",@ "
+ (fun fmt item ->
+ Format.fprintf fmt "%s=%a" item.eiorig_name
+ Cil_printer.pp_exp item.eival)
+ in
+ if oldeinode != intEnumInfoNode && einode != intEnumInfoNode then
+ Kernel.warning
+ "@[merging definitions of enum %s using int type@ (%s);@ items %a and@ %a@]"
+ oldei.ename msg
+ pp_items oldei.eitems pp_items ei.eitems;
+ (* Get here if you cannot merge two enumeration nodes *)
+ if oldeinode != intEnumInfoNode then
+ ignore(EnumMerging.union oldeinode intEnumInfoNode);
+ if einode != intEnumInfoNode then
+ ignore(EnumMerging.union einode intEnumInfoNode)
+
+
+let matchCompInfoGen (combineF : combineFunction)
+ (oldci: compinfo) (ci: compinfo) : unit =
let cstruct = oldci.cstruct in
if cstruct <> ci.cstruct then
raise (Failure "different struct/union types");
@@ -1177,17 +1046,17 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo)
(* Make the nodes if not already made. Actually return the
* representatives *)
let oldcinode =
- PlainMerging.getNode sEq sSyn oldfidx oldci.cname oldci None
+ PlainMerging.getNode sEq sSyn !oldfidx oldci.cname oldci None
in
- let cinode = PlainMerging.getNode sEq sSyn fidx ci.cname ci None in
+ let cinode = PlainMerging.getNode sEq sSyn !fidx ci.cname ci None in
if oldcinode == cinode then (* We already know they are the same *)
()
- else begin
+ else
(* Replace with the representative data *)
let oldci = oldcinode.ndata in
- let oldfidx = oldcinode.nfidx in
+ oldfidx := oldcinode.nfidx;
let ci = cinode.ndata in
- let fidx = cinode.nfidx in
+ fidx := cinode.nfidx;
(* We check that they are defined in the same way. While doing this there
* might be recursion and we have to watch for going into an infinite
* loop. So we add the assumption that they are equal *)
@@ -1218,7 +1087,7 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo)
* old compinfo. *)
begin
try
- (* must_check_offsets indicates that composite type attributes are
+ (* mustCheckOffsets indicates that composite type attributes are
different, which may impact field offsets *)
let mustCheckOffsets =
if equal_attributes_for_merge ci.cattr oldci.cattr then false
@@ -1245,12 +1114,12 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo)
should be the same.
We do not force this for now, but could do it. *)
let newtype =
- combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype
- in
+ combineF.typ_combine combineF true
+ CombineOther oldf.ftype f.ftype in
(* Change the type in the representative *)
oldf.ftype <- newtype)
oldfields fields
- with Failure reason ->
+ with (Cannot_combine reason | Failure reason) ->
(* Our assumption was wrong. Forget the isomorphism *)
undo ();
let fields_old =
@@ -1295,90 +1164,95 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo)
(* We get here when we succeeded checking that they are equal, or one of
* them was empty *)
newrep.ndata.cattr <- addAttributes oldci.cattr ci.cattr
- end
-
-(* Match two enuminfos and throw a Failure if they do not match *)
-and matchEnumInfo (oldfidx: int) (oldei: enuminfo)
- (fidx: int) (ei: enuminfo) : unit =
- (* Find the node for this enum, no path compression. *)
- let oldeinode = EnumMerging.getNode eEq eSyn oldfidx oldei oldei None
- in
- let einode = EnumMerging.getNode eEq eSyn fidx ei ei None in
- if oldeinode == einode then (* We already know they are the same *)
- ()
- else begin
- (* Replace with the representative data *)
- let oldei = oldeinode.ndata in
- let ei = einode.ndata in
- (* Try to match them. But if you cannot just make them both integers *)
- try
- have_same_enum_items oldei ei;
- (* Set the representative *)
- let newrep, _ = EnumMerging.union oldeinode einode in
- (* We get here if the enumerations match *)
- newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr;
- ()
- with Failure msg -> begin
- let pp_items = Pretty_utils.pp_list ~pre:"{" ~suf:"}" ~sep:",@ "
- (fun fmt item ->
- Format.fprintf fmt "%s=%a" item.eiorig_name
- Cil_printer.pp_exp item.eival)
- in
- if oldeinode != intEnumInfoNode && einode != intEnumInfoNode then
- Kernel.warning
- "@[merging definitions of enum %s using int type@ (%s);@ items %a and@ %a@]"
- oldei.ename msg
- pp_items oldei.eitems pp_items ei.eitems;
- (* Get here if you cannot merge two enumeration nodes *)
- if oldeinode != intEnumInfoNode then begin
- let _ = EnumMerging.union oldeinode intEnumInfoNode in ()
- end;
- if einode != intEnumInfoNode then begin
- let _ = EnumMerging.union einode intEnumInfoNode in ()
- end;
- end
- end
(* Match two typeinfos and throw a Failure if they do not match *)
-and matchTypeInfo (oldfidx: int) (oldti: typeinfo)
- (fidx: int) (ti: typeinfo) : unit =
+let matchTypeInfoGen (combineF : combineFunction)
+ (oldti: typeinfo) (ti: typeinfo) : unit =
if oldti.tname = "" || ti.tname = "" then
Kernel.fatal "matchTypeInfo for anonymous type";
(* Find the node for this enum, no path compression. *)
- let oldtnode = PlainMerging.getNode tEq tSyn oldfidx oldti.tname oldti None in
- let tnode = PlainMerging.getNode tEq tSyn fidx ti.tname ti None in
+ let oldtnode = PlainMerging.getNode tEq tSyn !oldfidx oldti.tname oldti None in
+ let tnode = PlainMerging.getNode tEq tSyn !fidx ti.tname ti None in
if oldtnode == tnode then (* We already know they are the same *)
()
- else begin
+ else
(* Replace with the representative data *)
let oldti = oldtnode.ndata in
- let oldfidx = oldtnode.nfidx in
+ oldfidx := oldtnode.nfidx;
let ti = tnode.ndata in
- let fidx = tnode.nfidx in
+ fidx := tnode.nfidx;
(* Check that they are the same *)
(try
- ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype);
- with Failure reason -> begin
- let msg =
- let oldname = oldti.tname in
- let name = ti.tname in
- if oldname = name
- then
- Format.sprintf
- "Definitions of type %s are not isomorphic. \
- Reason follows:@\n@?%s"
- oldname reason
- else
- Format.sprintf
- "Types %s and %s are not isomorphic. Reason follows:@\n@?%s"
- oldname name reason
- in
- raise (Failure msg)
- end);
- let _ = union oldtnode tnode in
- ()
- end
+ ignore (combineF.typ_combine combineF true
+ CombineOther oldti.ttype ti.ttype);
+ with (Cannot_combine reason | Failure reason) ->
+ let msg =
+ let oldname = oldti.tname in
+ let name = ti.tname in
+ if oldname = name
+ then
+ Format.sprintf
+ "Definitions of type %s are not isomorphic. \
+ Reason follows:@\n@?%s"
+ oldname reason
+ else
+ Format.sprintf
+ "Types %s and %s are not isomorphic. Reason follows:@\n@?%s"
+ oldname name reason
+ in
+ raise (Failure msg));
+ ignore(union oldtnode tnode)
+
+let conflict_detected = ref false
+
+let combines = {
+ typ_combine = (fun combF b what oldt t ->
+ let find_names_file = H.find fileNames in
+ let old_file = find_names_file !oldfidx in
+ let new_file = find_names_file !fidx in
+ let old_name_file = Filepath.Normalized.to_pretty_string old_file in
+ let new_name_file = Filepath.Normalized.to_pretty_string new_file in
+ let pre_msg = "Conflicting definitions are between files "^
+ old_name_file^" and "^new_name_file in
+ let emitwith _ =
+ if (not !conflict_detected) && oldfidx <> fidx
+ then
+ begin
+ conflict_detected := true;
+ Kernel.warning
+ ~wkey:Kernel.wkey_merge_conversion
+ "%s" pre_msg
+ end
+ in
+ combineTypesGen ~emitwith
+ combF ~strictInteger:false ~strictReturnTypes:b
+ what oldt t);
+ enum_combine = (fun _ oldei ei ->
+ matchEnumInfoGen oldei ei;
+ oldei);
+ comp_combine = (fun c oldci ci ->
+ matchCompInfoGen c oldci ci;
+ oldci);
+ name_combine = (fun c _ oldti ti ->
+ matchTypeInfoGen c oldti ti;
+ oldti);
+}
+
+let setFidCall f oldfid oldt fid t =
+ oldfidx := oldfid;
+ fidx := fid;
+ f oldt t
+
+let matchEnumInfo = setFidCall matchEnumInfoGen
+
+let matchCompInfo = setFidCall (matchCompInfoGen combines)
+
+let matchTypeInfo = setFidCall (matchTypeInfoGen combines)
+
+let combineTypes what = setFidCall (combines.typ_combine combines true what)
+
+(* Match two compinfos and throw a Failure if they do not match *)
let update_compinfo ci =
let node =
@@ -1701,7 +1575,7 @@ let oneFilePass1 (f:file) : unit =
combineTypes CombineOther
oldvinode.nfidx oldvi.vtype
!currentFidx vi.vtype, fst (union oldvinode vinode);
- with (Failure reason) -> begin
+ with (Cannot_combine reason | Failure reason) -> begin
(* If one of the variable is currently unused, we can ignore it.
If both are unused and only one is defined, we keep this one.
Otherwise, we keep the old variable by default. *)
diff --git a/src/kernel_services/abstract_interp/eva_types.ml b/src/kernel_services/abstract_interp/eva_types.ml
new file mode 100644
index 0000000000000000000000000000000000000000..229782bc556f4a22fe3107eb5a01799935788973
--- /dev/null
+++ b/src/kernel_services/abstract_interp/eva_types.ml
@@ -0,0 +1,188 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2023 *)
+(* 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 stable_hash x = Hashtbl.seeded_hash 0 x
+
+let dkey_callstack = Kernel.register_category "callstack"
+
+module Callstack =
+struct
+ module Thread = Int (* Threads are identified by integers *)
+ module Kf = Kernel_function
+ module Stmt = Cil_datatype.Stmt
+ module Var = Cil_datatype.Varinfo
+
+ module Call = Datatype.Pair_with_collections(Kf)(Stmt)
+ (struct let module_name = "Eva.Callstack.Call" end)
+
+ module Calls = Datatype.List (Call)
+
+ type callstack = {
+ thread: int;
+ entry_point: Kernel_function.t;
+ stack: Call.t list;
+ }
+
+ module Prototype =
+ struct
+ include Datatype.Serializable_undefined
+
+ type t = callstack = {
+ thread: int;
+ entry_point: Kernel_function.t;
+ stack: Call.t list;
+ }
+ [@@deriving eq, ord]
+
+ let name = "Eva.Callstack"
+
+ let reprs =
+ List.concat_map (fun stack ->
+ List.map (fun entry_point -> { thread = 0; entry_point; stack })
+ Kernel_function.reprs)
+ Calls.reprs
+
+ let pretty fmt cs =
+ let pp_call fmt (kf,stmt) =
+ Format.fprintf fmt "%a :: %a <-@ "
+ Kf.pretty kf
+ Cil_datatype.Location.pretty (Stmt.loc stmt)
+ in
+ Format.fprintf fmt "@[<hv>";
+ List.iter (pp_call fmt) cs.stack;
+ Format.fprintf fmt "%a@]" Kernel_function.pretty cs.entry_point
+
+ let hash cs =
+ Hashtbl.hash
+ (cs.thread, Kernel_function.hash cs.entry_point, Calls.hash cs.stack)
+ end
+
+ type call = Call.t
+
+ include Datatype.Make_with_collections (Prototype)
+
+ let pretty_debug = pretty
+
+ let compare_lex cs1 cs2 =
+ if cs1 == cs2 then 0 else
+ let c = Thread.compare cs1.thread cs2.thread in
+ if c <> 0 then c else
+ let c = Kernel_function.compare cs1.entry_point cs2.entry_point in
+ if c <> 0 then c else
+ Calls.compare (List.rev cs1.stack) (List.rev cs2.stack)
+
+ (* Stack manipulation *)
+
+ let init ?(thread=0) kf = { thread; entry_point=kf; stack = [] }
+
+ let push kf stmt cs =
+ { cs with stack = (kf, stmt) :: cs.stack }
+
+ let pop cs =
+ match cs.stack with
+ | [] -> None
+ | _ :: tail -> Some { cs with stack = tail }
+
+ let top cs =
+ match cs.stack with
+ | [] -> None
+ | (kf, stmt) :: _ -> Some (kf, stmt)
+
+ let top_kf cs =
+ match cs.stack with
+ | (kf, _stmt) :: _ -> kf
+ | [] -> cs.entry_point
+
+ let top_callsite cs =
+ match cs.stack with
+ | [] -> Cil_types.Kglobal
+ | (_kf, stmt) :: _ -> Cil_types.Kstmt stmt
+
+ let top_call cs =
+ match cs.stack with
+ | (kf, stmt) :: _ -> kf, Cil_types.Kstmt stmt
+ | [] -> cs.entry_point, Cil_types.Kglobal
+
+ let top_caller cs =
+ match cs.stack with
+ | _ :: (kf, _) :: _ -> Some kf
+ | [_] -> Some cs.entry_point
+ | [] -> None
+
+ (* Conversion *)
+
+ let to_kf_list cs = cs.entry_point :: List.rev_map fst cs.stack
+ let to_stmt_list cs = List.rev_map snd cs.stack
+
+ let to_call_list cs =
+ let l =
+ List.rev_map (fun (kf, stmt) -> (kf, Cil_types.Kstmt stmt)) cs.stack
+ in
+ (cs.entry_point, Cil_types.Kglobal) :: l
+
+ (* Stable hash and pretty-printing *)
+
+ let stmt_hash s =
+ let pos = fst (Cil_datatype.Stmt.loc s) in
+ stable_hash (pos.Filepath.pos_path, pos.Filepath.pos_lnum)
+
+ let kf_hash kf = stable_hash (Kernel_function.get_name kf)
+
+ let rec calls_hash = function
+ | [] -> 0
+ | (kf, stmt) :: tl -> stable_hash (kf_hash kf, stmt_hash stmt, calls_hash tl)
+
+ let stable_hash { thread; entry_point; stack } =
+ let p = stable_hash (thread, kf_hash entry_point, calls_hash stack) in
+ p mod 11_316_496 (* 58 ** 4 *)
+
+ let base58_map = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
+
+ (* Converts [i] into a fixed-length, 4-wide string in base-58 *)
+ let base58_of_int n =
+ let buf = Bytes.create 4 in
+ Bytes.set buf 0 (String.get base58_map (n mod 58));
+ let n = n / 58 in
+ Bytes.set buf 1 (String.get base58_map (n mod 58));
+ let n = n / 58 in
+ Bytes.set buf 2 (String.get base58_map (n mod 58));
+ let n = n / 58 in
+ Bytes.set buf 3 (String.get base58_map (n mod 58));
+ Bytes.to_string buf
+
+ let pretty_hash fmt callstack =
+ if Kernel.is_debug_key_enabled dkey_callstack then
+ Format.fprintf fmt "<%s> " (base58_of_int (stable_hash callstack))
+ else Format.ifprintf fmt ""
+
+ let pretty_short fmt callstack =
+ Format.fprintf fmt "%a" pretty_hash callstack;
+ let list = List.rev (to_kf_list callstack) in
+ Pretty_utils.pp_flowlist ~left:"" ~sep:" <- " ~right:""
+ (fun fmt kf -> Kernel_function.pretty fmt kf)
+ fmt list
+
+ let pretty fmt callstack =
+ Format.fprintf fmt "@[<hv>%a" pretty_hash callstack;
+ pretty fmt callstack;
+ Format.fprintf fmt "@]"
+end
diff --git a/src/plugins/callgraph/gui/cg_viewer.mli b/src/kernel_services/abstract_interp/eva_types.mli
similarity index 52%
rename from src/plugins/callgraph/gui/cg_viewer.mli
rename to src/kernel_services/abstract_interp/eva_types.mli
index fae5d3d1a3c51da3c1c58b8e97957a3615a72222..d5406e1d64876766c4d68ce28d7ca537e70e4539 100644
--- a/src/plugins/callgraph/gui/cg_viewer.mli
+++ b/src/kernel_services/abstract_interp/eva_types.mli
@@ -20,4 +20,44 @@
(* *)
(**************************************************************************)
-(** Extension of the Frama-C GUI for the plugin. Nothing is exported. *)
+(** This module is here for compatibility reasons only and will be removed in
+ future versions. Use [Eva.Callstack] instead *)
+
+module Callstack :
+sig
+ type call = Cil_types.kernel_function * Cil_types.stmt
+
+ module Call : Datatype.S with type t = call
+
+ type callstack = {
+ thread: int;
+ entry_point: Cil_types.kernel_function;
+ stack: call list;
+ }
+
+ include Datatype.S_with_collections with type t = callstack
+
+ val pretty_hash : Format.formatter -> t -> unit
+ val pretty_short : Format.formatter -> t -> unit
+ val pretty_debug : Format.formatter -> t -> unit
+
+ val compare_lex : t -> t -> int
+
+ val init : ?thread:int -> Cil_types.kernel_function -> t
+
+ val push : Cil_types.kernel_function -> Cil_types.stmt -> t -> t
+ val pop : t -> t option
+ val top : t -> (Cil_types.kernel_function * Cil_types.stmt) option
+ val top_kf : t -> Cil_types.kernel_function
+ val top_callsite : t -> Cil_types.kinstr
+ val top_call : t -> Cil_types.kernel_function * Cil_types.kinstr
+ val top_caller : t -> Cil_types.kernel_function option
+
+ val to_kf_list : t -> Cil_types.kernel_function list
+ val to_stmt_list : t -> Cil_types.stmt list
+ val to_call_list : t -> (Cil_types.kernel_function * Cil_types.kinstr) list
+end
+[@@alert db_deprecated
+ "Eva_types is only provided for compatibility reason and will be removed \
+ in a future version of Frama-C. Please use the Eva.Callstack in the \
+ public API instead."]
diff --git a/src/kernel_services/abstract_interp/lmap.ml b/src/kernel_services/abstract_interp/lmap.ml
index 4bc48a7c76ea0b922d8d9dc475ba0b474cafa94e..2b584a1a1d28f8f3331bd0325152a951a5a6e97f 100644
--- a/src/kernel_services/abstract_interp/lmap.ml
+++ b/src/kernel_services/abstract_interp/lmap.ml
@@ -459,7 +459,32 @@ struct
if something_done then
widened
else
- join_widen (`Widen wh_hints) m1 m2
+ let r = join_widen (`Widen wh_hints) m1 m2 in
+ (* If [r] is equal to [m2], the widening had no effect.
+ If [m1] was not equal to [m2], either [m2] has reached some widening
+ threshold (and the widening is postponed), or there is a convergence
+ issue, for instance if the size of an allocated base is increased at
+ each loop iteration. To avoid such issue, we widen the size of weak
+ bases whose offsetmaps have changed between [m1] and [m2]. *)
+ if equal r m2 && not (equal m1 m2) then begin
+ let update_weak_base_validity base o1 o2 =
+ if Base.is_weak base && not (Offsetmap.equal o1 o2) then
+ match Base.validity base with
+ | Base.Variable v when Int.lt v.max_alloc v.max_allocable ->
+ (* Increasing [max_alloc] is never unsound as any access beyond
+ [min_alloc] will generate an alarm anyway. *)
+ Base.update_variable_validity v ~weak:true
+ ~min_alloc:v.min_alloc ~max_alloc:v.max_allocable
+ | _ -> ()
+ in
+ fold2_join_heterogeneous
+ ~cache:Hptmap_sig.NoCache
+ ~join:(fun () () -> ()) ~empty:()
+ ~empty_left:(fun _ -> ()) ~empty_right:(fun _ -> ())
+ ~both:update_weak_base_validity
+ m1 m2
+ end;
+ r
let paste_offsetmap ~from ~dst_loc ~size ~exact m =
let loc_dst = make_loc dst_loc (Int_Base.inject size) in
diff --git a/src/kernel_services/abstract_interp/value_types.ml b/src/kernel_services/abstract_interp/value_types.ml
index de2fbcb8ba0f702ae0537818c03c585572dfca65..d7d070d20e3053df8e3337c8921a6b9bd037c536 100644
--- a/src/kernel_services/abstract_interp/value_types.ml
+++ b/src/kernel_services/abstract_interp/value_types.ml
@@ -20,95 +20,6 @@
(* *)
(**************************************************************************)
-module OCamlHashtbl = Hashtbl
-open Cil_types
-
-type call_site = kernel_function * kinstr
-
-module Callsite = struct
- include Datatype.Pair_with_collections(Kernel_function)(Cil_datatype.Kinstr)
- (struct let module_name = "Value_callbacks.Callpoint" end)
-
- let pretty fmt (kf, ki) =
- Format.fprintf fmt "%a@@%t" Kernel_function.pretty kf
- (fun fmt ->
- match ki with
- | Kglobal -> Format.pp_print_string fmt "<main>"
- | Kstmt stmt -> Format.pp_print_int fmt stmt.sid
- )
-end
-
-let dkey_callstack = Kernel.register_category "callstack"
-
-type callstack = call_site list
-
-module Callstack = struct
- include Datatype.With_collections
- (Datatype.List(Callsite))
- (struct let module_name = "Value_types.Callstack" end)
-
- (* Use default Datatype printer for debug only *)
- let pretty_debug = pretty
-
- let stmt_hash s =
- let pos = fst (Cil_datatype.Stmt.loc s) in
- OCamlHashtbl.seeded_hash 0
- (pos.Filepath.pos_path, pos.Filepath.pos_lnum)
-
- let kf_hash kf =
- let name = Kernel_function.get_name kf in
- OCamlHashtbl.seeded_hash 0 name
-
- let ki_hash = function
- | Kglobal -> 1
- | Kstmt s -> 5 * stmt_hash s
-
- let rec hash = function
- | [] -> 0
- | (kf, ki) :: r ->
- let p = OCamlHashtbl.seeded_hash 0 (kf_hash kf, ki_hash ki, hash r) in
- p mod 11_316_496 (* 58 ** 4 *)
-
- let base58_map = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
-
- (* Converts [i] into a fixed-length, 4-wide string in base-58 *)
- let base58_of_int n =
- let buf = Bytes.create 4 in
- Bytes.set buf 0 (String.get base58_map (n mod 58));
- let n = n / 58 in
- Bytes.set buf 1 (String.get base58_map (n mod 58));
- let n = n / 58 in
- Bytes.set buf 2 (String.get base58_map (n mod 58));
- let n = n / 58 in
- Bytes.set buf 3 (String.get base58_map (n mod 58));
- Bytes.to_string buf
-
- let pretty_hash fmt callstack =
- if Kernel.is_debug_key_enabled dkey_callstack then
- Format.fprintf fmt "<%s> " (base58_of_int (hash callstack))
- else Format.ifprintf fmt ""
-
- let pretty_short fmt callstack =
- Format.fprintf fmt "%a" pretty_hash callstack;
- Pretty_utils.pp_flowlist ~left:"" ~sep:" <- " ~right:""
- (fun fmt (kf,_) -> Kernel_function.pretty fmt kf)
- fmt
- callstack
-
- let pretty fmt callstack =
- Format.fprintf fmt "@[<hv>%a" pretty_hash callstack;
- List.iter (fun (kf,ki) ->
- Kernel_function.pretty fmt kf;
- match ki with
- | Kglobal -> ()
- | Kstmt stmt -> Format.fprintf fmt " :: %a <-@ "
- Cil_datatype.Location.pretty
- (Cil_datatype.Stmt.loc stmt)
- ) callstack;
- Format.fprintf fmt "@]"
-
-end
-
type 'a callback_result =
| Normal of 'a
| NormalStore of 'a * int
diff --git a/src/kernel_services/abstract_interp/value_types.mli b/src/kernel_services/abstract_interp/value_types.mli
index f492097990283c38c1702685c30ce3c6fc89f5d9..811e97b24fd8645dacd03b2224d5186e007f8c6a 100644
--- a/src/kernel_services/abstract_interp/value_types.mli
+++ b/src/kernel_services/abstract_interp/value_types.mli
@@ -23,41 +23,6 @@
(** Declarations that are useful for plugins written on top of the results
of Value. *)
-open Cil_types
-
-(* TODO: These types are already defined in Value_util. *)
-type call_site = kernel_function * kinstr
-(** Value call-site.
- A callsite [(f,p)] represents a call at function [f] invoked
- {i from} program point [p].
-*)
-
-type callstack = call_site list
-(** Value callstacks, as used e.g. in Db.Value hooks.
-
- The head call site [(f,p)] is the most recent one,
- where current function [f] has been called from program point [p].
-
- Therefore, the tail call site is expected to be [(main,Kglobal)]
- where [main] is the global entry point.
-
- Moreover, given two consecutive call-sites […(_,p);(g,_)…] in a callstack,
- program point [p] is then expected to live in function [g].
-*)
-
-module Callsite: Datatype.S_with_collections with type t = call_site
-module Callstack: sig
- include Datatype.S_with_collections with type t = callstack
- val pretty_debug : Format.formatter -> t -> unit
-
- (** Print a hash of the callstack when '-kernel-msg-key callstack'
- is enabled (prints nothing otherwise). *)
- val pretty_hash : Format.formatter -> t -> unit
-
- (** Print a call stack without displaying call sites. *)
- val pretty_short : Format.formatter -> t -> unit
-end
-
type 'a callback_result =
| Normal of 'a
| NormalStore of 'a * int
diff --git a/src/kernel_services/ast_building/cil_builder.ml b/src/kernel_services/ast_building/cil_builder.ml
index 3d8e46ec965f12748527e9bfcc344e6456f905ad..c5be5ea50a70034ccd074c6fb6ffb33babcae54a 100644
--- a/src/kernel_services/ast_building/cil_builder.ml
+++ b/src/kernel_services/ast_building/cil_builder.ml
@@ -58,7 +58,7 @@ struct
let schar = Single, Ctype (TInt (ISChar, []))
let uchar = Single, Ctype (TInt (IUChar, []))
let int = Single, Ctype (TInt (IInt, []))
- let unit = Single, Ctype (TInt (IUInt, []))
+ let uint = Single, Ctype (TInt (IUInt, []))
let short = Single, Ctype (TInt (IShort, []))
let ushort = Single, Ctype (TInt (IUShort, []))
let long = Single, Ctype (TInt (ILong, []))
@@ -339,12 +339,31 @@ struct
(* Constants *)
- let of_constant c = `const (CilConstant c)
- let of_integer i = `const (Integer i)
let of_int i = `const (Int i)
+ let of_integer i = `const (Integer i)
+ let of_constant c = `const (CilConstant c)
+
let zero = of_int 0
let one = of_int 1
+ let mk_cint kind iv =
+ let iv, _ = Cil.truncateInteger64 kind iv in
+ Cil_types.CInt64(iv,kind,None)
+
+ let mk_cfloat kind fv =
+ let open Cil_types in
+ let fv =
+ match kind with
+ | FFloat -> Floating_point.round_to_single_precision_float fv
+ | FDouble | FLongDouble -> fv
+ in CReal(fv,kind,None)
+
+ let of_cint ?(kind=Cil_types.IInt) iv =
+ `const (CilConstant (mk_cint kind iv))
+
+ let of_cfloat ?(kind=Cil_types.FDouble) fv =
+ `const (CilConstant (mk_cfloat kind fv))
+
(* Lvalues *)
let var v = `var (CilVar v)
@@ -478,11 +497,10 @@ struct
with Not_found ->
typing_error ("no field " ^ s ^ " in " ^ ci.Cil_types.cname)
-
let rec build_constant = function
| CilConstant const -> const
- | Int i -> build_constant (Integer (Integer.of_int i))
- | Integer i -> Cil_types.(CInt64 (i, IInt, None))
+ | Int i -> mk_cint IInt (Integer.of_int i)
+ | Integer i -> mk_cint IInt i
and build_var ~scope = function
| CilVar vi -> vi
diff --git a/src/kernel_services/ast_building/cil_builder.mli b/src/kernel_services/ast_building/cil_builder.mli
index 074420eb04fe6712afe80ef3854b6ee83e323a00..3fc834764bf35489b0574c7edca8cb40f2fc3837 100644
--- a/src/kernel_services/ast_building/cil_builder.mli
+++ b/src/kernel_services/ast_building/cil_builder.mli
@@ -44,7 +44,7 @@ sig
val schar : ('v,'v) typ
val uchar : ('v,'v) typ
val int : ('v,'v) typ
- val unit : ('v,'v) typ
+ val uint : ('v,'v) typ
val short : ('v,'v) typ
val ushort : ('v,'v) typ
val long : ('v,'v) typ
@@ -107,9 +107,22 @@ sig
(* Constants *)
- val of_constant : Cil_types.constant -> [> const]
+ (** Implicitly converted to type [int] when converted into C constant *)
val of_int : int -> [> const]
+
+ (** Implicitly converted to type [int] when converted into C constant *)
val of_integer : Integer.t -> [> const]
+
+ (** Default kind is [int]. Value is truncated if necessary. *)
+ val of_cint :
+ ?kind:Cil_types.ikind -> Integer.t -> [> const]
+
+ (** Default kind is [double].
+ Value is rounded to simple precision if necessary. *)
+ val of_cfloat :
+ ?kind:Cil_types.fkind -> float -> [> const]
+
+ val of_constant : Cil_types.constant -> [> const]
val zero : [> const]
val one : [> const]
diff --git a/src/kernel_services/ast_printing/printer_tag.ml b/src/kernel_services/ast_printing/printer_tag.ml
index dc3f0d40495c6ad04ec9a4d9a40aa80e5b1dc3f0..ffe3da9c20d58e47a2f9e218a137a49a616aa47e 100644
--- a/src/kernel_services/ast_printing/printer_tag.ml
+++ b/src/kernel_services/ast_printing/printer_tag.ml
@@ -840,19 +840,25 @@ struct
super#fkind c
method! compname fmt comp =
- Format.fprintf fmt "@{<%s>%a@}"
- (Info.tag (PGlobal(Globals.Types.global Struct comp.cname)))
- super#compname comp
+ try
+ Format.fprintf fmt "@{<%s>%a@}"
+ (Info.tag (PGlobal(Globals.Types.global Struct comp.cname)))
+ super#compname comp
+ with Not_found -> super#compname fmt comp
method! enuminfo fmt enum =
- Format.fprintf fmt "@{<%s>%a@}"
- (Info.tag (PGlobal(Globals.Types.global Enum enum.ename)))
- super#enuminfo enum
+ try
+ Format.fprintf fmt "@{<%s>%a@}"
+ (Info.tag (PGlobal(Globals.Types.global Enum enum.ename)))
+ super#enuminfo enum
+ with Not_found -> super#enuminfo fmt enum
method! typeinfo fmt tinfo =
- Format.fprintf fmt "@{<%s>%a@}"
- (Info.tag (PGlobal(Globals.Types.global Typedef tinfo.tname)))
- super#typeinfo tinfo
+ try
+ Format.fprintf fmt "@{<%s>%a@}"
+ (Info.tag (PGlobal(Globals.Types.global Typedef tinfo.tname)))
+ super#typeinfo tinfo
+ with Not_found -> super#typeinfo fmt tinfo
initializer force_brace <- true
diff --git a/src/kernel_services/ast_queries/ast_info.ml b/src/kernel_services/ast_queries/ast_info.ml
index e6976f6deb8a82305b05bfc2df29708236dc5595..2c9418a9254db980617627f9859d20796f8a47db 100644
--- a/src/kernel_services/ast_queries/ast_info.ml
+++ b/src/kernel_services/ast_queries/ast_info.ml
@@ -450,22 +450,22 @@ let pointed_type ty =
(* ************************************************************************** *)
let can_be_cea_function name =
- Extlib.string_prefix "Frama_" name
+ String.starts_with ~prefix:"Frama_" name
let is_cea_function name =
- Extlib.string_prefix "Frama_C_show_each" name
+ String.starts_with ~prefix:"Frama_C_show_each" name
let is_cea_domain_function name =
- Extlib.string_prefix "Frama_C_domain_show_each" name
+ String.starts_with ~prefix:"Frama_C_domain_show_each" name
let is_cea_dump_function name =
- Extlib.string_prefix "Frama_C_dump_each" name
+ String.starts_with ~prefix:"Frama_C_dump_each" name
let is_cea_dump_file_function name =
- Extlib.string_prefix "Frama_C_dump_each_file" name
+ String.starts_with ~prefix:"Frama_C_dump_each_file" name
let is_cea_builtin name =
- Extlib.string_prefix "Frama_C_builtin" name
+ String.starts_with ~prefix:"Frama_C_builtin" name
let is_frama_c_builtin n =
can_be_cea_function n &&
diff --git a/src/kernel_services/ast_queries/cil.ml b/src/kernel_services/ast_queries/cil.ml
index d5a6b27c12b79ccb5cd9734b8c2f9e42164efc67..58b126012a073929e6c155c936f63aa403b411ba 100644
--- a/src/kernel_services/ast_queries/cil.ml
+++ b/src/kernel_services/ast_queries/cil.ml
@@ -400,7 +400,7 @@ let splitArrayAttributes =
List.partition
(fun a -> List.mem (attributeName a) qualifier_attributes)
-let rec typeAddAttributes a0 t =
+let rec typeAddAttributes ?(combine=addAttributes) a0 t =
begin
match a0 with
| [] ->
@@ -408,7 +408,7 @@ let rec typeAddAttributes a0 t =
t
| _ ->
(* anything else: add a0 to existing attributes *)
- let add (a: attributes) = addAttributes a0 a in
+ let add (a: attributes) = combine a0 a in
match t with
TVoid a -> TVoid (add a)
| TInt (ik, a) -> TInt (ik, add a)
@@ -830,6 +830,7 @@ let id = Fun.id
let alphabetabeta _ x = x
let alphabetafalse _ _ = false
let alphatrue _ = true
+let alphafalse _ = false
module Extensions = struct
let initialized = ref false
@@ -5802,32 +5803,53 @@ let isVariadicListType t = match unrollTypeSkel t with
| TBuiltin_va_list _ -> true
| _ -> false
-let rec isConstantGen f e = match e.enode with
+let rec isConstantGen lit_only is_varinfo_cst f e = match e.enode with
| Const c -> f c
- | UnOp (_, e, _) -> isConstantGen f e
- | BinOp (_, e1, e2, _) -> isConstantGen f e1 && isConstantGen f e2
- | Lval (Var vi, NoOffset) ->
- (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype)
+ | UnOp (_, e, _) -> isConstantGen lit_only is_varinfo_cst f e
+ | BinOp (_, e1, e2, _) ->
+ isConstantGen lit_only is_varinfo_cst f e1 &&
+ isConstantGen lit_only is_varinfo_cst f e2
+ | Lval (Var vi, _) ->
+ is_varinfo_cst vi ||
+ (vi.vglob && isArrayType vi.vtype) ||
+ isFunctionType vi.vtype
| Lval _ -> false
| SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true
(* see ISO 6.6.6 *)
| CastE(t,{ enode = Const(CReal _)}) when isIntegralType t -> true
- | CastE (_, e) -> isConstantGen f e
- | AddrOf (Var vi, off) | StartOf (Var vi, off)
- -> vi.vglob && isConstantOffsetGen f off
- | AddrOf (Mem e, off) | StartOf(Mem e, off)
- -> isConstantGen f e && isConstantOffsetGen f off
-
-and isConstantOffsetGen f = function
+ | CastE(t, e) ->
+ begin
+ match t, typeOf e with
+ | TInt (i, _), TPtr _ ->
+ (* gcc/clang/ccomp consider a non-truncated pointer to be a constant.
+ If it is truncated, we check whether we already know its value. *)
+ bytesSizeOfInt theMachine.upointKind <= bytesSizeOfInt i ||
+ isConstantGen true is_varinfo_cst f e
+ | _ -> isConstantGen lit_only is_varinfo_cst f e
+ end
+ | AddrOf (Var vi, off) | StartOf (Var vi, off) ->
+ not lit_only &&
+ vi.vglob &&
+ isConstantOffsetGen lit_only is_varinfo_cst f off
+ | AddrOf (Mem e, off) | StartOf(Mem e, off) ->
+ isConstantGen lit_only is_varinfo_cst f e &&
+ isConstantOffsetGen lit_only is_varinfo_cst f off
+
+and isConstantOffsetGen lit_only is_varinfo_cst f = function
NoOffset -> true
- | Field(_fi, off) -> isConstantOffsetGen f off
- | Index(e, off) -> isConstantGen f e && isConstantOffsetGen f off
-
-let isConstant e = isConstantGen alphatrue e
-let isConstantOffset o = isConstantOffsetGen alphatrue o
-
-let isIntegerConstant e =
- isConstantGen
+ | Field(_fi, off) -> isConstantOffsetGen lit_only is_varinfo_cst f off
+ | Index(e, off) ->
+ isConstantGen lit_only is_varinfo_cst f e &&
+ isConstantOffsetGen lit_only is_varinfo_cst f off
+
+let isConstant ?(is_varinfo_cst = alphafalse) e =
+ isConstantGen false is_varinfo_cst alphatrue e
+let isConstantOffset ?(is_varinfo_cst = alphafalse) o =
+ isConstantOffsetGen false is_varinfo_cst alphatrue o
+
+let isIntegerConstant ?(is_varinfo_cst = alphafalse) e =
+ isConstantGen false
+ is_varinfo_cst
(function
| CInt64 _ | CChr _ | CEnum _ -> true
| CStr _ | CWStr _ | CReal _ -> false)
@@ -5838,6 +5860,375 @@ let getCompField cinfo fieldName =
(fun fi -> fi.fname = fieldName)
(Option.value ~default:[] cinfo.cfields)
+let sameSizeInt ?(machdep=false) (ik1 : ikind) (ik2 : ikind) =
+ if machdep then bytesSizeOfInt ik1 == bytesSizeOfInt ik2
+ else
+ match ik1, ik2 with
+ | (IChar | ISChar | IUChar), (IChar | ISChar | IUChar) -> true
+ | (IShort | IUShort), (IShort | IUShort) -> true
+ | (IInt | IUInt), (IInt | IUInt) -> true
+ | (ILong | IULong), (ILong | IULong) -> true
+ | (ILongLong | IULongLong), (ILongLong | IULongLong) -> true
+ | _ -> false
+
+
+let sameSign ?(machdep=false) (ik1 : ikind) (ik2 : ikind) =
+ if machdep then isSigned ik1 = isSigned ik2
+ else
+ match ik1, ik2 with
+ | IChar, (ISChar | IUChar)
+ | ISChar, (IChar | IUChar)
+ | IUChar, (IChar | ISChar) -> false
+ | _ -> isSigned ik1 = isSigned ik2
+
+let same_int64 ?(machdep=true) e1 e2 =
+ match constFoldToInt ~machdep e1, constFoldToInt ~machdep e2 with
+ | Some i, Some i' -> Integer.equal i i'
+ | _ -> false
+
+exception Cannot_combine of string
+
+type combineWhat =
+ CombineFundef of bool
+ (* The new definition is for a function definition. The old
+ * is for a prototype. arg is [true] for an old-style declaration *)
+ | CombineFunarg of bool
+ (* Comparing a function argument type with an old prototype argument.
+ arg is [true] for an old-style declaration, which
+ triggers some ad hoc treatment in GCC mode. *)
+ | CombineFunret (* Comparing the return of a function with that from an old
+ * prototype *)
+ | CombineOther
+
+(* [combineAttributes what olda a] combines the attributes in [olda] and [a]
+ according to [what]:
+ - if [what == CombineFunarg], then override old attributes;
+ this is used to ensure that attributes from formal argument types in a
+ function definition are not mixed with attributes from arguments in other
+ (compatible, but with different qualifiers) declarations;
+ - else, perform the union of old and new attributes. *)
+let combineAttributes what olda a =
+ match what with
+ | CombineFunarg _ -> a (* override old attributes with new ones *)
+ | _ -> addAttributes olda a (* union of attributes *)
+
+type combineFunction =
+ {
+ typ_combine : combineFunction ->
+ bool -> combineWhat -> typ -> typ -> typ;
+
+ enum_combine : combineFunction ->
+ enuminfo -> enuminfo -> enuminfo;
+
+ comp_combine : combineFunction ->
+ compinfo -> compinfo -> compinfo;
+
+ name_combine : combineFunction -> combineWhat ->
+ typeinfo -> typeinfo -> typeinfo;
+ }
+
+(* Combine the types. Raises the Cannot_combine exception with an error message.
+ [what] is used to recursively deal with function return types and function
+ arguments in special ways.
+ Note: we cannot force the qualifiers of oldt and t to be the same here,
+ because in some cases (e.g. string literals and char pointers) it is
+ allowed to have differences, while in others we want to be more strict. *)
+let combineTypesGen ?emitwith (combF : combineFunction)
+ ?(strictInteger=true) ?(strictReturnTypes=false)
+ (what : combineWhat) (oldt : typ) (t : typ) : typ =
+ let warning = Kernel.warning ?emitwith in
+ match oldt, t with
+ | TVoid olda, TVoid a -> TVoid (combineAttributes what olda a)
+
+ | _, TVoid _ when what = CombineFunret && not strictReturnTypes -> t
+
+ | TInt (oldik, olda), TInt (ik, a) ->
+ let result k oldk = if rank oldk<rank k then k else oldk in
+ let check_gcc_mode oldk k =
+ if gccMode () && oldk == IInt &&
+ bytesSizeOf t <= bytesSizeOfInt IInt &&
+ (what = CombineFunarg true || what = CombineFunret)
+ then k
+ else
+ let msg =
+ Format.asprintf
+ "different integer types:@ '%a' and '%a'"
+ Cil_datatype.Typ.pretty oldt Cil_datatype.Typ.pretty t in
+ raise (Cannot_combine msg)
+ in
+ let combineIK oldk k =
+ if oldk == k then oldk else
+ if not strictInteger
+ then
+ if sameSizeInt ~machdep:false oldk k && sameSign ~machdep:false oldk k
+ then
+ (* The types contain the same sort of values but are not equal.
+ For example on x86_16 machdep unsigned short and unsigned int. *)
+ result k oldk
+ else
+ if sameSizeInt ~machdep:true oldk k && sameSign ~machdep:true oldk k
+ then
+ begin
+ warning
+ ~wkey:Kernel.wkey_int_conversion
+ ~current:true
+ "Integer compatibily is machine-dependent : %a and %a\n"
+ Cil_datatype.Typ.pretty oldt Cil_datatype.Typ.pretty t;
+ result k oldk
+ end
+ else
+ check_gcc_mode oldk k
+ else
+ check_gcc_mode oldk k
+ in
+ TInt (combineIK oldik ik, combineAttributes what olda a)
+
+ | TFloat (oldfk, olda), TFloat (fk, a) ->
+ let combineFK oldk k =
+ if oldk == k then oldk else
+ if gccMode () && oldk == FDouble && k == FFloat
+ && (what = CombineFunarg true || what = CombineFunret)
+ then k
+ else
+ raise (Cannot_combine "different floating point types")
+ in
+ TFloat (combineFK oldfk fk, combineAttributes what olda a)
+
+ | TEnum (oldei, olda), TEnum (ei, a) ->
+ (* Matching enumerations always succeeds. But sometimes it maps both
+ * enumerations to integers *)
+ TEnum (combF.enum_combine combF oldei ei,
+ combineAttributes what olda a)
+
+ (* Strange one. But seems to be handled by GCC *)
+ | TEnum (oldei, olda) , TInt(IInt, a) ->
+ TEnum(oldei, combineAttributes what olda a)
+
+ (* Strange one. But seems to be handled by GCC. Warning. Here we are
+ * leaking types from new to old *)
+ | TInt(IInt, olda), TEnum (ei, a) ->
+ TEnum(ei, combineAttributes what olda a)
+
+ | TComp (oldci, olda) , TComp (ci, a) ->
+ TComp(combF.comp_combine combF oldci ci,
+ combineAttributes what olda a)
+
+ | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
+ let newbt = combF.typ_combine combF strictReturnTypes CombineOther
+ oldbt bt in
+ let newsz =
+ match oldsz, sz with
+ | None, Some _ -> sz
+ | Some _, None -> oldsz
+ | None, None -> sz
+ | Some oldsz', Some sz' ->
+ (* They are not structurally equal. But perhaps they are equal if we
+ evaluate them. Check first machine independent comparison. *)
+ if same_int64 ~machdep:false oldsz' sz' then
+ oldsz
+ else if same_int64 ~machdep:true oldsz' sz' then begin
+ warning
+ ~wkey:Kernel.wkey_int_conversion
+ ~current:true
+ "Array type comparison succeeds only based on machine-dependent \
+ constant evaluation: %a and %a\n"
+ Cil_datatype.Typ.pretty oldt Cil_datatype.Typ.pretty t;
+ oldsz
+ end else
+ raise (Cannot_combine "different array lengths")
+ in
+ TArray (newbt, newsz, combineAttributes what olda a)
+
+ | TPtr (oldbt, olda), TPtr (bt, a) ->
+ TPtr (combF.typ_combine combF strictReturnTypes CombineOther oldbt bt,
+ combineAttributes what olda a)
+
+ | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) ->
+ let newrt = combF.typ_combine combF strictReturnTypes
+ CombineFunret oldrt rt in
+ if oldva != va then
+ raise (Cannot_combine "different vararg specifiers");
+ (* If one does not have arguments, believe the one with the
+ * arguments *)
+ let newargs, olda' =
+ if oldargs = None then args, olda else
+ if args = None then oldargs, olda else
+ let (oldargslist, oldghostargslist) = argsToPairOfLists oldargs in
+ let (argslist, ghostargslist) = argsToPairOfLists args in
+ if List.length oldargslist <> List.length argslist then
+ raise (Cannot_combine "different number of arguments")
+ else if List.length oldghostargslist <> List.length ghostargslist then
+ raise (Cannot_combine "different number of ghost arguments")
+ else
+ let oldargslist = oldargslist @ oldghostargslist in
+ let argslist = argslist @ ghostargslist in
+ (* Go over the arguments and update the old ones with the
+ * adjusted types *)
+ (* Format.printf "new type is %a@." Cil_datatype.Typ.pretty t; *)
+ let what =
+ match what with
+ | CombineFundef b -> CombineFunarg b
+ | _ -> CombineOther
+ in
+ Some
+ (List.map2
+ (fun (on, ot, oa) (an, at, aa) ->
+ (* Update the names. Always prefer the new name. This is
+ very important if the prototype uses different names than
+ the function definition. *)
+ let n = if an <> "" then an else on in
+ let t = combF.typ_combine combF strictReturnTypes what ot at in
+ let a = addAttributes oa aa in
+ (n, t, a))
+ oldargslist argslist),
+ olda
+ in
+ (* Drop missingproto as soon as one of the type is a properly declared one*)
+ let olda =
+ if not (hasAttribute "missingproto" a) then
+ dropAttribute "missingproto" olda'
+ else olda'
+ in
+ let a =
+ if not (hasAttribute "missingproto" olda') then
+ dropAttribute "missingproto" a
+ else a
+ in
+ TFun (newrt, newargs, oldva, combineAttributes what olda a)
+
+ | TBuiltin_va_list olda, TBuiltin_va_list a ->
+ TBuiltin_va_list (combineAttributes what olda a)
+
+ | TNamed (oldt, olda), TNamed (t, a) ->
+ TNamed (combF.name_combine combF what oldt t,
+ combineAttributes what olda a)
+
+ | _, TNamed (t, a) ->
+ let res = combF.typ_combine combF strictReturnTypes what oldt t.ttype in
+ typeAddAttributes ~combine:(combineAttributes what) a res
+
+ | TNamed (oldt, olda), _ ->
+ let res = combF.typ_combine combF strictReturnTypes what oldt.ttype t in
+ typeAddAttributes ~combine:(combineAttributes what) olda res
+
+ | _ ->
+ raise
+ (Cannot_combine
+ (Format.asprintf "different type constructors:@ %a and %a"
+ Cil_datatype.Typ.pretty oldt Cil_datatype.Typ.pretty t))
+
+
+let default_combines = {
+ typ_combine = (fun c b ->
+ combineTypesGen c ~strictInteger:true ~strictReturnTypes:b);
+ enum_combine = (fun _ _ ei -> ei);
+ comp_combine = (fun _ oldci ci ->
+ if oldci.cstruct <> ci.cstruct then
+ raise (Cannot_combine "different struct/union types");
+ if oldci.cname = ci.cname then
+ oldci
+ else
+ raise (Cannot_combine
+ (Format.sprintf "%ss with different tags"
+ (if oldci.cstruct then "struct" else "union"))));
+ name_combine = (fun c what oldt t ->
+ if oldt.tname = t.tname then oldt
+ else
+ begin
+ ignore (c.typ_combine c false what oldt.ttype t.ttype);
+ oldt
+ end);
+}
+
+
+let combineTypes ?(strictReturnTypes=false) what (oldt: typ) (t: typ) : typ =
+ combineTypesGen default_combines ~strictReturnTypes what oldt t
+
+(***************** Compatibility ******)
+
+
+(* how type qualifiers must be checked *)
+type qualifier_check_context =
+ | Identical (* identical qualifiers. *)
+ | IdenticalToplevel (* ignore at toplevel, use Identical when going under a
+ pointer. *)
+ | Covariant (* first type can have const-qualifications
+ the second doesn't have. *)
+ | CovariantToplevel
+ (* accepts everything for current type, use Covariant when going under a
+ pointer. *)
+ | Contravariant (* second type can have const-qualifications
+ the first doesn't have. *)
+ | ContravariantToplevel
+ (* accepts everything for current type, use Contravariant when going under
+ a pointer. *)
+
+let qualifier_context_fun_arg = function
+ | Identical | IdenticalToplevel -> IdenticalToplevel
+ | Covariant | CovariantToplevel -> ContravariantToplevel
+ | Contravariant | ContravariantToplevel -> CovariantToplevel
+
+let qualifier_context_fun_ret = function
+ | Identical | IdenticalToplevel -> IdenticalToplevel
+ | Covariant | CovariantToplevel -> CovariantToplevel
+ | Contravariant | ContravariantToplevel -> ContravariantToplevel
+
+let qualifier_context_ptr = function
+ | Identical | IdenticalToplevel -> Identical
+ | Covariant | CovariantToplevel -> Covariant
+ | Contravariant | ContravariantToplevel -> Contravariant
+
+let included_qualifiers ?(context=Identical) a1 a2 =
+ let a1 = filter_qualifier_attributes a1 in
+ let a2 = filter_qualifier_attributes a2 in
+ let a1 = dropAttribute "restrict" a1 in
+ let a2 = dropAttribute "restrict" a2 in
+ let a1_no_cv = dropAttributes ["const"; "volatile"] a1 in
+ let a2_no_cv = dropAttributes ["const"; "volatile"] a2 in
+ let is_equal = Cil_datatype.Attributes.equal a1 a2 in
+ if is_equal then true
+ else begin
+ match context with
+ | Identical -> false
+ | Covariant -> Cil_datatype.Attributes.equal a1_no_cv a2
+ | Contravariant -> Cil_datatype.Attributes.equal a1 a2_no_cv
+ | CovariantToplevel | ContravariantToplevel | IdenticalToplevel -> true
+ end
+
+(* precondition: t1 and t2 must be "compatible" as per combineTypes, i.e.
+ you must have called [combineTypes t1 t2] before calling this function. *)
+let rec have_compatible_qualifiers_deep ?(context=Identical) t1 t2 =
+ match unrollType t1, unrollType t2 with
+ | TFun (tres1, Some args1, _, _), TFun (tres2, Some args2, _, _) ->
+ have_compatible_qualifiers_deep
+ ~context:(qualifier_context_fun_ret context) tres1 tres2 &&
+ let context = qualifier_context_fun_arg context in
+ List.for_all2 (fun (_, t1', a1) (_, t2', a2) ->
+ have_compatible_qualifiers_deep ~context t1' t2' &&
+ included_qualifiers ~context a1 a2)
+ args1 args2
+ | TPtr (t1', a1), TPtr (t2', a2)
+ | TArray (t1', _, a1), TArray (t2', _, a2) ->
+ (included_qualifiers ~context a1 a2) &&
+ let context = qualifier_context_ptr context in
+ have_compatible_qualifiers_deep ~context t1' t2'
+ | _, _ -> included_qualifiers ~context (typeAttrs t1) (typeAttrs t2)
+
+let compatibleTypes ?strictReturnTypes ?context t1 t2 =
+ let r = combineTypes ?strictReturnTypes CombineOther t1 t2 in
+ (* C99, 6.7.3 §9: "... to be compatible, both shall have the identically
+ qualified version of a compatible type;" *)
+ if not (have_compatible_qualifiers_deep ?context t1 t2) then
+ raise (Cannot_combine "different qualifiers");
+ (* Note: different non-qualifier attributes will be silently dropped. *)
+ r
+
+let areCompatibleTypes ?strictReturnTypes ?context t1 t2 =
+ try
+ ignore (compatibleTypes ?strictReturnTypes ?context t1 t2); true
+ with Cannot_combine _ -> false
+
+
let mkCastT ?(force=false) ~(oldt: typ) ~(newt: typ) e =
let loc = e.eloc in
(* Issue #!1546
diff --git a/src/kernel_services/ast_queries/cil.mli b/src/kernel_services/ast_queries/cil.mli
index 8b63fb51b24e9a757822fd9696bd9c9b00902fcc..f4c1dc2ef70b4817065e4b1438f0cc8dec5dc0ef 100644
--- a/src/kernel_services/ast_queries/cil.mli
+++ b/src/kernel_services/ast_queries/cil.mli
@@ -665,6 +665,135 @@ val splitFunctionTypeVI:
typ * (string * typ * attributes) list option * bool * attributes
+exception Cannot_combine of string
+
+(** Used in {!combineTypes} and {!combineTypesGen} to indicate what we want to
+ combine.
+
+ @since Frama-C+dev
+*)
+type combineWhat =
+ | CombineFundef of bool
+ (** The new definition is for a function definition. The old is for a
+ prototype. arg is [true] for an old-style declaration.
+ *)
+ | CombineFunarg of bool
+ (** Comparing a function argument type with an old prototype argument. arg is
+ [true] for an old-style declaration, which triggers some ad hoc treatment
+ in GCC mode.
+ *)
+ | CombineFunret
+ (** Comparing the return of a function with that from an old prototype *)
+ | CombineOther
+
+(** [combineAttributes what olda a] combines the attributes in [olda] and [a]
+ according to [what]:
+ - if [what == CombineFunarg], then override old attributes;
+ this is used to ensure that attributes from formal argument types in a
+ function definition are not mixed with attributes from arguments in other
+ (compatible, but with different qualifiers) declarations;
+ - else, perform the union of old and new attributes.
+
+ @since Frama-C+dev
+*)
+val combineAttributes : combineWhat -> attribute list -> attributes -> attributes
+
+(** [combineFunction] contains information on how enum, struct/union and
+ typedef are to be handled when combining with {!combineTypes} and
+ {!combineTypesGen}.
+ In pratice, the first argument of each field is a recursive definition.
+
+ @since Frama-C+dev
+*)
+type combineFunction =
+ {
+ typ_combine : combineFunction ->
+ bool -> combineWhat -> typ -> typ -> typ;
+ (** [bool] is about strictness in return context.
+ See [StrictReturnTypes] in [combineTypeGen] *)
+
+ enum_combine : combineFunction ->
+ enuminfo -> enuminfo -> enuminfo;
+
+ comp_combine : combineFunction ->
+ compinfo -> compinfo -> compinfo;
+
+ name_combine : combineFunction -> combineWhat ->
+ typeinfo -> typeinfo -> typeinfo;
+ }
+
+(** [combineTypesGen combF combW oldt newt]
+ Combine [oldt] and [newt] accordingly to [combF], [combW] indicates what we
+ are combinining.
+
+ Warning : this is not commutative. Indeed, excluding enum, struct/union and
+ typedef which depend on [combF], the resulting type is as close as possible
+ to [newt].
+
+ [strictInteger] is [true] (default) if two integers with same size and sign
+ but with different types cannot be combined. A warning is sent if it is
+ [false] and the compatibility is machine-dependent.
+
+ [strictReturnTypes] is [false] (default) if a non-void type is compatible
+ with void in a return case.
+
+ Notice that the [~emitwith] action is called iff a warning is logged.
+
+ @raise Cannot_combine with an explanation when the type cannot be
+ combined.
+
+ @since Frama-C+dev
+*)
+val combineTypesGen : ?emitwith:(Log.event -> unit) -> combineFunction ->
+ ?strictInteger:bool -> ?strictReturnTypes:bool ->
+ combineWhat -> typ -> typ -> typ
+
+(** Specialized verison of [combineTypesGen], we suppore here that
+ if two global symbols are equal, then they are the same object.
+
+ @since Frama-C+dev
+*)
+val combineTypes : ?strictReturnTypes:bool -> combineWhat -> typ -> typ -> typ
+
+(** How type qualifiers must be checked when checking for types compatibility
+ with {!areCompatibleTypes} and {!compatibleTypes}.
+
+ @since Frama-C+dev
+*)
+type qualifier_check_context =
+ | Identical (** Identical qualifiers. *)
+ | IdenticalToplevel
+ (** Ignore at toplevel, use Identical when going under a pointer. *)
+ | Covariant
+ (** First type can have const-qualifications the second doesn't have. *)
+ | CovariantToplevel
+ (** Accepts everything for current type, use Covariant when going under a
+ pointer. *)
+ | Contravariant
+ (** Second type can have const-qualifications the first doesn't have. *)
+ | ContravariantToplevel
+ (** Accepts everything for current type, use Contravariant when going under
+ a pointer. *)
+
+(** [areCompatibleTypes] returns [true] if two types are compatible.
+ [context] indicates how check the compatibility of qualifiers.
+ Other arguments are the same than [combineTypes].
+
+ @since Frama-C+dev
+*)
+val areCompatibleTypes :
+ ?strictReturnTypes:bool -> ?context:qualifier_check_context -> typ -> typ -> bool
+
+(** Same as [areCompatibleTypes old newt] but combine [oldt] and [newt].
+ [context] does not impact the qualifiers of the result.
+
+ @raise Cannot_combine if [oldt] and [newt] are not compatible.
+
+ @since Frama-C+dev
+*)
+val compatibleTypes :
+ ?strictReturnTypes:bool -> ?context:qualifier_check_context -> typ -> typ -> typ
+
(*********************************************************)
(** LVALUES *)
@@ -841,14 +970,26 @@ val kfloat: loc:location -> fkind -> float -> exp
character or an integer constant *)
val isInteger: exp -> Integer.t option
-(** True if the expression is a compile-time constant *)
-val isConstant: exp -> bool
+(** True if the expression is a compile-time constant.
+ [is_varinfo_cst] indicates whether a variable should
+ be considered as having a constant content. Defaults to
+ [false].
+
+ @before Frama-C+dev [is_varinfo_cst] does not exist
+*)
+val isConstant: ?is_varinfo_cst:(varinfo -> bool) -> exp -> bool
+
+(** True if the expression is a compile-time integer constant
+
+ @before Frama-C+dev [is_varinfo_cst] does not exist
+*)
+val isIntegerConstant: ?is_varinfo_cst:(varinfo -> bool) -> exp -> bool
-(** True if the expression is a compile-time integer constant *)
-val isIntegerConstant: exp -> bool
+(** True if the given offset contains only field names or constant indices.
-(** True if the given offset contains only field names or constant indices. *)
-val isConstantOffset: offset -> bool
+ @before Frama-C+dev [is_varinfo_cst] does not exist
+*)
+val isConstantOffset: ?is_varinfo_cst:(varinfo -> bool) -> offset -> bool
(** True if the given expression is a (possibly cast'ed) integer or character
constant with value zero *)
@@ -918,6 +1059,13 @@ val constFoldBinOp: loc:location -> bool -> binop -> exp -> exp -> typ -> exp
*)
val compareConstant: constant -> constant -> bool
+
+(** [true] if two kinds have the same size independently of the machine.*)
+val sameSizeInt : ?machdep:bool -> ikind -> ikind -> bool
+
+(** [true] if the result of two expressions are two equal integers. *)
+val same_int64 : ?machdep:bool -> exp -> exp -> bool
+
(** Increment an expression. Can be arithmetic or pointer type *)
val increm: exp -> int -> exp
@@ -1325,8 +1473,12 @@ val typeAttr: typ -> attribute list
are discarded. *)
val setTypeAttrs: typ -> attributes -> typ
-(** Add some attributes to a type *)
-val typeAddAttributes: attribute list -> typ -> typ
+(** Add some attributes to a type.
+ [combine] explains how to combine attributes. Default is [addAttributes].
+
+ @before Frama-C+dev [combine] does not exist *)
+val typeAddAttributes: ?combine: (attribute list -> attributes -> attributes) ->
+ attribute list -> typ -> typ
(** Remove all attributes with the given names from a type. Note that this
does not remove attributes from typedef and tag definitions, just from
diff --git a/src/kernel_services/ast_queries/file.ml b/src/kernel_services/ast_queries/file.ml
index 213a01aa72e0f96f949d035b2793bb2151a65b44..a607b34e6d1e12220703ceaf4e8520bc0204067b 100644
--- a/src/kernel_services/ast_queries/file.ml
+++ b/src/kernel_services/ast_queries/file.ml
@@ -132,12 +132,12 @@ let from_filename ?cpp f =
else if cpp <> "" then begin
if not Fc_config.preprocessor_keep_comments then
Kernel.warning ~once:true
- "Default pre-processor does not keep comments. Any ACSL annotation \
- on non-pre-processed file will be discarded.";
+ "Default preprocessor does not keep comments. Any ACSL annotations \
+ on non-preprocessed files will be discarded.";
NeedCPP (f, cpp, extra_for_this_file, is_cpp_gnu_like ())
end else
- Kernel.abort "No working pre-processor found. You can only analyze \
- pre-processed .i files."
+ Kernel.abort "No working preprocessor found. You can only analyze \
+ preprocessed .i files."
(* ************************************************************************* *)
(** {2 Internal states} *)
@@ -441,6 +441,10 @@ let safe_remove_file (f : Datatype.Filepath.t) =
if not (Kernel.is_debug_key_enabled Kernel.dkey_parser) then
Extlib.safe_remove (f :> string)
+let cpp_name cmd =
+ let cmd = List.hd (String.split_on_char ' ' cmd) in
+ Filename.basename cmd
+
let replace_in_cpp_cmd cmdl supp_args in_file out_file =
(* using Filename.quote for filenames which contain space or shell
metacharacters *)
@@ -497,7 +501,7 @@ let build_cpp_cmd = function
Kernel.warning
~once:true
"your preprocessor is not known to handle option `%s'. \
- If pre-processing fails because of it, please add \
+ If preprocessing fails because of it, please add \
-no-cpp-frama-c-compliant option to Frama-C's command-line. \
If you do not want to see this warning again, explicitly use \
option -cpp-frama-c-compliant."
@@ -516,6 +520,19 @@ let build_cpp_cmd = function
else []
in
let fc_define_args = ["__FRAMAC__"] in
+ let exe = cpp_name cmdl in
+ let clang_no_warn =
+ if exe = "clang" || exe = "gcc" then
+ (* NB: For gcc, only old versions (still found in Ubuntu 18.04,
+ supported until 2028, though) activate builtin-macro-redefined.
+ This is also the case for newer clangs, while older ones will
+ complain about the unknown warning (gcc does not seem to care,
+ so that it is safe to keep the unknown-warning-option in every
+ case). *)
+ ["-Wno-builtin-macro-redefined"; "-Wno-unknown-warning-option"]
+ else
+ []
+ in
let nostdinc_arg =
if Kernel.FramaCStdLib.get() then add_if_gnu "-nostdinc"
else []
@@ -537,7 +554,7 @@ let build_cpp_cmd = function
in
let supp_args =
string_of_supp_args
- (gnu_implicit_args @
+ (gnu_implicit_args @ clang_no_warn @
extra_for_this_file @ (Kernel.CppExtraArgs.get ()))
fc_include_args fc_define_args
in
diff --git a/src/kernel_services/plugin_entry_points/db.ml b/src/kernel_services/plugin_entry_points/db.ml
index 5567a74eefc59512a1aeb82db309194b16e4d71b..2cbd4c86ed67b863730b680daac78bcc60029fc0 100644
--- a/src/kernel_services/plugin_entry_points/db.ml
+++ b/src/kernel_services/plugin_entry_points/db.ml
@@ -127,7 +127,8 @@ module Operational_inputs = struct
let get_external = mk_fun "Operational_inputs.get_external"
module Record_Inout_Callbacks =
- Hook.Build (struct type t = Value_types.callstack * Inout_type.t end)
+ Hook.Build (struct type t = Eva_types.Callstack.t * Inout_type.t end)
+ [@@alert "-db_deprecated"]
let pretty fmt x =
Format.fprintf fmt "@[<v>";
@@ -236,8 +237,11 @@ module Value = struct
let size = 256
+ [@@@ alert "-db_deprecated"]
+ type callstack = Eva_types.Callstack.callstack
+
module States_by_callstack =
- Value_types.Callstack.Hashtbl.Make(Cvalue.Model)
+ Eva_types.Callstack.Hashtbl.Make(Cvalue.Model)
module Table_By_Callstack =
Cil_state_builder.Stmt_hashtbl(States_by_callstack)
@@ -365,19 +369,17 @@ module Value = struct
Cvalue.Model.pretty v)
*)
- type callstack = (kernel_function * kinstr) list
-
module Record_Value_Callbacks =
Hook.Build
(struct
- type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t
+ type t = callstack * (state Stmt.Hashtbl.t) Lazy.t
end)
module Record_Value_Callbacks_New =
Hook.Build
(struct
type t =
- (kernel_function * kinstr) list *
+ callstack *
((state Stmt.Hashtbl.t) Lazy.t * (state Stmt.Hashtbl.t) Lazy.t)
Value_types.callback_result
end)
@@ -385,24 +387,24 @@ module Value = struct
module Record_Value_After_Callbacks =
Hook.Build
(struct
- type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t
+ type t = callstack * (state Stmt.Hashtbl.t) Lazy.t
end)
module Record_Value_Superposition_Callbacks =
Hook.Build
(struct
- type t = (kernel_function * kinstr) list * (state list Stmt.Hashtbl.t) Lazy.t
+ type t = callstack * (state list Stmt.Hashtbl.t) Lazy.t
end)
module Call_Value_Callbacks =
Hook.Build
- (struct type t = state * (kernel_function * kinstr) list end)
+ (struct type t = state * callstack end)
module Call_Type_Value_Callbacks =
Hook.Build(struct
- type t = [`Builtin of Value_types.call_froms | `Spec of funspec
- | `Def | `Memexec]
- * state * (kernel_function * kinstr) list end)
+ type t = [`Builtin | `Spec
+ | `Body | `Reuse]
+ * state * callstack end)
;;
@@ -418,7 +420,7 @@ module Value = struct
let no_results = mk_fun "Value.no_results"
let update_callstack_table ~after stmt callstack v =
- let open Value_types in
+ let open Eva_types in
let find,add =
if after
then AfterTable_By_Callstack.find, AfterTable_By_Callstack.add
@@ -437,9 +439,8 @@ module Value = struct
Callstack.Hashtbl.add r callstack v;
add stmt r
- let merge_initial_state cs state =
- let open Value_types in
- let kf = match cs with (kf, _) :: _ -> kf | _ -> assert false in
+ let merge_initial_state cs kf state =
+ let open Eva_types in
let by_callstack =
try Called_Functions_By_Callstack.find kf
with Not_found ->
@@ -459,7 +460,7 @@ module Value = struct
with Not_found ->
let state =
try
- let open Value_types in
+ let open Eva_types in
let by_callstack = Called_Functions_By_Callstack.find kf in
Callstack.Hashtbl.fold
(fun _cs state acc -> Cvalue.Model.join acc state)
@@ -507,7 +508,7 @@ module Value = struct
match ho with
| None -> Cvalue.Model.bottom
| Some h ->
- Value_types.Callstack.Hashtbl.fold (fun _cs state acc ->
+ Eva_types.Callstack.Hashtbl.fold (fun _cs state acc ->
Cvalue.Model.join acc state
) h Cvalue.Model.bottom
in
@@ -539,7 +540,7 @@ module Value = struct
assert (is_computed ()); (* this assertion fails during Eva analysis *)
match get_stmt_state_callstack ~after stmt with
| None -> acc
- | Some h -> Value_types.Callstack.Hashtbl.fold (fun _ -> f) h acc
+ | Some h -> Eva_types.Callstack.Hashtbl.fold (fun _ -> f) h acc
let fold_state_callstack f acc ~after ki =
assert (is_computed ()); (* this assertion fails during Eva analysis *)
@@ -559,7 +560,7 @@ module Value = struct
| None -> false
| Some h ->
try
- Value_types.Callstack.Hashtbl.iter
+ Eva_types.Callstack.Hashtbl.iter
(fun _cs state ->
if Cvalue.Model.is_reachable state
then raise Is_reachable) h;
diff --git a/src/kernel_services/plugin_entry_points/db.mli b/src/kernel_services/plugin_entry_points/db.mli
index 5dc9c539f9b4cdccfa158fca7f7d303bc374b108..4a82d0b724c34198a6b7dcb7821732989a710ebd 100644
--- a/src/kernel_services/plugin_entry_points/db.mli
+++ b/src/kernel_services/plugin_entry_points/db.mli
@@ -134,15 +134,19 @@ module Value : sig
(** Return [true] iff the value analysis has been done.
@see <https://frama-c.com/download/frama-c-plugin-development-guide.pdf> Plug-in Development Guide *)
+ [@@@alert "-db_deprecated"]
+
+ type callstack = Eva_types.Callstack.callstack
+
module Table_By_Callstack:
State_builder.Hashtbl with type key = stmt
- and type data = state Value_types.Callstack.Hashtbl.t
+ and type data = state Eva_types.Callstack.Hashtbl.t
(** Table containing the results of the value analysis, ie.
the state before the evaluation of each reachable statement. *)
module AfterTable_By_Callstack:
State_builder.Hashtbl with type key = stmt
- and type data = state Value_types.Callstack.Hashtbl.t
+ and type data = state Eva_types.Callstack.Hashtbl.t
(** Table containing the state of the value analysis after the evaluation
of each reachable and evaluable statement. Filled only if
[Value_parameters.ResultsAfter] is set. *)
@@ -216,12 +220,12 @@ module Value : sig
val get_initial_state : kernel_function -> state
val get_initial_state_callstack :
- kernel_function -> state Value_types.Callstack.Hashtbl.t option
+ kernel_function -> state Eva_types.Callstack.Hashtbl.t option
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
+ after:bool -> stmt -> state Eva_types.Callstack.Hashtbl.t option
val get_stmt_state : ?after:bool -> stmt -> state
(** [after] is false by default.
@@ -406,19 +410,20 @@ module Value : sig
(** {3 Callbacks} *)
- type callstack = Value_types.callstack
-
(** Actions to perform at end of each function analysis. Not compatible with
option [-memexec-all] *)
module Record_Value_Callbacks:
- Hook.Iter_hook with type param = callstack * (state Stmt.Hashtbl.t) Lazy.t
+ Hook.Iter_hook
+ with type param = callstack * (state Stmt.Hashtbl.t) Lazy.t
module Record_Value_Superposition_Callbacks:
- Hook.Iter_hook with type param = callstack * (state list Stmt.Hashtbl.t) Lazy.t
+ Hook.Iter_hook
+ with type param = callstack * (state list Stmt.Hashtbl.t) Lazy.t
module Record_Value_After_Callbacks:
- Hook.Iter_hook with type param = callstack * (state Stmt.Hashtbl.t) Lazy.t
+ Hook.Iter_hook
+ with type param = callstack * (state Stmt.Hashtbl.t) Lazy.t
(**/**)
(* Temporary API, do not use *)
@@ -447,7 +452,7 @@ module Value : sig
@since Aluminium-20160501 *)
module Call_Type_Value_Callbacks:
Hook.Iter_hook with type param =
- [`Builtin of Value_types.call_froms | `Spec of funspec | `Def | `Memexec]
+ [`Builtin | `Spec | `Body | `Reuse]
* state * callstack
@@ -493,7 +498,7 @@ module Value : sig
(kernel_function -> call_kinstr:kinstr -> state -> (exp*t) list
-> Cvalue.V_Offsetmap.t option (** returned value of [kernel_function] *) * state) ref
*)
- val merge_initial_state : callstack -> state -> unit
+ val merge_initial_state : callstack -> kernel_function -> state -> unit
(** Store an additional possible initial state for the given callstack as
well as its values for actuals. *)
@@ -657,8 +662,9 @@ module Operational_inputs : sig
(**/**)
(* Internal use *)
module Record_Inout_Callbacks:
- Hook.Iter_hook with type param = Value_types.callstack * Inout_type.t
- (**/**)
+ Hook.Iter_hook with type param = Eva_types.Callstack.t * Inout_type.t
+ [@@alert "-db_deprecated"]
+ (**/**)
end
diff --git a/src/kernel_services/plugin_entry_points/kernel.ml b/src/kernel_services/plugin_entry_points/kernel.ml
index a3507a0ac08575dd11e660d284a235db59edd8c4..d7b572fffdd8a956478b1aff071702beb9f9abb4 100644
--- a/src/kernel_services/plugin_entry_points/kernel.ml
+++ b/src/kernel_services/plugin_entry_points/kernel.ml
@@ -171,6 +171,9 @@ let wkey_inconsistent_specifier =
let wkey_int_conversion =
register_warn_category "typing:int-conversion"
+let wkey_merge_conversion =
+ register_warn_category "typing:merge-conversion"
+
let wkey_cert_exp_46 = register_warn_category "CERT:EXP:46"
let wkey_cert_msc_37 = register_warn_category "CERT:MSC:37"
diff --git a/src/kernel_services/plugin_entry_points/kernel.mli b/src/kernel_services/plugin_entry_points/kernel.mli
index de72d6bb4dee30e023ad0cd0ce900a075ee3444f..0d3698e07a0ba10787cca970dd90d472c25179c5 100644
--- a/src/kernel_services/plugin_entry_points/kernel.mli
+++ b/src/kernel_services/plugin_entry_points/kernel.mli
@@ -168,6 +168,8 @@ val wkey_inconsistent_specifier: warn_category
val wkey_int_conversion: warn_category
+val wkey_merge_conversion: warn_category
+
val wkey_cert_exp_46: warn_category
val wkey_cert_msc_37: warn_category
diff --git a/src/kernel_services/plugin_entry_points/log.ml b/src/kernel_services/plugin_entry_points/log.ml
index d6923055b248a7c999c4f18fe72713416fffd46a..7ebcab452aa143a6475491be1570d120cce9a8e8 100644
--- a/src/kernel_services/plugin_entry_points/log.ml
+++ b/src/kernel_services/plugin_entry_points/log.ml
@@ -1133,7 +1133,13 @@ struct
?current ?source
?echo ?append text =
let status = get_warn_status wkey in
- if status <> Winactive then
+ let kind =
+ match status with
+ | Wfeedback | Wfeedback_once -> Feedback
+ | (Wactive | Werror | Wabort | Wonce | Werror_once | Winactive) ->
+ Warning
+ in
+ if status <> Winactive && (kind <> Feedback || verbose_atleast 1) then
begin
let action, once_suffix =
match status with
@@ -1157,12 +1163,6 @@ struct
| Some e, None | None, Some e -> Some e
| Some e1, Some e2 -> Some (fun evt -> e1 evt; e2 evt)
in
- let kind =
- match status with
- | Wfeedback | Wfeedback_once -> Feedback
- | (Wactive | Werror | Wabort | Wonce | Werror_once | Winactive) ->
- Warning
- in
let category = if wkey = "" then None else Some wkey in
let append_once_suffix = (fun fmt ->
Format.fprintf fmt
diff --git a/src/libraries/datatype/datatype.ml b/src/libraries/datatype/datatype.ml
index 014fa20993b2bcff1d4f4d9fd300d54f4284f0cd..7e01a4806faa1486fffb40b35dead1a9c534a8e2 100644
--- a/src/libraries/datatype/datatype.ml
+++ b/src/libraries/datatype/datatype.ml
@@ -412,7 +412,7 @@ module Polymorphic3
val mk_hash:
('a -> int) -> ('b -> int) -> ('c -> int) -> ('a, 'b, 'c) t -> int
val map:
- ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
+ ('a -> 'b) -> ('c -> 'd) -> ('e -> 'f) -> ('a, 'c, 'e) t -> ('b, 'd, 'f) t
val mk_pretty:
(Format.formatter -> 'a -> unit) ->
(Format.formatter -> 'b -> unit) ->
@@ -537,8 +537,8 @@ module Polymorphic4
('a -> int) -> ('b -> int) -> ('c -> int) -> ('d -> int) ->
('a, 'b, 'c, 'd) t -> int
val map:
- ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('d -> 'd) ->
- ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t
+ ('a -> 'b) -> ('c -> 'd) -> ('e -> 'f) -> ('g -> 'h) ->
+ ('a, 'c, 'e, 'g) t -> ('b, 'd, 'f, 'h) t
val mk_pretty:
(Format.formatter -> 'a -> unit) ->
(Format.formatter -> 'b -> unit) ->
@@ -775,7 +775,7 @@ module type Polymorphic_input = sig
val mk_equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val mk_compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
val mk_hash: ('a -> int) -> 'a t -> int
- val map: ('a -> 'a) -> 'a t -> 'a t
+ val map: ('a -> 'b) -> 'a t -> 'b t
val mk_pretty:
(Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
val mk_mem_project:
diff --git a/src/libraries/datatype/datatype.mli b/src/libraries/datatype/datatype.mli
index b89ecf6f486d39b43e5b637cccaf928cafc3ddc5..39e4baadec51035688238e414ffa8fe726f99f87 100644
--- a/src/libraries/datatype/datatype.mli
+++ b/src/libraries/datatype/datatype.mli
@@ -372,7 +372,7 @@ module Polymorphic
val mk_equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val mk_compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
val mk_hash: ('a -> int) -> 'a t -> int
- val map: ('a -> 'a) -> 'a t -> 'a t
+ val map: ('a -> 'b) -> 'a t -> 'b t
val mk_pretty:
(Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
val mk_mem_project:
@@ -402,7 +402,7 @@ module Polymorphic2
val mk_compare:
('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int
val mk_hash: ('a -> int) -> ('b -> int) -> ('a, 'b) t -> int
- val map: ('a -> 'a) -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t
+ val map: ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) t -> ('b, 'd) t
val mk_pretty:
(Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) ->
Format.formatter -> ('a, 'b) t -> unit
@@ -439,7 +439,7 @@ module Polymorphic3
val mk_hash:
('a -> int) -> ('b -> int) -> ('c -> int) -> ('a, 'b, 'c) t -> int
val map:
- ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
+ ('a -> 'b) -> ('c -> 'd) -> ('e -> 'f) -> ('a, 'c, 'e) t -> ('b, 'd, 'f) t
val mk_pretty:
(Format.formatter -> 'a -> unit) ->
(Format.formatter -> 'b -> unit) ->
@@ -483,8 +483,8 @@ module Polymorphic4
('a -> int) -> ('b -> int) -> ('c -> int) -> ('d -> int) ->
('a, 'b, 'c, 'd) t -> int
val map:
- ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('d -> 'd) ->
- ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t
+ ('a -> 'b) -> ('c -> 'd) -> ('e -> 'f) -> ('g -> 'h) ->
+ ('a, 'c, 'e, 'g) t -> ('b, 'd, 'f, 'h) t
val mk_pretty:
(Format.formatter -> 'a -> unit) ->
(Format.formatter -> 'b -> unit) ->
diff --git a/src/libraries/datatype/unmarshal.ml b/src/libraries/datatype/unmarshal.ml
index 826fa89b22e6fd902d34a82b438109c922b13b2c..fafe009f85285e66ea4b835cdd056e6af98cc1ec 100644
--- a/src/libraries/datatype/unmarshal.ml
+++ b/src/libraries/datatype/unmarshal.ml
@@ -725,16 +725,6 @@ register_custom "_n"
)
;;
-let ge_ocaml ~major ?(minor=0) ?(rev=0) () =
- let test x y z =
- x > major || (x = major && (y > minor || y = minor && z >= rev))
- in
- Scanf.sscanf Sys.ocaml_version "%d.%d.%d" test
-
-let ge_ocaml_4 = ge_ocaml ~major:4 ()
-
-let ge_ocaml_403 = ge_ocaml ~major:4 ~minor:3 ()
-
let t_unit = Abstract;;
let t_int = Abstract;;
let t_string = Abstract;;
@@ -752,12 +742,9 @@ let t_option = t_ref;;
let t_array a = Structure (Array a)
let t_queue a =
- if ge_ocaml_403 then
- (* queue cells are only a list-like structure, but there is
- no distinguishable difference at this level. *)
- t_record [| t_int; t_list a; t_list a |]
- else
- t_record [| t_int; t_list a |]
+ (* queue cells are only a list-like structure, but there is
+ no distinguishable difference at this level. *)
+ t_record [| t_int; t_list a; t_list a |]
(**** Hash tables ****)
@@ -777,10 +764,7 @@ and ('a, 'b) _bucketlist =
| Cons of 'a * 'b * ('a, 'b) _bucketlist
let t_hashtbl bucket =
- if not (ge_ocaml_4) then
- t_record [| Abstract ; t_array bucket |]
- else
- t_record [| Abstract ; t_array bucket; Abstract; Abstract |]
+ t_record [| Abstract ; t_array bucket; Abstract; Abstract |]
(* version 1: loading keys do not change their hash value *)
let t_hashtbl_unchangedhashs key value =
diff --git a/src/libraries/project/state_builder.ml b/src/libraries/project/state_builder.ml
index c93f9c167b30cdc49e3c100f6542147c4a548e67..a65f82560e349fd7979a1cba0a505e44f2ec960a 100644
--- a/src/libraries/project/state_builder.ml
+++ b/src/libraries/project/state_builder.ml
@@ -328,6 +328,7 @@ module type Ref = sig
val set: data -> unit
val get: unit -> data
val clear: unit -> unit
+ val add_hook_on_change: (data -> unit) -> unit
end
module Ref
@@ -353,9 +354,11 @@ struct
end)
(struct include Info let unique_name = name end)
- let set v = !state := v
+ module Change_hook = Hook.Build(Data)
+ let add_hook_on_change = Change_hook.extend
+ let set v = !state := v; Change_hook.apply v
let get () = !(!state)
- let clear () = !state := Info.default ()
+ let clear () = let v = Info.default () in set v
end
@@ -365,6 +368,7 @@ module type Option_ref = sig
val map: (data -> data) -> data option
val may: (data -> unit) -> unit
val get_option : unit -> data option
+ val add_hook_on_change: (data option -> unit) -> unit
end
module Option_ref(Data:Datatype.S)(Info: Info) = struct
@@ -375,6 +379,7 @@ module Option_ref(Data:Datatype.S)(Info: Info) = struct
let state = ref (create ())
module D = Datatype.Ref(Datatype.Option(Data))
+ module Change_hook = Hook.Build(Datatype.Option(Data))
include Register
(D)
@@ -389,10 +394,12 @@ module Option_ref(Data:Datatype.S)(Info: Info) = struct
end)
(struct include Info let unique_name = name end)
- let set v = !state := Some v
+ let add_hook_on_change = Change_hook.extend
+ let change opt_v = !state := opt_v; Change_hook.apply opt_v
+ let set v = change (Some v)
let get () = match !(!state) with None -> raise Not_found | Some v -> v
let get_option () = !(!state)
- let clear () = !state := None
+ let clear () = change None
let memo ?change f =
try
@@ -474,6 +481,11 @@ end
(** {3 Hashtbl} *)
(* ************************************************************************* *)
+type ('k,'v) hashtbl_event =
+ | Update of 'k * 'v
+ | Remove of 'k
+ | Clear
+
module type Hashtbl = sig
include S
type key
@@ -495,6 +507,7 @@ module type Hashtbl = sig
val mem: key -> bool
val remove: key -> unit
val to_seq: unit -> (key * data) Seq.t
+ val add_hook_on_change: ((key, data) hashtbl_event -> unit) -> unit
end
module Hashtbl
@@ -545,15 +558,19 @@ struct
end)
(struct include Info let unique_name = name end)
- let clear () = H.clear !state
+
+ module Change_hook = Hook.Build(struct type t = (key, data) hashtbl_event end)
+ let add_hook_on_change = Change_hook.extend
+ let clear () = H.clear !state; Change_hook.apply (Clear)
let length () = H.length !state
- let replace key v = H.replace !state key v
- let add key v = H.add !state key v
+ let replace key v =
+ H.replace !state key v; Change_hook.apply (Update (key, v))
+ let add key v = H.add !state key v; Change_hook.apply (Update (key, v))
let find key = H.find !state key
let find_opt key = H.find_opt !state key
let find_all key = H.find_all !state key
let mem key = H.mem !state key
- let remove key = H.remove !state key
+ let remove key = H.remove !state key; Change_hook.apply (Remove (key))
let iter f = H.iter f !state
let iter_sorted ?cmp f = H.iter_sorted ?cmp f !state
let fold f acc = H.fold f !state acc
diff --git a/src/libraries/project/state_builder.mli b/src/libraries/project/state_builder.mli
index 60a7bacace307b8face4ba02c71688789fa19cb1..ac53d7d75c780c7fde1eb1f6c52cd9125c9424b5 100644
--- a/src/libraries/project/state_builder.mli
+++ b/src/libraries/project/state_builder.mli
@@ -117,6 +117,11 @@ module type Ref = sig
val clear: unit -> unit
(** Reset the reference to its default value. *)
+
+ val add_hook_on_change: (data -> unit) -> unit
+ (** Add an hook which is applied each time (just after) the value of the state
+ changes inside the current project.
+ @since Frama-C+dev *)
end
(** @see <https://frama-c.com/download/frama-c-plugin-development-guide.pdf> Plug-in Development Guide *)
@@ -143,6 +148,11 @@ module type Option_ref = sig
val may: (data -> unit) -> unit
val get_option : unit -> data option
(** @since Beryllium-20090901 *)
+
+ val add_hook_on_change: (data option -> unit) -> unit
+ (** Add an hook which is applied each time (just after) the value of the state
+ changes inside the current project.
+ @since Frama-C+dev *)
end
(** Build a reference on an option. *)
@@ -314,6 +324,15 @@ module Hashconsing_tbl: Hashconsing_tbl
custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) *)
(* ************************************************************************* *)
+(** Events emitted when an [Hashtbl] state changes. *)
+type ('k,'v) hashtbl_event =
+ | Update of 'k * 'v
+ (** A binding in the hashtable has been added or modified. *)
+ | Remove of 'k
+ (** A binding in the hashtable has been removed. *)
+ | Clear
+ (** The hashtable has been cleared. *)
+
(** Output signature of builders of hashtables. *)
module type Hashtbl = sig
include S
@@ -365,6 +384,11 @@ module type Hashtbl = sig
val to_seq: unit -> (key * data) Seq.t
(** Iterate on the whole table.
@since 27.0-Cobalt *)
+
+ val add_hook_on_change: ((key, data) hashtbl_event -> unit) -> unit
+ (** Add an hook which is applied each time (just after) a (key,value) pair in
+ the hashtable changes inside the current project.
+ @since Frama-C+dev *)
end
(** @see <https://frama-c.com/download/frama-c-plugin-development-guide.pdf> Plug-in Development Guide
diff --git a/src/libraries/stdlib/extlib.mli b/src/libraries/stdlib/extlib.mli
index a0ef80e7ff15352ba41fb79f4e3e8a0bce104b87..3b158d16c21a20457d0077ca7939f34b4e6a0257 100644
--- a/src/libraries/stdlib/extlib.mli
+++ b/src/libraries/stdlib/extlib.mli
@@ -194,11 +194,14 @@ val opt_map2: ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option
(* ************************************************************************* *)
val string_prefix: ?strict:bool -> string -> string -> bool
+[@@alert deprecated "Use String.starts_with instead"]
(** [string_prefix ~strict p s] returns [true] if and only if [p] is a
prefix of the string [s]. If [strict] is true, the prefix must be strict
(that is, [s] must moreover be strictly longer than [p]). [strict]
is false by default.
- @since Boron-20100401 *)
+ @since Boron-20100401
+ @deprecated Frama-C+dev use 'String.starts_with' instead
+*)
val string_del_prefix: ?strict:bool -> string -> string -> string option
(** [string_del_prefix ~strict p s] returns [None] if [p] is not a prefix of
@@ -206,10 +209,12 @@ val string_del_prefix: ?strict:bool -> string -> string -> string option
@since Oxygen-20120901 *)
val string_suffix: ?strict:bool -> string -> string -> bool
+[@@alert deprecated "Use String.ends_with instead"]
(** [string_suffix ~strict suf s] returns [true] iff [suf] is a suffix of
string [s]. [strict], which defaults to [false], indicates whether [s]
should be strictly longer than [p].
@since Aluminium-20160501
+ @deprecated Frama-C+dev use 'String.ends_with' instead
*)
val string_del_suffix: ?strict:bool -> string -> string -> string option
diff --git a/src/libraries/stdlib/transitioning.ml b/src/libraries/stdlib/transitioning.ml
index 747e2811e0bb8fd639f4ab40a1ba9de3d105df22..38937e6f5cbdd8f968d744b6d7dfb2542a655480 100644
--- a/src/libraries/stdlib/transitioning.ml
+++ b/src/libraries/stdlib/transitioning.ml
@@ -22,31 +22,6 @@
(* Generated file. The file to update is [transitioning.ml.in] *)
-module List = struct
-
- let concat_map f l =
- let rec aux f acc = function
- | [] -> List.rev acc
- | x :: l ->
- let xs = f x in
- aux f (List.rev_append xs acc) l
- in aux f [] l
-
- let equal f l1 l2 =
- l1 == l2 || try List.for_all2 f l1 l2 with Invalid_argument _ -> false
-
- let rec compare f l1 l2 =
- if l1 == l2 then 0
- else match l1, l2 with
- | [], [] -> assert false
- | [], _ :: _ -> -1
- | _ :: _, [] -> 1
- | x1 :: q1, x2 :: q2 ->
- let n = f x1 x2 in
- if n = 0 then compare f q1 q2 else n
-end
-
-
module Seq = struct
open Stdlib.Seq
@@ -57,11 +32,6 @@ module Seq = struct
let unzip seq =
map fst seq, map snd seq
- let rec append xs ys () =
- match xs () with
- | Nil -> ys ()
- | Cons (x, xt) -> Cons (x, append xt ys)
-
let is_empty xs =
match xs () with
| Nil -> true
diff --git a/src/libraries/stdlib/transitioning.mli b/src/libraries/stdlib/transitioning.mli
index 3be73b061e217174606f3e5d4d2f29ac56d55f0f..1954b47f420ad0981b2c2dc7f5c78d8fee853f75 100644
--- a/src/libraries/stdlib/transitioning.mli
+++ b/src/libraries/stdlib/transitioning.mli
@@ -32,17 +32,6 @@
(** {1 OCaml} *)
-module List: sig
- (** since 4.10.0 *)
- val concat_map: ('a -> 'b list) -> 'a list -> 'b list
-
- (** since 4.12.0 *)
- val equal: ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
-
- (** since 4.12.0 *)
- val compare: ('a -> 'a -> int) -> 'a list -> 'a list -> int
-end
-
module Seq: sig
open Stdlib.Seq
@@ -55,9 +44,6 @@ module Seq: sig
(** since 4.14.0 *)
val unzip : ('a * 'b) t -> 'a t * 'b t
- (** since 4.11.0 *)
- val append : 'a t -> 'a t -> 'a t
-
(** since 4.14.0 *)
val drop : int -> 'a t -> 'a t
end
diff --git a/src/libraries/utils/filepath.ml b/src/libraries/utils/filepath.ml
index 6292a93db464c60761f6981912fdac4a949eebd8..b2ea6e9bf6e0db85d1e1970015e9133a92dccf73 100644
--- a/src/libraries/utils/filepath.ml
+++ b/src/libraries/utils/filepath.ml
@@ -226,7 +226,7 @@ let add_path path =
| Some symb -> symb ^ Buffer.contents buf
let rec skip_dot file_name =
- if Extlib.string_prefix "./" file_name then
+ if String.starts_with ~prefix:"./" file_name then
skip_dot (String.sub file_name 2 (String.length file_name - 2))
else file_name
@@ -237,7 +237,8 @@ let pretty file_name =
let path = insert cwd file_name in
let file_name = path.path_name in
let cwd_name = cwd.path_name in
- if Extlib.string_prefix ~strict:true cwd_name file_name then
+ if String.starts_with ~prefix:cwd_name file_name && cwd_name <> file_name
+ then
let n = 1 + String.length cwd_name in
String.sub file_name n (String.length file_name - n)
else
@@ -255,7 +256,7 @@ let relativize ?base_name file_name =
in
if base_name = file_name then "." else
let base_name = base_name ^ Filename.dir_sep in
- if Extlib.string_prefix base_name file_name then
+ if String.starts_with ~prefix:base_name file_name then
let n = String.length base_name in
let file_name = String.sub file_name n (String.length file_name - n) in
if file_name = "" then "." else file_name
@@ -268,7 +269,7 @@ let is_relative ?base_name file_name =
| Some b -> (insert cwd b).path_name
in
base_name = file_name
- || Extlib.string_prefix (base_name ^ Filename.dir_sep) file_name
+ || String.starts_with ~prefix:(base_name ^ Filename.dir_sep) file_name
(* -------------------------------------------------------------------------- *)
(* --- Normalized Typed Module --- *)
diff --git a/src/libraries/utils/hptmap.ml b/src/libraries/utils/hptmap.ml
index b1fff81fcd0702622895d473cd5717a959edf906..04d64f4fbae2c351ec37449dbb1179535c1b3dba 100644
--- a/src/libraries/utils/hptmap.ml
+++ b/src/libraries/utils/hptmap.ml
@@ -343,7 +343,7 @@ module Shape(Key: Id_Datatype) = struct
| Empty -> Seq.Nil
| Leaf (key, data, _) -> Seq.Cons ((key, data), Seq.empty)
| Branch (_, _, tree0, tree1, _) ->
- Transitioning.Seq.append (to_seq tree0) (to_seq tree1) ()
+ Seq.append (to_seq tree0) (to_seq tree1) ()
(* This reference will contain a list of functions that will clear
all the transient caches used in this module *)
diff --git a/src/plugins/alias/abstract_state.mli b/src/plugins/alias/abstract_state.mli
index 8506611bc0f61251f5ee4b60f44506145c9fff96..9dc69a23d052c81ef2b0a46b3f47965504ce9d6d 100644
--- a/src/plugins/alias/abstract_state.mli
+++ b/src/plugins/alias/abstract_state.mli
@@ -64,7 +64,8 @@ sig
(** dot printer; first argument is a file name *)
val print_dot : string -> t -> unit
- (** finds the vertex corresponding to a lval. May raise @Not_found
+ (** finds the vertex corresponding to a lval.
+ @raise Not_found if such a vertex does not exist
*)
val find_vertex : lval -> t -> G.V.t
diff --git a/src/plugins/alias/simplified.ml b/src/plugins/alias/simplified.ml
index 8250af8e229b46ebca8acba3184ef2e89bcafaad..95d0f57925464ef1d49de7e43776e03b9690c4b6 100644
--- a/src/plugins/alias/simplified.ml
+++ b/src/plugins/alias/simplified.ml
@@ -23,7 +23,7 @@
open Cil_types
open Cil_datatype
-let nul_exp= Cil.zero ~loc:Location.unknown
+let nul_exp= Cil.kinteger64 ~loc:Location.unknown ~repr:"0.." ~kind:IInt Integer.zero
let is_nul_exp = Cil_datatype.ExpStructEq.equal nul_exp
module HL = Lval.Hashtbl
diff --git a/src/plugins/alias/tests/offsets/oracle/nested1.res.oracle b/src/plugins/alias/tests/offsets/oracle/nested1.res.oracle
index e26a96622ddd53633ec3d0978ac43635f1dc1e4f..c5ee52ba984709aa7ae197c147b0a8fdd6eaabb8 100644
--- a/src/plugins/alias/tests/offsets/oracle/nested1.res.oracle
+++ b/src/plugins/alias/tests/offsets/oracle/nested1.res.oracle
@@ -77,31 +77,31 @@
[alias:unsafe-cast] nested1.c:47: Warning:
unsafe cast from st_1_t * to struct struct_1_t *
[alias] May-aliases after instruction z1->s = (struct struct_1_t *)tab_y[0]; are
- {z1->s, tab_y[0]}
+ {z1->s, tab_y[0..]}
[alias] analysing instruction: z2->s = (struct struct_1_t *)tab_y[1];
[alias:unsafe-cast] nested1.c:48: Warning:
unsafe cast from st_1_t * to struct struct_1_t *
[alias] May-aliases after instruction z2->s = (struct struct_1_t *)tab_y[1]; are
- {z1->s, z2->s, tab_y[0]}
+ {z1->s, z2->s, tab_y[0..]}
[alias] analysing instruction: z1->c = a;
[alias] May-aliases after instruction z1->c = a; are
- {z1->s, z2->s, tab_y[0]} {z1->c, a}
+ {z1->s, z2->s, tab_y[0..]} {z1->c, a}
[alias] analysing instruction: z2->c = b;
[alias] May-aliases after instruction z2->c = b; are
- {z1->s, z2->s, tab_y[0]} {z1->c, a} {z2->c, b}
+ {z1->s, z2->s, tab_y[0..]} {z1->c, a} {z2->c, b}
[alias] analysing instruction: t->t = (struct struct_2_t *)z1;
[alias:unsafe-cast] nested1.c:51: Warning:
unsafe cast from st_2_t * to struct struct_2_t *
[alias] May-aliases after instruction t->t = (struct struct_2_t *)z1; are
- {z1->s, z2->s, tab_y[0]} {t->t, z1} {z1->c, a} {z2->c, b}
+ {z1->s, z2->s, tab_y[0..]} {t->t, z1} {z1->c, a} {z2->c, b}
[alias] analysing instruction: t->d = a;
[alias] May-aliases after instruction t->d = a; are
- {z1->s, z2->s, tab_y[0]} {t->t, z1} {z1->c, t->d, a} {z2->c, b}
+ {z1->s, z2->s, tab_y[0..]} {t->t, z1} {z1->c, t->d, a} {z2->c, b}
[alias] analysing instruction: __retres = 0;
[alias] May-aliases after instruction __retres = 0; are
- {z1->s, z2->s, tab_y[0]} {t->t, z1} {z1->c, t->d, a} {z2->c, b}
+ {z1->s, z2->s, tab_y[0..]} {t->t, z1} {z1->c, t->d, a} {z2->c, b}
[alias] May-aliases at the end of function main:
- {z1->s, z2->s, tab_y[0]} {t->t, z1} {z1->c, t->d, a} {z2->c, b}
+ {z1->s, z2->s, tab_y[0..]} {t->t, z1} {z1->c, t->d, a} {z2->c, b}
[alias] analysing function: malloc
[alias] May-aliases at the end of function malloc: ⊥
[alias] analysing function: mblen
diff --git a/src/plugins/alias/tests/real_world/oracle/example1.res.oracle b/src/plugins/alias/tests/real_world/oracle/example1.res.oracle
index 2184e66ef66ccd9e68cdee8db84944dbaa773d5f..466fd5543e5bcb45fb418334dd5260eac5d45efc 100644
--- a/src/plugins/alias/tests/real_world/oracle/example1.res.oracle
+++ b/src/plugins/alias/tests/real_world/oracle/example1.res.oracle
@@ -96,25 +96,25 @@
idata = (double *)malloc((unsigned long)10 * sizeof(double)); are {x, tmp}
[alias] analysing instruction: idata = tmp->t2[*(tmp->n2)];
[alias] May-aliases after instruction idata = tmp->t2[*(tmp->n2)]; are
- {x, tmp} {tmp->t2[0], idata}
+ {x, tmp} {tmp->t2[0..], idata}
[alias] analysing instruction: odata = tmp->t1[*(tmp->n1)];
[alias] May-aliases after instruction odata = tmp->t1[*(tmp->n1)]; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: idx = 0;
[alias] May-aliases after instruction idx = 0; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: tmp_1 = sin(*(idata + idx));
[alias] analysing function: sin
[alias] May-aliases at the end of function sin: ⊥
[alias:undefined:fn] example1.c:45: Warning: function sin has no definition
[alias] May-aliases after instruction tmp_1 = sin(*(idata + idx)); are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: *(odata + idx) = 0.5 * tmp_1;
[alias] May-aliases after instruction *(odata + idx) = 0.5 * tmp_1; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: idx ++;
[alias] May-aliases after instruction idx ++; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: swap(tmp->n1);
[alias] analysing function: swap
[alias] analysing instruction: *n = 0;
@@ -123,13 +123,13 @@
[alias] May-aliases after instruction (*n) ++; are <none>
[alias] May-aliases at the end of function swap: <none>
[alias] May-aliases after instruction swap(tmp->n1); are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: idata = tmp->t2[*(tmp->n2)];
[alias] May-aliases after instruction idata = tmp->t2[*(tmp->n2)]; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: odata = tmp->t1[*(tmp->n1)];
[alias] May-aliases after instruction odata = tmp->t1[*(tmp->n1)]; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias:no-return] example1.c:29: Warning:
function f1 does not return; analysis may be unsound
[alias] May-aliases at the end of function f1: <none>
@@ -142,30 +142,30 @@
idata = (double *)malloc((unsigned long)10 * sizeof(double)); are {x, tmp}
[alias] analysing instruction: idata = tmp->t1[*(tmp->n1)];
[alias] May-aliases after instruction idata = tmp->t1[*(tmp->n1)]; are
- {x, tmp} {tmp->t1[0], idata}
+ {x, tmp} {tmp->t1[0..], idata}
[alias] analysing instruction: odata = tmp->t2[*(tmp->n2)];
[alias] May-aliases after instruction odata = tmp->t2[*(tmp->n2)]; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: idx = 0;
[alias] May-aliases after instruction idx = 0; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction:
*(odata + idx) = (double)3 * *(idata + idx) + (double)1;
[alias] May-aliases after instruction
*(odata + idx) = (double)3 * *(idata + idx) + (double)1; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: idx ++;
[alias] May-aliases after instruction idx ++; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: swap(tmp->n2);
[alias] May-aliases after instruction swap(tmp->n2); are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: idata = tmp->t1[*(tmp->n1)];
[alias] May-aliases after instruction idata = tmp->t1[*(tmp->n1)]; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: odata = tmp->t2[*(tmp->n2)];
[alias] May-aliases after instruction odata = tmp->t2[*(tmp->n2)]; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias:no-return] example1.c:53: Warning:
function f2 does not return; analysis may be unsound
[alias] May-aliases at the end of function f2: <none>
@@ -274,36 +274,41 @@
[alias] May-aliases after instruction i = 0; are <none>
[alias] analysing instruction: b->t1[i] = a->t1[i];
[alias] May-aliases after instruction b->t1[i] = a->t1[i]; are
- {a->t1[0], b->t1[0]}
+ {a->t1[0..], b->t1[0..]}
[alias] analysing instruction: b->t2[i] = a->t2[i];
[alias] May-aliases after instruction b->t2[i] = a->t2[i]; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]}
[alias] analysing instruction: i ++;
[alias] May-aliases after instruction i ++; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]}
[alias] analysing instruction: b->t1[i] = a->t1[i];
[alias] May-aliases after instruction b->t1[i] = a->t1[i]; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]}
[alias] analysing instruction: b->t2[i] = a->t2[i];
[alias] May-aliases after instruction b->t2[i] = a->t2[i]; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]}
[alias] analysing instruction: b->n1 = a->n1;
[alias] May-aliases after instruction b->n1 = a->n1; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
[alias] analysing instruction: b->n2 = a->n2;
[alias] May-aliases after instruction b->n2 = a->n2; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] analysing instruction: f1(a);
[alias] May-aliases after instruction f1(a); are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] analysing instruction: f2(b);
[alias] May-aliases after instruction f2(b); are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] analysing instruction: __retres = 0;
[alias] May-aliases after instruction __retres = 0; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] May-aliases at the end of function main:
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] analysing function: malloc
[alias] May-aliases at the end of function malloc: ⊥
[alias] analysing function: mblen
diff --git a/src/plugins/alias/tests/real_world/oracle/example2.res.oracle b/src/plugins/alias/tests/real_world/oracle/example2.res.oracle
index 21f8829b4dc8c670f933cedca6281dd899cd434f..d4791a4c79009721c7e4d2641777be15812cab88 100644
--- a/src/plugins/alias/tests/real_world/oracle/example2.res.oracle
+++ b/src/plugins/alias/tests/real_world/oracle/example2.res.oracle
@@ -98,25 +98,25 @@
[alias] May-aliases after instruction int i = 0; are {x, tmp}
[alias] analysing instruction: idata = tmp->t2[*(tmp->n2)];
[alias] May-aliases after instruction idata = tmp->t2[*(tmp->n2)]; are
- {x, tmp} {tmp->t2[0], idata}
+ {x, tmp} {tmp->t2[0..], idata}
[alias] analysing instruction: odata = tmp->t1[*(tmp->n1)];
[alias] May-aliases after instruction odata = tmp->t1[*(tmp->n1)]; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: idx = 0;
[alias] May-aliases after instruction idx = 0; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: tmp_1 = sin(*(idata + idx));
[alias] analysing function: sin
[alias] May-aliases at the end of function sin: ⊥
[alias:undefined:fn] example2.c:45: Warning: function sin has no definition
[alias] May-aliases after instruction tmp_1 = sin(*(idata + idx)); are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: *(odata + idx) = 0.5 * tmp_1;
[alias] May-aliases after instruction *(odata + idx) = 0.5 * tmp_1; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: idx ++;
[alias] May-aliases after instruction idx ++; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: swap(tmp->n1);
[alias] analysing function: swap
[alias] analysing instruction: *n = 0;
@@ -125,21 +125,21 @@
[alias] May-aliases after instruction (*n) ++; are <none>
[alias] May-aliases at the end of function swap: <none>
[alias] May-aliases after instruction swap(tmp->n1); are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: i ++;
[alias] May-aliases after instruction i ++; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: idata = tmp->t2[*(tmp->n2)];
[alias] May-aliases after instruction idata = tmp->t2[*(tmp->n2)]; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: odata = tmp->t1[*(tmp->n1)];
[alias] May-aliases after instruction odata = tmp->t1[*(tmp->n1)]; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing instruction: __retres = (void *)0;
[alias] May-aliases after instruction __retres = (void *)0; are
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] May-aliases at the end of function f1:
- {x, tmp} {tmp->t2[0], idata} {tmp->t1[0], odata}
+ {x, tmp} {tmp->t2[0..], idata} {tmp->t1[0..], odata}
[alias] analysing function: f2
[alias] analysing instruction: ty *tmp = x;
[alias] May-aliases after instruction ty *tmp = x; are {x, tmp}
@@ -151,38 +151,38 @@
[alias] May-aliases after instruction int i = 0; are {x, tmp}
[alias] analysing instruction: idata = tmp->t1[*(tmp->n1)];
[alias] May-aliases after instruction idata = tmp->t1[*(tmp->n1)]; are
- {x, tmp} {tmp->t1[0], idata}
+ {x, tmp} {tmp->t1[0..], idata}
[alias] analysing instruction: odata = tmp->t2[*(tmp->n2)];
[alias] May-aliases after instruction odata = tmp->t2[*(tmp->n2)]; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: idx = 0;
[alias] May-aliases after instruction idx = 0; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction:
*(odata + idx) = (double)3 * *(idata + idx) + (double)1;
[alias] May-aliases after instruction
*(odata + idx) = (double)3 * *(idata + idx) + (double)1; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: idx ++;
[alias] May-aliases after instruction idx ++; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: swap(tmp->n2);
[alias] May-aliases after instruction swap(tmp->n2); are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: i ++;
[alias] May-aliases after instruction i ++; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: idata = tmp->t1[*(tmp->n1)];
[alias] May-aliases after instruction idata = tmp->t1[*(tmp->n1)]; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: odata = tmp->t2[*(tmp->n2)];
[alias] May-aliases after instruction odata = tmp->t2[*(tmp->n2)]; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing instruction: __retres = (void *)0;
[alias] May-aliases after instruction __retres = (void *)0; are
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] May-aliases at the end of function f2:
- {x, tmp} {tmp->t1[0], idata} {tmp->t2[0], odata}
+ {x, tmp} {tmp->t1[0..], idata} {tmp->t2[0..], odata}
[alias] analysing function: fabs
[alias] May-aliases at the end of function fabs: ⊥
[alias] analysing function: fabsf
@@ -288,36 +288,41 @@
[alias] May-aliases after instruction i = 0; are <none>
[alias] analysing instruction: b->t1[i] = a->t1[i];
[alias] May-aliases after instruction b->t1[i] = a->t1[i]; are
- {a->t1[0], b->t1[0]}
+ {a->t1[0..], b->t1[0..]}
[alias] analysing instruction: b->t2[i] = a->t2[i];
[alias] May-aliases after instruction b->t2[i] = a->t2[i]; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]}
[alias] analysing instruction: i ++;
[alias] May-aliases after instruction i ++; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]}
[alias] analysing instruction: b->t1[i] = a->t1[i];
[alias] May-aliases after instruction b->t1[i] = a->t1[i]; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]}
[alias] analysing instruction: b->t2[i] = a->t2[i];
[alias] May-aliases after instruction b->t2[i] = a->t2[i]; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]}
[alias] analysing instruction: b->n1 = a->n1;
[alias] May-aliases after instruction b->n1 = a->n1; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
[alias] analysing instruction: b->n2 = a->n2;
[alias] May-aliases after instruction b->n2 = a->n2; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] analysing instruction: f1(a);
[alias] May-aliases after instruction f1(a); are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] analysing instruction: f2(b);
[alias] May-aliases after instruction f2(b); are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] analysing instruction: __retres = 0;
[alias] May-aliases after instruction __retres = 0; are
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] May-aliases at the end of function main:
- {a->t1[0], b->t1[0]} {a->t2[0], b->t2[0]} {a->n1, b->n1} {a->n2, b->n2}
+ {a->t1[0..], b->t1[0..]} {a->t2[0..], b->t2[0..]} {a->n1, b->n1}
+ {a->n2, b->n2}
[alias] analysing function: malloc
[alias] May-aliases at the end of function malloc: ⊥
[alias] analysing function: mblen
diff --git a/src/plugins/callgraph/gui/cg_viewer.ml b/src/plugins/callgraph/gui/cg_viewer.ml
deleted file mode 100644
index 4eba1034a11d87411f1f87c1e479ad84ddb9a92a..0000000000000000000000000000000000000000
--- a/src/plugins/callgraph/gui/cg_viewer.ml
+++ /dev/null
@@ -1,252 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2007-2023 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It is distributed in the hope that it will be useful, *)
-(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
-(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
-(* GNU Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Graph.S
-
-let ($) f x = f x
-
-type service_id = int
-
-module Service_view = DGraphContainer.Make(Services.Graphviz_attributes)
-
-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.create 10
-
- method is_root (n:'v DGraphViewItem.view_item) = n#item.Service_graph.is_root
-
- method is_deployed id =
- try !(fst (Hashtbl.find services id)) with Not_found -> assert false
-
- method edge_kind (e: 'e DGraphViewItem.view_item) =
- Services.G.E.label e#item
-
- method deploy node =
- assert (self#is_root node);
- let service = self#service node in
- let deployed, nodes = Hashtbl.find services service in
- assert (not !deployed);
- deployed := true;
- (* iterating on nodes of the current service *)
- List.iter
- (fun n ->
- n#compute ();
- 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 ->
- e#compute ();
- e#show ()
- | Service_graph.Inter_services ->
- e#hide ())
- n)
- !nodes
-
- method undeploy node =
- assert (self#is_root node);
- let service = self#service node in
- let deployed, nodes = Hashtbl.find services service in
- assert !deployed;
- deployed := false;
- (* iterating on nodes of the current service *)
- List.iter
- (fun n ->
- 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 ())
- n)
- !nodes
-
- method service n =
- 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 _ ->
- if self#is_deployed (self#service n) then self#undeploy n
- else self#deploy n;
- false
- | _ ->
- false
- 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 ())
-
-end
-
-(* Constructor copied from dGraphView *)
-let services_view model =
- let delay_node v = not v.Service_graph.is_root in
- let delay_edge e = match Services.G.E.label e with
- | Service_graph.Inter_services | Service_graph.Both -> false
- | Service_graph.Inter_functions -> true
- in
- let view = Service_view.GView.view ~aa:true ~delay_node ~delay_edge model in
- view#set_zoom_padding 0.025;
- (* not very nice *)
- ignore (new services_view view);
- view#connect_highlighting_event ();
- ignore $ view#set_center_scroll_region true;
- view
-
-let make_service_view ~packing () =
- let _, view =
- Service_view.from_graph_with_commands
- ~packing
- ?root:(Services.entry_point ())
- ~mk_global_view:services_view
- (Services.Subgraph.get ())
- in
- view
-
-module Cg_view = DGraphContainer.Make(Cg.Graphviz_attributes)
-
-let make_cg_view ?root ~packing (): Cg_view.view_container =
- let _, view =
- Cg_view.from_graph_with_commands ~packing ?root (Cg.Subgraph.get ())
- in
- view
-
-(* note: root is only used when services are not computed *)
-let make_graph_view ?root services ~packing () =
- if services then
- (make_service_view ~packing () :> <adapt_zoom: unit -> unit>)
- else
- (make_cg_view ?root ~packing () :> <adapt_zoom: unit -> unit >)
-
-let has_entry_point () =
- try ignore (Globals.entry_point ()); true
- with Globals.No_such_entry_point _ -> false
-
-let can_show_service_graph () =
- has_entry_point () && Options.Service_roots.is_empty ()
-
-let get_current_function () =
- match History.get_current () with
- | Some (History.Global (Cil_types.GFunDecl (_, vi, _)))
- | Some (History.Global (Cil_types.GFun ({Cil_types.svar = vi}, _))) ->
- let kf =
- try Globals.Functions.get vi
- with Not_found -> Options.fatal "no kf for %a" Printer.pp_varinfo vi
- in
- if Kernel_function.is_definition kf then Some kf else None
- | Some (History.Localizable l) -> Pretty_source.kf_of_localizable l
- | _ -> None
-
-let warn_degrade reason =
- GToolbox.message_box ~title:"Warning"
- ("Services cannot be displayed due to " ^ reason ^
- ".\n\
- View degraded to non-service graph.\n\
- (use -cg-no-services to avoid this warning)")
-
-let main (window: Design.main_window_extension_points) =
- ignore
- ((window#menu_manager ())#add_plugin
- [ Menu_manager.menubar "Show entire callgraph"
- (Menu_manager.Unit_callback (fun () ->
- (* note: if there is no entry point, or if the set of service
- roots is not empty, we must 'degrade' the view and show a
- non-service graph *)
- let services, warn =
- if Options.Services.get () then
- let degrade = not (can_show_service_graph ()) in
- not degrade, degrade
- else false, false
- in
- try
- (* display the callgraph through its dot output *)
- Service_graph.frama_c_display true;
- Dgraph_helper.graph_window
- ~parent:window#main_window ~title:"Callgraph"
- (make_graph_view services);
- if warn then
- warn_degrade
- (if not (has_entry_point ()) then "absence of entry point"
- else "set of service roots being non-empty")
- with ex ->
- GToolbox.message_box ~title:"Error"
- ("Error loading callgraph: " ^ (Printexc.to_string ex))
- ));
- Menu_manager.menubar "Show callgraph from current function"
- ~sensitive:(fun () -> get_current_function () <> None)
- (Menu_manager.Unit_callback (fun () ->
- match get_current_function () with
- | None ->
- GToolbox.message_box ~title:"Error" "Error: no current function"
- | Some kf ->
- try
- (* save old value, to restore it later *)
- let old_roots = Options.Roots.get () in
- Options.Roots.set (Kernel_function.Set.singleton kf);
- let services, warn =
- if Options.Services.get () && can_show_service_graph ()
- then begin
- ignore (Services.Subgraph.get ()); (* compute subgraph *)
- let is_root = Services.is_root kf in
- is_root, not is_root
- end
- else false, false
- in
- Service_graph.frama_c_display true;
- Dgraph_helper.graph_window
- ~parent:window#main_window ~title:"Callgraph"
- (make_graph_view ~root:kf services);
- (* restore old value *)
- Options.Roots.set old_roots;
- if warn then
- warn_degrade "node not being a service root"
- with ex ->
- GToolbox.message_box ~title:"Error"
- ("Error loading callgraph: " ^ (Printexc.to_string ex))
- ))
- ])
-
-let () = Design.register_extension main
-
-(*
-Local Variables:
-compile-command: "make -C ../../.."
-End:
-*)
diff --git a/src/plugins/callgraph/gui/dune b/src/plugins/callgraph/gui/dune
deleted file mode 100644
index 2d7ced2c466c5031ed2d6422d4f28713df95afec..0000000000000000000000000000000000000000
--- a/src/plugins/callgraph/gui/dune
+++ /dev/null
@@ -1,50 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;
-;; This file is part of Frama-C. ;;
-;; ;;
-;; Copyright (C) 2007-2023 ;;
-;; 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). ;;
-;; ;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(rule
- (alias frama-c-configure)
- (deps (universe))
- (action (progn
- (echo "Callgraph GUI:" %{lib-available:frama-c-callgraph.gui} "\n")
- (echo " - Frama-C GUI:" %{lib-available:frama-c.gui} "\n")
- (echo " - Callgraph:" %{lib-available:frama-c-callgraph.core} "\n")
- (echo " - Ocamlgraph_gtk:" %{lib-available:ocamlgraph_gtk} "\n")
- (echo " - Ocamlgraph Dgraph:" %{lib-available:ocamlgraph.dgraph} "\n")
- )
- )
-)
-
-( library
- (name callgraph_gui)
- (public_name frama-c-callgraph.gui)
- (optional)
- (flags -open Frama_c_kernel -open Frama_c_gui -open Callgraph :standard -w -9)
- (libraries
- frama-c.kernel frama-c.gui frama-c-callgraph.core
- (select graph.ml from
- (!lablgtk3-sourceview3 ocamlgraph.dgraph -> graph.dgraph.ml)
- (!lablgtk3-sourceview3 ocamlgraph_gtk -> graph.gtk.ml)
- )
- )
-)
-
-(plugin (optional) (name callgraph-gui) (libraries frama-c-callgraph.gui) (site (frama-c plugins_gui)))
diff --git a/src/plugins/dive/build.ml b/src/plugins/dive/build.ml
index acfa92afaa6498c25af003240e6b683123fe89b6..016d29aa3e101ea5fce05287237a543353ff1790 100644
--- a/src/plugins/dive/build.ml
+++ b/src/plugins/dive/build.ml
@@ -275,6 +275,7 @@ let find_compatible_callstacks stmt callstack =
let callstacks = Eval.to_callstacks stmt in
(* TODO: missing callstacks filtered by memexec *)
let make_compatible cs =
+ let cs = List.rev (Eva.Callstack.to_call_list cs) in
Callstack.truncate_to_sub cs callstack |>
Option.value ~default:(Callstack.init kf)
in
diff --git a/src/plugins/dive/callstack.ml b/src/plugins/dive/callstack.ml
index f9d329ef16cdd90fae218dcf7d93669d60059f2d..8f94e127823b61085b9b25315ffa0fd97d4353e9 100644
--- a/src/plugins/dive/callstack.ml
+++ b/src/plugins/dive/callstack.ml
@@ -22,10 +22,11 @@
open Cil_types
-include Value_types.Callstack
+module Callsite = Datatype.Pair (Kernel_function) (Cil_datatype.Kinstr)
+type call_site = Callsite.t
-type call_site = Value_types.call_site
-module Callsite = Value_types.Callsite
+include Datatype.With_collections (Datatype.List (Callsite))
+ (struct let module_name = "Dive.Callstack" end)
let init kf = [(kf,Kglobal)]
diff --git a/src/plugins/dive/dive_graph.ml b/src/plugins/dive/dive_graph.ml
index ef3c84076d6d3a39afe77c1c39c0786fc8602102..d6aeae490d92bb6f49896e464b6cef67087a53ec 100644
--- a/src/plugins/dive/dive_graph.ml
+++ b/src/plugins/dive/dive_graph.ml
@@ -177,7 +177,7 @@ let output_to_dot out_channel g =
let build_label s = `HtmlLabel (Extlib.html_escape s) in
let module FileTable = Datatype.String.Hashtbl in
- let module CallstackTable = Value_types.Callstack.Hashtbl in
+ let module CallstackTable = Callstack.Hashtbl in
let file_table = FileTable.create 13
and callstack_table = CallstackTable.create 13 in
let file_counter = ref 0 in
diff --git a/src/plugins/e-acsl/doc/Changelog b/src/plugins/e-acsl/doc/Changelog
index 8d365c6d4a829724b44bdaac91bb6c491d01fb05..d0829960b6f98351aafa8264a28f34ae5934c948 100644
--- a/src/plugins/e-acsl/doc/Changelog
+++ b/src/plugins/e-acsl/doc/Changelog
@@ -25,6 +25,10 @@
Plugin E-ACSL <next-release>
###############################################################################
+###############################################################################
+Plugin E-ACSL 27.1 (Cobalt)
+###############################################################################
+
###############################################################################
Plugin E-ACSL 27.0 (Cobalt)
###############################################################################
diff --git a/src/plugins/e-acsl/doc/refman/changes_modern.tex b/src/plugins/e-acsl/doc/refman/changes_modern.tex
index 3e7e104758318f6448f261ddcb560e5ecab516f9..a44b0e55677d65978a2285ef9087128ea08ed910 100644
--- a/src/plugins/e-acsl/doc/refman/changes_modern.tex
+++ b/src/plugins/e-acsl/doc/refman/changes_modern.tex
@@ -1,7 +1,19 @@
\section{Changes}
% Next version
-%\subsection*{Version \version}
+\subsection*{Version \version}
+\begin{itemize}
+ \item Update according to \acsl 1.19
+ \begin{itemize}
+ \item \changeinsection{memory}{add the \lstinline|\\object_pointer| and
+ \lstinline|\\pointer_comparable| built-in predicates}
+ \end{itemize}
+\end{itemize}
+
+\subsection*{Version 1.18}
+\begin{itemize}
+ \item No changes: changes in \acsl 1.18 do not impact \eacsl.
+\end{itemize}
\subsection*{Version 1.17}
\begin{itemize}
@@ -11,7 +23,7 @@
operations over them}
\item \changeinsection{locations}{new extended syntax for set comprehensions}
\item \changeinsection{at}{more restrictive scoping rule for \lstinline|\\at|
- constructs.}
+ constructs}
\item \changeinsection{logicspec}{add lemmas and data invariants}
\item \changeinsection{inductivepredicates}{add inductive predicates
experimentally: the accepted subset will be refined in a future version}
diff --git a/src/plugins/e-acsl/doc/refman/main.tex b/src/plugins/e-acsl/doc/refman/main.tex
index f23a0c27675b37eca732b9e47b47476262db032b..ac7c25222d034de00b21620cb21e6279c2bb7c7e 100644
--- a/src/plugins/e-acsl/doc/refman/main.tex
+++ b/src/plugins/e-acsl/doc/refman/main.tex
@@ -24,7 +24,7 @@
\usepackage{alltt}
\makeindex
-\newcommand{\eacsllangversion}{1.18\xspace}
+\newcommand{\eacsllangversion}{1.19\xspace}
\newcommand{\version}{\eacsllangversion\xspace}
\renewcommand{\textfraction}{0.01}
diff --git a/src/plugins/e-acsl/doc/refman/memory.tex b/src/plugins/e-acsl/doc/refman/memory.tex
index 29175c955963e3e967b0ae83301c304693916a0d..8d9c6096b0f3cde1987a1b93249ac90b23b514c0 100644
--- a/src/plugins/e-acsl/doc/refman/memory.tex
+++ b/src/plugins/e-acsl/doc/refman/memory.tex
@@ -11,6 +11,8 @@
| "\valid" { one-label? } "(" locations-list ")" ;
| "\valid_read" { one-label? } "(" locations-list ")";
| "\separated" "(" location "," locations-list ")";
+ | { "\object_pointer" one-label? "(" locations-list ")" };
+ | { "\pointer_comparable" one-label? "(" term "," term ")" };
\
{ one-label } ::= { "{" label-id "}" } ;
\
diff --git a/src/plugins/e-acsl/src/analyses/analyses_datatype.ml b/src/plugins/e-acsl/src/analyses/analyses_datatype.ml
index d0cc26dfed7508044bf2480bbf7231754002dc10..f96c0a09eb38d5eadd73810282da2b7d1660cdae 100644
--- a/src/plugins/e-acsl/src/analyses/analyses_datatype.ml
+++ b/src/plugins/e-acsl/src/analyses/analyses_datatype.ml
@@ -337,6 +337,16 @@ struct
let structural_descr = Structural_descr.t_abstract
let rehash = Datatype.identity
let name = "E-ACSL.Profile"
+ let pretty fmt m =
+ let first = ref true in
+ let pp_vi v i =
+ if !first
+ then first := false
+ else Format.fprintf fmt " ";
+ Format.fprintf fmt "%a:%a"
+ Logic_var.pretty v Analyses_types.pp_ival i
+ in
+ Logic_var.Map.iter pp_vi m
end)
let is_empty = Logic_var.Map.is_empty
diff --git a/src/plugins/e-acsl/src/analyses/analyses_types.ml b/src/plugins/e-acsl/src/analyses/analyses_types.ml
index 67632c2c116db506d5aa14363f0ddaf6ffda112c..a5a1f12468a7698020d8a3eeb74511df9d7c4b9f 100644
--- a/src/plugins/e-acsl/src/analyses/analyses_types.ml
+++ b/src/plugins/e-acsl/src/analyses/analyses_types.ml
@@ -76,6 +76,13 @@ type ival =
| Real
| Nan
+let pp_ival fmt = function
+ | Ival i -> Ival.pretty fmt i
+ | Float _ -> Format.fprintf fmt "F"
+ | Rational -> Format.fprintf fmt "Q"
+ | Real -> Format.fprintf fmt "R"
+ | Nan -> Format.fprintf fmt "Nan"
+
(** Type of types inferred by the type inference for types representing
numbers *)
type number_ty =
diff --git a/src/plugins/e-acsl/src/analyses/typing.ml b/src/plugins/e-acsl/src/analyses/typing.ml
index 1b38c7811ad60893dd8f275862ee13df3a652ec1..b7158f15100f6435ab887f8cd8b3a170f6218ce2 100644
--- a/src/plugins/e-acsl/src/analyses/typing.ml
+++ b/src/plugins/e-acsl/src/analyses/typing.ml
@@ -117,9 +117,13 @@ let typ_of_lty = function
type computed_info =
{ ty: Number_ty.t; (* type required for the term *)
cast: Number_ty.t option; (* if not [None], type of the context which the term
- must be casted to. If [None], no cast needed. *)
+ must be cast to. If [None], no cast needed. *)
}
+let pp_computed_info fmt ci =
+ let pp_cast fmt c = Format.fprintf fmt "(%a)" Number_ty.pretty c in
+ Format.fprintf fmt "%a%a" (Pretty_utils.pp_opt pp_cast) ci.cast Number_ty.pretty ci.ty
+
(* Memoization module which retrieves the computed info of some terms. If the
info is already computed for a term, it is never recomputed *)
module Memo: sig
@@ -357,6 +361,7 @@ let rec type_term
?ctx
~profile
t =
+ Options.feedback ~dkey ~level:5 "typing (sub-)term %a" Printer.pp_term t;
let ctx = Option.map (mk_ctx ~use_gmp_opt) ctx in
let compute_ctx ?ctx i =
(* in order to get a minimal amount of generated casts for operators, the
@@ -650,13 +655,21 @@ let rec type_term
| [ t1; t2; {term_node = Tlambda([ _ ], _)} as lambda ] ->
let range = Interval.(plus_one (get_from_profile ~profile t2)) in
let range = Interval.(join range (get_from_profile ~profile t1)) in
- let range = ty_of_interv range in
+ let ty_range = ty_of_interv range in
ignore
(type_term
- ~use_gmp_opt:true ~arith_operand:true ~ctx:range ~profile t1);
+ ~use_gmp_opt:true
+ ~arith_operand:true
+ ~profile
+ ~ctx:ty_range
+ t1);
ignore
(type_term
- ~use_gmp_opt:true ~arith_operand:true ~ctx:range ~profile t2);
+ ~use_gmp_opt
+ ~arith_operand
+ ~profile
+ ~ctx:ty_range
+ t2);
let ival = Interval.get_from_profile ~profile t in
let ty = ty_of_interv ival ~use_gmp_opt:true ?ctx in
ignore (type_term ~use_gmp_opt:true ?ctx ~profile lambda);
@@ -712,7 +725,10 @@ let rec type_term
| Some ctx -> coerce ~arith_operand ~ctx ty)
t
with
- | Result.Ok res -> res
+ | Result.Ok result ->
+ Options.debug ~dkey "type_term ~ctx:%a %a = %a"
+ (Pretty_utils.pp_opt Number_ty.pretty) ctx Printer.pp_term t pp_computed_info result;
+ result
| Result.Error exn -> raise exn
and type_term_lval ~profile (host, offset) =
diff --git a/src/plugins/e-acsl/src/code_generator/translate_terms.ml b/src/plugins/e-acsl/src/code_generator/translate_terms.ml
index 714cf3ba890d23ecac351d209b55c3a5125c3fb3..8ae9ce55f459495068880d4a88d8146bc4ca5979 100644
--- a/src/plugins/e-acsl/src/code_generator/translate_terms.ml
+++ b/src/plugins/e-acsl/src/code_generator/translate_terms.ml
@@ -170,7 +170,7 @@ and extended_quantifier_to_exp ~adata ~loc kf env t t_min t_max lambda name =
let ty_op = Typing.get_typ ~logic_env t in
let ty_k = match Typing.get_cast ~logic_env t_min with
| Some e -> e
- | _ -> Options.fatal "unexpected error in \\sum translation"
+ | _ -> Options.fatal ~dkey "unexpected error in \\sum translation"
in
let e_min, adata, env = to_exp ~adata kf env t_min in
let e_max, adata, env = to_exp ~adata kf env t_max in
@@ -865,37 +865,43 @@ and context_insensitive_term_to_exp ~adata ?(inplace=false) kf env t =
constructs. *)
and to_exp ~adata ?inplace kf env t =
let generate_rte = Env.generate_rte env in
- Options.feedback ~dkey ~level:4 "translating term %a (rte? %b)in local \
+ Options.feedback ~dkey ~level:5 "translating term %a (rte? %b) in local \
environment '%a'"
Printer.pp_term t generate_rte Profile.pretty
(Env.Logic_env.get_profile env);
let logic_env = Env.Logic_env.get env in
let t = Logic_normalizer.get_term t in
- Extlib.flatten
- (Env.with_params_and_result
- ~rte:false
- ~f:(fun env ->
- let e, adata, env, sty, name =
- context_insensitive_term_to_exp ?inplace ~adata kf env t
- in
- let env =
- if generate_rte then !translate_rte_exp_ref kf env e else env
- in
- let cast = Typing.get_cast ~logic_env t in
- let name = if name = "" then None else Some name in
- Extlib.nest
- adata
- (Typed_number.add_cast
- ~loc:t.term_loc
- ?name
- env
- kf
- cast
- sty
- (Some t)
- e)
- )
- env)
+ let (rexp, _, _) as result =
+ Extlib.flatten
+ (Env.with_params_and_result
+ ~rte:false
+ ~f:(fun env ->
+ let e, adata, env, sty, name =
+ context_insensitive_term_to_exp ?inplace ~adata kf env t
+ in
+ let env =
+ if generate_rte then !translate_rte_exp_ref kf env e else env
+ in
+ let cast = Typing.get_cast ~logic_env t in
+ let name = if name = "" then None else Some name in
+ Extlib.nest
+ adata
+ (Typed_number.add_cast
+ ~loc:t.term_loc
+ ?name
+ env
+ kf
+ cast
+ sty
+ (Some t)
+ e)
+ )
+ env)
+ in
+ Options.debug ~dkey ~level:4 "to_exp %a = %a"
+ Printer.pp_term t Printer.pp_exp rexp;
+ result
+
let term_to_exp_without_inplace ~adata kf env t = to_exp ~adata kf env t
diff --git a/src/plugins/e-acsl/tests/builtin/dune b/src/plugins/e-acsl/tests/builtin/dune
index 9dbf4e24533a7de7d1e1946bcef58497e1507f23..60c73d79b871aac38f96989e746ac1ce4757a8b0 100644
--- a/src/plugins/e-acsl/tests/builtin/dune
+++ b/src/plugins/e-acsl/tests/builtin/dune
@@ -1,7 +1,7 @@
(subdir
result/utils
- (copy_files ../../utils/*))
+ (copy_files ../../../utils/*))
(subdir
result_dev/utils
- (copy_files ../../utils/*))
+ (copy_files ../../../utils/*))
diff --git a/src/plugins/e-acsl/tests/builtin/utils b/src/plugins/e-acsl/tests/builtin/utils
deleted file mode 120000
index 19985ba50b51e1b7741a400a0b24ee16739553af..0000000000000000000000000000000000000000
--- a/src/plugins/e-acsl/tests/builtin/utils
+++ /dev/null
@@ -1 +0,0 @@
-../utils/
\ No newline at end of file
diff --git a/src/plugins/e-acsl/tests/format/dune b/src/plugins/e-acsl/tests/format/dune
index 9dbf4e24533a7de7d1e1946bcef58497e1507f23..60c73d79b871aac38f96989e746ac1ce4757a8b0 100644
--- a/src/plugins/e-acsl/tests/format/dune
+++ b/src/plugins/e-acsl/tests/format/dune
@@ -1,7 +1,7 @@
(subdir
result/utils
- (copy_files ../../utils/*))
+ (copy_files ../../../utils/*))
(subdir
result_dev/utils
- (copy_files ../../utils/*))
+ (copy_files ../../../utils/*))
diff --git a/src/plugins/e-acsl/tests/format/utils b/src/plugins/e-acsl/tests/format/utils
deleted file mode 120000
index 19985ba50b51e1b7741a400a0b24ee16739553af..0000000000000000000000000000000000000000
--- a/src/plugins/e-acsl/tests/format/utils
+++ /dev/null
@@ -1 +0,0 @@
-../utils/
\ No newline at end of file
diff --git a/src/plugins/e-acsl/tests/memory/oracle/hidden_malloc.res.oracle b/src/plugins/e-acsl/tests/memory/oracle/hidden_malloc.res.oracle
index ef3478f02e739c892261afcfe549b462d7b1683a..b795e7d036eb81ee57189173f8ad237916fed7b4 100644
--- a/src/plugins/e-acsl/tests/memory/oracle/hidden_malloc.res.oracle
+++ b/src/plugins/e-acsl/tests/memory/oracle/hidden_malloc.res.oracle
@@ -2,6 +2,3 @@
[e-acsl] translation done in project "e-acsl".
[kernel:annot:missing-spec] hidden_malloc.c:11: Warning:
Neither code nor specification for function realpath, generating default assigns from the prototype
-[eva:invalid-assigns] hidden_malloc.c:11:
- Completely invalid destination for assigns clause *(resolved_name + (0 ..)).
- Ignoring.
diff --git a/src/plugins/e-acsl/tests/test_config_dev b/src/plugins/e-acsl/tests/test_config_dev
index ee637413caa074f7a35b7f7d482396ca83d8158f..948d591ee9fd28cfdc36c7693e70272a5122fe85 100644
--- a/src/plugins/e-acsl/tests/test_config_dev
+++ b/src/plugins/e-acsl/tests/test_config_dev
@@ -8,7 +8,7 @@ COMMENT: Default options for the frama-c invocation
MACRO: ROOT_EACSL_GCC_FC_EXTRA -verbose 0
COMMENT: Currently compilation assumes an x86_64 architecture
-ENABLED_IF: (= %{architecture} x86_64)
+ENABLED_IF: (= %{architecture} amd64)
PLUGIN: e-acsl eva,scope,variadic rtegen
diff --git a/src/plugins/eva/Eva.mli b/src/plugins/eva/Eva.mli
index db84313b85ad427fb3c61cacc7507d1c02809886..3357d50d8349a3d3e2e90fe704eb5394b2b9109d 100644
--- a/src/plugins/eva/Eva.mli
+++ b/src/plugins/eva/Eva.mli
@@ -115,6 +115,75 @@ module Analysis: sig
val save_results: Cil_types.kernel_function -> bool
end
+module Callstack: sig
+ [@@@ alert "-db_deprecated"]
+
+ (** A call is identified by the function called and the call statement *)
+ type call = Cil_types.kernel_function * Cil_types.stmt
+
+ module Call : Datatype.S with type t = call
+
+ (** Eva callstacks. *)
+ type callstack = Eva_types.Callstack.callstack = {
+ thread: int;
+ (* An identifier of the thread's callstack. *)
+ entry_point: Cil_types.kernel_function;
+ (** The first function function of the callstack. *)
+ stack: call list;
+ (** A call stack is a list of calls. The head is the latest call. *)
+ }
+
+ include Datatype.S_with_collections
+ with type t = callstack
+ and module Hashtbl = Eva_types.Callstack.Hashtbl
+
+ (** Prints a callstack without displaying call sites. *)
+ val pretty_short : Format.formatter -> t -> unit
+
+ (** Prints a hash of the callstack when '-kernel-msg-key callstack'
+ is enabled (prints nothing otherwise). *)
+ val pretty_hash : Format.formatter -> t -> unit
+
+ (** [compare_lex] compares callstack lexicographically, slightly slower
+ than [compare] but in a more natural order, giving more importance
+ to the function at bottom of the callstack - the first functions called. *)
+ val compare_lex : t -> t -> int
+
+ (*** {2 Stack manipulation} *)
+
+ (*** Constructor *)
+ val init : ?thread:int -> Cil_types.kernel_function -> t
+
+ (** Adds a new call to the top of the callstack. *)
+ val push : Cil_types.kernel_function -> Cil_types.stmt -> t -> t
+
+ (** Removes the topmost call from the callstack. *)
+ val pop : t -> t option
+
+ val top : t -> (Cil_types.kernel_function * Cil_types.stmt) option
+ val top_kf : t -> Cil_types.kernel_function
+ val top_callsite : t -> Cil_types.kinstr
+ val top_call : t -> Cil_types.kernel_function * Cil_types.kinstr
+
+ (** Returns the function that called the topmost function of the callstack. *)
+ val top_caller : t -> Cil_types.kernel_function option
+
+ (** {2 Conversion} *)
+
+ (** Gives the list of kf in the callstack from the entry point to the top of the
+ callstack (i.e. reverse order of the call stack). *)
+ val to_kf_list : t -> Cil_types.kernel_function list
+
+ (** Gives the list of call statements from the bottom to the top of the
+ callstack (i.e. reverse order of the call stack). *)
+ val to_stmt_list : t -> Cil_types.stmt list
+
+ (** Gives the list of call from the bottom to the top of the callstack
+ (i.e. reverse order of the call stack). *)
+ val to_call_list : t -> (Cil_types.kernel_function * Cil_types.kinstr) list
+
+end
+
module Results: sig
(** Eva's result API is a new interface to access the results of an analysis,
@@ -158,8 +227,6 @@ module Results: sig
all requests in the function will lead to a Top error. *)
val are_available : Cil_types.kernel_function -> bool
- type callstack = (Cil_types.kernel_function * Cil_types.kinstr) list
-
type request
type value
@@ -222,16 +289,16 @@ module Results: sig
(** Only consider the given callstack.
Replaces previous calls to [in_callstack] or [in_callstacks]. *)
- val in_callstack : callstack -> request -> request
+ val in_callstack : Callstack.t -> request -> request
(** Only consider the callstacks from the given list.
Replaces previous calls to [in_callstack] or [in_callstacks]. *)
- val in_callstacks : callstack list -> request -> request
+ val in_callstacks : Callstack.t list -> request -> request
(** Only consider callstacks satisfying the given predicate. Several filters
can be added. If callstacks are also selected with [in_callstack] or
[in_callstacks], only the selected callstacks will be filtered. *)
- val filter_callstack : (callstack -> bool) -> request -> request
+ val filter_callstack : (Callstack.t -> bool) -> request -> request
(** Working with callstacks *)
@@ -241,11 +308,11 @@ module Results: sig
reached by the analysis, or if no information has been saved at this point
(for instance with the -eva-no-results option).
Use [is_empty request] to distinguish these two cases. *)
- val callstacks : request -> callstack list
+ val callstacks : request -> Callstack.t list
(** Returns a list of subrequests for each reachable callstack from
the given request. *)
- val by_callstack : request -> (callstack * request) list
+ val by_callstack : request -> (Callstack.t * request) list
(** State requests *)
@@ -616,22 +683,24 @@ module Cvalue_callbacks: sig
in a future version. Please contact us if you need to register callbacks
to be executed during an Eva analysis. *)
- type callstack = (Cil_types.kernel_function * Cil_types.kinstr) list
type state = Cvalue.Model.t
type analysis_kind =
- [ `Builtin of Value_types.call_froms
- | `Spec of Cil_types.funspec
- | `Def
- | `Memexec ]
+ [ `Builtin (** A cvalue builtin is used to interpret the function. *)
+ | `Spec (** The specification is used to interpret the function. *)
+ | `Body (** The function body is analyzed. This is the standard case. *)
+ | `Reuse (** The results of a previous analysis of the function are reused. *)
+ ]
- (** Registers a function to be applied at the beginning of the analysis of each
- function call. Arguments of the callback are the callstack of the call,
- the function called, the kind of analysis performed by Eva for this call,
- and the cvalue state at the beginning of the call. *)
- val register_call_hook:
- (callstack -> Cil_types.kernel_function -> analysis_kind -> state -> unit)
- -> unit
+ (** Signature of a hook to be called before the analysis of each function call.
+ Arguments are the callstack of the call, the function called, the initial
+ cvalue state, and the kind of analysis performed by Eva for this call. *)
+ type call_hook =
+ Callstack.t -> Cil_types.kernel_function -> state -> analysis_kind -> unit
+
+ (** Registers a function to be applied at the start of the analysis of each
+ function call. *)
+ val register_call_hook: call_hook -> unit
type state_by_stmt = (state Cil_datatype.Stmt.Hashtbl.t) Lazy.t
@@ -639,19 +708,27 @@ module Cvalue_callbacks: sig
(** Results of a function call. *)
type call_results =
- | Store of results * int
+ [ `Builtin of state list * Value_types.call_froms
+ (** List of cvalue states at the end of the builtin. *)
+ | `Spec of state list
+ (** List of cvalue states at the end of the call. *)
+ | `Body of results * int
(** Cvalue states before and after each statement of the given function,
plus a unique integer id for the call. *)
- | Reuse of int
- (** The results are the same as a previous call with the given integer id,
- previously recorded with the [Store] constructor. *)
+ | `Reuse of int
+ (** The results are the same as a previous call with the given integer id,
+ previously recorded with the [`Body] constructor. *)
+ ]
+
+ (** Signature of a hook to be called after the analysis of each function call.
+ Arguments are the callstack of the call, the function called, the initial
+ cvalue state at the start of the call, and the results from its analysis. *)
+ type call_results_hook =
+ Callstack.t -> Cil_types.kernel_function -> state -> call_results -> unit
(** Registers a function to be applied at the end of the analysis of each
- function call. Arguments of the callback are the callstack of the call,
- the function called and the cvalue states resulting from its analysis. *)
- val register_call_results_hook:
- (callstack -> Cil_types.kernel_function -> call_results -> unit)
- -> unit
+ function call. *)
+ val register_call_results_hook: call_results_hook -> unit
end
@@ -733,7 +810,7 @@ module Eva_results: sig
For technical reasons, the top of the callstack must currently
be preserved. *)
val change_callstacks:
- (Value_types.callstack -> Value_types.callstack) -> results -> results
+ (Callstack.t -> Callstack.t) -> results -> results
val eval_tlval_as_location :
?result:Cil_types.varinfo ->
diff --git a/src/plugins/eva/api/general_requests.ml b/src/plugins/eva/api/general_requests.ml
index d3085ad822cb528b62bcffc5a61cea4ea055f09c..f4de3ff5552b915bfa51e293697cfd954514978f 100644
--- a/src/plugins/eva/api/general_requests.ml
+++ b/src/plugins/eva/api/general_requests.ml
@@ -31,7 +31,7 @@ let package =
()
module ComputationState = struct
- type t = Analysis.computation_state
+ type t = Self.computation_state
let jtype =
Data.declare ~package
~name:"computationStateType"
@@ -42,20 +42,18 @@ module ComputationState = struct
Jtag "computed" ;
Jtag "aborted" ])
let to_json = function
- | Analysis.NotComputed -> `String "not_computed"
+ | Self.NotComputed -> `String "not_computed"
| Computing -> `String "computing"
| Computed -> `String "computed"
| Aborted -> `String "aborted"
end
let computation_signal =
- States.register_value ~package
+ States.register_framac_value ~package
~name:"computationState"
~descr:(Markdown.plain "The current computation state of the analysis.")
~output:(module ComputationState)
- ~get:Analysis.current_computation_state
- ~add_hook:Analysis.register_computation_hook
- ()
+ (module Self.ComputationState)
(* ----- Callsites ---------------------------------------------------------- *)
@@ -747,16 +745,15 @@ let _array =
~data:(module Statuses)
~get:(fun (_kf,stats) -> stats.fun_alarm_statuses);
- States.register_array
+ States.register_framac_array
~package
~name:"functionStats"
~descr:(Markdown.plain
"Statistics about the last Eva analysis for each function")
- ~key:(fun (fundec,_stats) -> fundec.svar.vname)
+ ~key:(fun fundec -> fundec.svar.vname)
~keyType:Kernel_ast.Fundec.jtype
- ~iter:(fun f -> FunctionStats.iter (fun fundec s -> f (fundec,s)))
- ~add_update_hook:FunctionStats.register_hook
model
+ (module FunctionStats)
diff --git a/src/plugins/eva/api/values_request.ml b/src/plugins/eva/api/values_request.ml
index 1e109a39629a2e95115db3b403be1112542972ba..8e0c351b98b2d9c605e8d7723dc47640200387b9 100644
--- a/src/plugins/eva/api/values_request.ml
+++ b/src/plugins/eva/api/values_request.ml
@@ -26,9 +26,8 @@ open Cil_types
module Kmap = Kernel_function.Hashtbl
module Smap = Cil_datatype.Stmt.Hashtbl
-module CS = Value_types.Callstack
-module CSet = CS.Set
-module CSmap = CS.Hashtbl
+module CSet = Callstack.Set
+module CSmap = Callstack.Hashtbl
module Md = Markdown
module Jfct = Kernel_ast.Function
@@ -49,7 +48,6 @@ type evaluation_point = General_requests.evaluation_point =
(* A term and the program point where it should be evaluated. *)
type probe = term * evaluation_point
-type callstack = Value_types.callstack
type truth = Abstract_interp.truth
(* The result of an evaluation:
@@ -138,7 +136,7 @@ let probe marker =
module type Ranking_sig = sig
val stmt : stmt -> int
- val sort : callstack list -> callstack list
+ val sort : Callstack.t list -> Callstack.t list
end
module Ranking : Ranking_sig = struct
@@ -198,18 +196,15 @@ module Ranking : Ranking_sig = struct
let stmt = let rk = new ranker in rk#rank
- let rec ranks (rks : int list) (cs : callstack) : int list =
- match cs with
- | [] -> rks
- | (_,Kglobal)::wcs -> ranks rks wcs
- | (_,Kstmt s)::wcs -> ranks (stmt s :: rks) wcs
+ let ranks (cs : Callstack.t) : int list =
+ List.map stmt (Callstack.to_stmt_list cs)
let order : int list -> int list -> int = Stdlib.compare
- let sort (wcs : callstack list) : callstack list =
+ let sort (wcs : Callstack.t list) : Callstack.t list =
List.map fst @@
List.sort (fun (_,rp) (_,rq) -> order rp rq) @@
- List.map (fun cs -> cs , ranks [] cs) wcs
+ List.map (fun cs -> cs , ranks cs) wcs
end
@@ -217,9 +212,9 @@ end
(* --- Domain Utilities --- *)
(* -------------------------------------------------------------------------- *)
-module Jcallstack : S with type t = callstack = struct
+module Jcallstack : S with type t = Callstack.t = struct
module I = Data.Index
- (Value_types.Callstack.Map)
+ (Callstack.Map)
(struct let name = "eva-callstack-id" end)
let jtype = Data.declare ~package ~name:"callstack" I.jtype
type t = I.t
@@ -227,9 +222,9 @@ module Jcallstack : S with type t = callstack = struct
let of_json = I.of_json
end
-module Jcalls : Request.Output with type t = callstack = struct
+module Jcalls : Request.Output with type t = Callstack.t = struct
- type t = callstack
+ type t = Callstack.t
let jtype = Package.(Jarray (Jrecord [
"callee" , Jfct.jtype ;
@@ -238,23 +233,25 @@ module Jcalls : Request.Output with type t = callstack = struct
"rank" , Joption Jnumber ;
]))
- let rec jcallstack jcallee ki cs : json list =
- match ki , cs with
- | Kglobal , _ | _ , [] -> [ `Assoc [ "callee", jcallee ] ]
- | Kstmt stmt , (called,ki) :: cs ->
- let jcaller = Jfct.to_json called in
- let callsite = `Assoc [
- "callee", jcallee ;
- "caller", jcaller ;
- "stmt", Jstmt.to_json stmt ;
- "rank", Jint.to_json (Ranking.stmt stmt) ;
- ]
- in
- callsite :: jcallstack jcaller ki cs
-
- let to_json = function
- | [] -> `List []
- | (callee,ki)::cs -> `List (jcallstack (Jfct.to_json callee) ki cs)
+ let jcallsite ~jcaller ~jcallee stmt =
+ `Assoc [
+ "callee", jcallee ;
+ "caller", jcaller ;
+ "stmt", Jstmt.to_json stmt ;
+ "rank", Jint.to_json (Ranking.stmt stmt) ;
+ ]
+
+ let to_json (cs : t) =
+ let aux (acc, jcaller) (callee, stmt) =
+ let jcallee = Jfct.to_json callee in
+ jcallsite ~jcaller ~jcallee stmt :: acc, jcallee
+ in
+ let entry_point = Jfct.to_json cs.entry_point in
+ let l, _last_callee = List.fold_left aux
+ ([`Assoc [ "callee", entry_point ]], entry_point)
+ (List.rev cs.stack)
+ in
+ `List l
end
@@ -353,13 +350,15 @@ let filter_variables bases =
(* -------------------------------------------------------------------------- *)
module type EvaProxy = sig
- val kf_callstacks : kernel_function -> callstack list
- val stmt_callstacks : stmt -> callstack list
- val evaluate : probe -> callstack option -> evaluations
+ val kf_callstacks : kernel_function -> Callstack.t list
+ val stmt_callstacks : stmt -> Callstack.t list
+ val evaluate : probe -> Callstack.t option -> evaluations
end
module Proxy(A : Analysis.S) : EvaProxy = struct
+ include Cvalue_domain.Getters (A.Dom)
+
open Eval
type dstate = A.Dom.state or_top_bottom
@@ -448,7 +447,7 @@ module Proxy(A : Analysis.S) : EvaProxy = struct
(* --- Evaluates an expression or lvalue into an evaluation [result]. ----- *)
let lval_to_offsetmap lval state =
- let cvalue_state = A.Dom.get_cvalue_or_top state in
+ let cvalue_state = get_cvalue_or_top state in
match lval with
| Var vi, NoOffset ->
let r = extract_single_var vi cvalue_state in
diff --git a/src/plugins/eva/domains/abstract_domain.ml b/src/plugins/eva/domains/abstract_domain.ml
index 87a9bfc5a6c2e55a159afa719e9d1dd912eee551..3fba964a09919b7915885e47e520968da85e9eb3 100644
--- a/src/plugins/eva/domains/abstract_domain.ml
+++ b/src/plugins/eva/domains/abstract_domain.ml
@@ -502,15 +502,28 @@ end
type 't key = 't Structure.Key_Domain.key
-(** Signature for a leaf module of a domain. *)
+(** Signature for a leaf abstract domain which can be registered
+ via {!Abstractions.Domain.register}. *)
module type Leaf = sig
include S
- (** The key identifies the domain and the type [t] of its states. *)
+ (** The key identifies the domain and the type [t] of its states.
+ Automatically created by {!Domain_builder.Complete}. *)
val key: t key
+
+ (** The abstract value used by the domain.
+ It carries the [value] type used by the domain.
+ See {!Main_values} for some abstract values available in Eva. *)
+ val value_dependencies: value Abstract_value.dependencies
+
+ (** The abstract location used by the domain.
+ It carries the [location] type used by the domain.
+ See {!Main_locations} for the abstract location available in Eva. *)
+ val location_dependencies: location Abstract_location.dependencies
end
+
(*
Local Variables:
compile-command: "make -C ../../../.."
diff --git a/src/plugins/eva/domains/apron/apron_domain.ml b/src/plugins/eva/domains/apron/apron_domain.ml
index ff4d21571c61738d0be479e498f7f7f60ca32cfa..2b47a0168f33ebef4a4a11257c5e7995b2bcf7fb 100644
--- a/src/plugins/eva/domains/apron/apron_domain.ml
+++ b/src/plugins/eva/domains/apron/apron_domain.ml
@@ -360,6 +360,9 @@ module Make (Man : Input) = struct
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Main_values.ival
+ let location_dependencies = Main_locations.ploc
+
let man = Man.manager
let log_category = dkey
@@ -714,16 +717,13 @@ let () = Floating_point.set_round_nearest_even ()
let make name (module Man: Input) =
let module Domain = Make (Man) in
+ let name = "apron-" ^ name and experimental = true and priority = 1 in
let descr =
"Binding to the " ^ name ^ " domain of the Apron library. " ^
"See http://apron.cri.ensmp.fr/library for more details."
in
- let name = "apron-" ^ name in
- let abstraction =
- Abstractions.{ values = Single (module Main_values.Interval);
- domain = Domain (module Domain); }
- in
- Abstractions.register ~name ~descr ~experimental:true ~priority:1 abstraction
+ Abstractions.Domain.register ~name ~descr ~experimental ~priority
+ (module Domain)
let octagon = make "octagon" (module Apron_Octagon)
let box = make "box" (module Apron_Box)
@@ -731,6 +731,32 @@ let polka_loose = make "polka-loose" (module Apron_Polka_Loose)
let polka_strict = make "polka-strict" (module Apron_Polka_Strict)
let polka_equality = make "polka-equality" (module Apron_Polka_Equalities)
+(* 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
+ | Some ival ->
+ try
+ let ival' = Cvalue.V.project_ival cvalue in
+ if Ival.is_int ival'
+ then
+ let reduced_ival = Ival.narrow ival ival' in
+ let cvalue = Cvalue.V.inject_ival reduced_ival in
+ cvalue, Some reduced_ival
+ else cvalue, Some ival
+ with Cvalue.V.Not_based_on_null -> cvalue, Some ival
+
+let () =
+ Abstractions.Reducer.register
+ Main_values.CVal.key Main_values.Interval.key reduce_apron_itv
+
+
(*
Local Variables:
compile-command: "make -C ../../../../.. -j"
diff --git a/src/plugins/eva/domains/apron/apron_domain.mli b/src/plugins/eva/domains/apron/apron_domain.mli
index ede77986e150365603b0a878d6a84296bc42c17e..fb06185c0fa58124d767e27515907ea33a980230 100644
--- a/src/plugins/eva/domains/apron/apron_domain.mli
+++ b/src/plugins/eva/domains/apron/apron_domain.mli
@@ -24,11 +24,11 @@
the APRON library: http://apron.cri.ensmp.fr/library
For now, this binding only processes scalar integer variables. *)
-val octagon: Abstractions.flag
-val box: Abstractions.flag
-val polka_loose: Abstractions.flag
-val polka_strict: Abstractions.flag
-val polka_equality: Abstractions.flag
+val octagon: Abstractions.Domain.registered
+val box: Abstractions.Domain.registered
+val polka_loose: Abstractions.Domain.registered
+val polka_strict: Abstractions.Domain.registered
+val polka_equality: Abstractions.Domain.registered
(*
Local Variables:
diff --git a/src/plugins/eva/domains/cvalue/builtins.ml b/src/plugins/eva/domains/cvalue/builtins.ml
index feb925ad393094dc7e98d1d4112efe7de8af2af3..48c2d53189c0e07471eee40242001f04947522c8 100644
--- a/src/plugins/eva/domains/cvalue/builtins.ml
+++ b/src/plugins/eva/domains/cvalue/builtins.ml
@@ -266,13 +266,15 @@ let apply_builtin (builtin:builtin) call ~pre ~post =
let arguments = compute_arguments call.arguments call.rest in
try
let call_result = builtin pre arguments in
+ let states = process_result call post call_result in
let froms =
match call_result with
- | Full result -> `Builtin result.c_from
- | States _ | Result _ -> `Builtin None
+ | Full result -> result.c_from
+ | States _ | Result _ -> None
in
- Cvalue_callbacks.apply_call_hooks call.callstack call.kf froms pre;
- process_result call post call_result
+ let result = `Builtin (List.map fst states, froms) in
+ Cvalue_callbacks.apply_call_results_hooks call.callstack call.kf pre result;
+ states
with
| Invalid_nb_of_args n ->
Self.abort ~current:true
diff --git a/src/plugins/eva/domains/cvalue/builtins_malloc.ml b/src/plugins/eva/domains/cvalue/builtins_malloc.ml
index 4f17d70e897baac10ce641654653c972c309e88a..77b26cbe8cc5bcb6e6cd6812c283f612ecb56eed 100644
--- a/src/plugins/eva/domains/cvalue/builtins_malloc.ml
+++ b/src/plugins/eva/domains/cvalue/builtins_malloc.ml
@@ -38,7 +38,7 @@ let wkey_imprecise_alloc = Self.register_warn_category
module Base_hptmap = Hptmap.Make
(Base.Base)
- (Value_types.Callstack)
+ (Callstack)
(Hptmap.Comp_unused)
(struct let v = [ [ ] ] end)
(struct let l = [ Ast.self ] end)
@@ -57,9 +57,9 @@ let () = Ast.add_monotonic_state Dynamic_Alloc_Bases.self
(* -------------------------- Auxiliary functions -------------------------- *)
let current_call_site () =
- match Eva_utils.call_stack () with
- | (_kf, Kstmt stmt) :: _ -> stmt
- | _ -> Cil.dummyStmt
+ match Callstack.top_callsite (Eva_utils.current_call_stack ()) with
+ | Kglobal -> Cil.dummyStmt
+ | Kstmt stmt -> stmt
(* Remove some parts of the callstack:
- Remove the bottom of the call tree until we get to the call site
@@ -67,29 +67,26 @@ let current_call_site () =
these call site correspond to a different use of a malloc function,
so it is interesting to keep their bases separated. *)
let call_stack_no_wrappers () =
- let stack = Eva_utils.call_stack () in
- assert (stack != []);
- let wrappers = Parameters.AllocFunctions.get() in
+ let cs = Eva_utils.current_call_stack () in
+ let wrappers = Parameters.AllocFunctions.get () in
let rec bottom_filter = function
- | [] -> assert false
- | [_] as stack -> stack (* Do not empty the stack completely *)
+ | [] | [_] as stack -> stack
| (kf,_)::((kf', _):: _ as rest) as stack ->
- if Datatype.String.Set.mem (Kernel_function.get_name kf) wrappers then
- if Datatype.String.Set.mem (Kernel_function.get_name kf') wrappers then
- bottom_filter rest
- else
- stack
- else
- stack
+ if Datatype.String.Set.mem (Kernel_function.get_name kf) wrappers
+ && Datatype.String.Set.mem (Kernel_function.get_name kf') wrappers
+ then bottom_filter rest
+ else stack
in
- bottom_filter stack
+ { cs with stack = bottom_filter cs.stack }
-let register_malloced_base ?(stack=call_stack_no_wrappers ()) b =
- let stack_without_top = List.tl stack in
+let register_malloced_base ~stack b =
+ let stack_without_top =
+ Option.value ~default:stack (Callstack.pop stack)
+ in
Dynamic_Alloc_Bases.set
(Base_hptmap.add b stack_without_top (Dynamic_Alloc_Bases.get ()))
-let fold_dynamic_bases (f: Base.t -> Value_types.Callstack.t -> 'a -> 'a) init =
+let fold_dynamic_bases (f: Base.t -> Callstack.t -> 'a -> 'a) init =
Base_hptmap.fold f (Dynamic_Alloc_Bases.get ()) init
let is_automatically_deallocated base =
@@ -120,20 +117,17 @@ let extract_size sizev_bytes =
(* Name of the base that will be given to a malloced variable, determined
using the callstack. *)
-let base_name prefix stack =
+let base_name prefix cs =
let stmt_line stmt = (fst (Cil_datatype.Stmt.loc stmt)).Filepath.pos_lnum in
- match stack with
- | [] -> assert false
- | [kf, Kglobal] -> (* Degenerate case *)
- Format.asprintf "__%s_%a" prefix Kernel_function.pretty kf
- | (_, Kglobal) :: _ :: _ -> assert false
- | (_, Kstmt callsite) :: qstack ->
+ match cs.Callstack.stack with
+ | [] ->
+ (* Degenerate case *)
+ Format.asprintf "__%s_%a" prefix Kernel_function.pretty cs.entry_point
+ | (_, callsite) :: qstack ->
(* Use the whole call-stack to generate the name *)
let rec loop_full = function
- | [_, Kglobal] -> Format.sprintf "_%s" (Kernel.MainFunction.get ())
- | (_, Kglobal) :: _ :: _ -> assert false
- | [] -> assert false (* impossible, we should have seen a Kglobal *)
- | (kf, Kstmt line)::b ->
+ | [] -> Format.sprintf "_%s" (Kernel_function.get_name cs.entry_point)
+ | (kf, line) :: b ->
let line = stmt_line line in
let node_str = Format.asprintf "_l%d__%a"
line Kernel_function.pretty kf
@@ -141,14 +135,14 @@ let base_name prefix stack =
(loop_full b) ^ node_str
in
(* Use only the name of the caller to malloc for the name *)
- let caller = function
- | [] -> assert false (* caught above *)
- | (kf, _) :: _ -> Format.asprintf "_%a" Kernel_function.pretty kf
+ let caller =
+ let kf = Callstack.top_kf { cs with stack = qstack } in
+ Format.asprintf "_%a" Kernel_function.pretty kf
in
let full_name = false in
Format.asprintf "__%s%s_l%d"
prefix
- (if full_name then loop_full qstack else caller qstack)
+ (if full_name then loop_full qstack else caller)
(stmt_line callsite)
type var = Weak | Strong
@@ -217,7 +211,7 @@ let guess_intended_malloc_type stack sizev constant_size =
| _ -> raise Exit
in
try
- match snd (List.hd stack) with
+ match Callstack.top_callsite stack with
| Kstmt {skind = Instr (Call (Some lv, _, _, _))} ->
mk_typed_size (Cil.typeOfLval lv)
| Kstmt {skind = Instr(Local_init(vi, _, _))} -> mk_typed_size vi.vtype
@@ -380,7 +374,7 @@ let string_of_region = function
(* Only called when the 'weakest base' needs to be allocated. *)
let create_weakest_base region =
- let stack = [ fst (Globals.entry_point ()), Kglobal ] in
+ let stack = { (Eva_utils.current_call_stack ()) with stack = [] } in
let type_base =
TArray (Cil.charType, None, [])
in
@@ -413,8 +407,8 @@ let alloc_weakest_base region =
stack. Currently, the callstacks are truncated according to
[-eva-alloc-functions]. *)
module MallocedByStack = (* varinfo list Callstack.hashtbl *)
- State_builder.Hashtbl(Value_types.Callstack.Hashtbl)
- (Datatype.List(Base))
+ State_builder.Hashtbl (Callstack.Hashtbl)
+ (Datatype.List (Base))
(struct
let name = "Value.Builtins_malloc.MallocedByStack"
let size = 17
@@ -686,7 +680,7 @@ let free_automatic_bases stack state =
let bases_to_free =
Base_hptmap.fold (fun base stack' acc ->
if is_automatically_deallocated base &&
- Value_types.Callstack.equal stack stack'
+ Callstack.equal stack stack'
then Base.Hptset.add base acc
else acc
) (Dynamic_Alloc_Bases.get ()) Base.Hptset.empty
diff --git a/src/plugins/eva/domains/cvalue/builtins_malloc.mli b/src/plugins/eva/domains/cvalue/builtins_malloc.mli
index 8cd4f9ddabf4ba775b258e6fc96fca993996285d..399b01a97c65de424fe157642df55c4b3f22c98b 100644
--- a/src/plugins/eva/domains/cvalue/builtins_malloc.mli
+++ b/src/plugins/eva/domains/cvalue/builtins_malloc.mli
@@ -23,7 +23,7 @@
(** Dynamic allocation related builtins.
Most functionality is exported as builtins. *)
-val fold_dynamic_bases: (Base.t -> Value_types.Callstack.t -> 'a -> 'a) -> 'a -> 'a
+val fold_dynamic_bases: (Base.t -> Callstack.t -> 'a -> 'a) -> 'a -> 'a
(** [fold_dynamic_bases f init] folds [f] to each dynamically allocated base,
with initial accumulator [init].
Note that this also includes bases created by [alloca] and [VLAs]. *)
@@ -34,7 +34,7 @@ val alloc_size_ok: Cvalue.V.t -> Alarmset.status
small enough, [False] that the allocation is guaranteed to fail (because
the size is always greater than SIZE_MAX). *)
-val free_automatic_bases: Value_types.Callstack.t -> Cvalue.Model.t -> Cvalue.Model.t
+val free_automatic_bases: Callstack.t -> Cvalue.Model.t -> Cvalue.Model.t
(** Performs the equivalent of [free] for each location that was allocated via
[alloca()] in the current function (as per [Eva_utils.call_stack ()]).
This function must be called during finalization of a function call. *)
@@ -44,7 +44,3 @@ val freeable: Cvalue.V.t -> Abstract_interp.truth
value points to an allocated memory block that can be safely released using
the C function free. Note that \freeable(\null) does not hold, despite NULL
being a valid argument to the C function free. *)
-
-(**/**)
-val register_malloced_base: ?stack:Value_types.Callstack.t -> Base.t -> unit
-(* Should not be used by casual users. *)
diff --git a/src/plugins/eva/domains/cvalue/builtins_memory.ml b/src/plugins/eva/domains/cvalue/builtins_memory.ml
index b543ce8a78c89f9ec93388d8b0c7824fc4e464b0..4a34203eed44a62880082513b6b35d4e872b9621 100644
--- a/src/plugins/eva/domains/cvalue/builtins_memory.ml
+++ b/src/plugins/eva/domains/cvalue/builtins_memory.ml
@@ -92,7 +92,7 @@ let memcpy_check_indeterminate_offsetmap offsm =
currently called function. *)
let deps_nth_arg n =
let open Function_Froms in
- let (kf,_) = List.hd (Eva_utils.call_stack()) in
+ let kf = Callstack.top_kf (Eva_utils.current_call_stack ()) in
try
let vi = List.nth (Kernel_function.get_formals kf) n in
Deps.add_data_dep Deps.bottom (Locations.zone_of_varinfo vi)
diff --git a/src/plugins/eva/domains/cvalue/cvalue_domain.ml b/src/plugins/eva/domains/cvalue/cvalue_domain.ml
index 6dca30d2ccbd4b4f031acc222c6c5018ed26f9de..7822ad59369304d3781cdaa189f1c2abfb0fac4a 100644
--- a/src/plugins/eva/domains/cvalue/cvalue_domain.ml
+++ b/src/plugins/eva/domains/cvalue/cvalue_domain.ml
@@ -187,6 +187,9 @@ module State = struct
type value = Model.value
type location = Model.location
+ let value_dependencies = Main_values.cval
+ let location_dependencies = Main_locations.ploc
+
let top = Model.top, Locals_scoping.bottom ()
let is_included (a, _) (b, _) = Model.is_included a b
let join (a, clob) (b, _) = Model.join a b, clob
@@ -457,8 +460,8 @@ module State = struct
end)
let register_global_state b _ = Storage.set b
- let register_initial_state callstack (state, _clob) =
- Db.Value.merge_initial_state callstack state
+ let register_initial_state callstack kf (state, _clob) =
+ Db.Value.merge_initial_state callstack kf state
let register_state_before_stmt callstack stmt (state, _clob) =
Db.Value.update_callstack_table ~after:false stmt callstack state
let register_state_after_stmt callstack stmt (state, _clob) =
@@ -470,7 +473,6 @@ module State = struct
else `Value (state, Locals_scoping.top ())
let lift_tbl tbl =
- let open Value_types in
let h = Callstack.Hashtbl.create 7 in
let process callstack state =
Callstack.Hashtbl.replace h callstack (state, Locals_scoping.top ())
@@ -482,10 +484,10 @@ module State = struct
match selection with
| None -> tbl
| Some list ->
- let new_tbl = Value_types.Callstack.Hashtbl.create (List.length list) in
+ let new_tbl = Callstack.Hashtbl.create (List.length list) in
let add cs =
- let s = Value_types.Callstack.Hashtbl.find_opt tbl cs in
- Option.iter (Value_types.Callstack.Hashtbl.replace new_tbl cs) s
+ let s = Callstack.Hashtbl.find_opt tbl cs in
+ Option.iter (Callstack.Hashtbl.replace new_tbl cs) s
in
List.iter add list;
new_tbl
@@ -585,6 +587,14 @@ end
let () = Db.Value.display := (fun fmt kf -> State.display ~fmt kf)
+let registered =
+ let name = "cvalue"
+ and descr =
+ "Main analysis domain, enabled by default. Should not be disabled."
+ in
+ Abstractions.Domain.register ~name ~descr ~priority:9 (module State)
+
+
type prefix = Hptmap.prefix
module Subpart = struct
type t = Model.subtree
@@ -598,6 +608,23 @@ let distinct_subpart (a, _) (b, _) =
with Model.Found_prefix (p, s1, s2) -> Some (p, s1, s2)
let find_subpart (s, _) prefix = Model.find_prefix s prefix
+
+module Getters (Dom : Abstract.Domain.External) = struct
+ let get_cvalue =
+ match Dom.get State.key with
+ | None -> None
+ | Some get -> Some (fun s -> fst (get s))
+
+ let get_cvalue_or_top =
+ match Dom.get State.key with
+ | None -> fun _ -> Cvalue.Model.top
+ | Some get -> fun s -> fst (get s)
+
+ let get_cvalue_or_bottom = function
+ | `Bottom -> Cvalue.Model.bottom
+ | `Value state -> get_cvalue_or_top state
+end
+
(*
Local Variables:
compile-command: "make -C ../../../../.."
diff --git a/src/plugins/eva/domains/cvalue/cvalue_domain.mli b/src/plugins/eva/domains/cvalue/cvalue_domain.mli
index 9c603e71b66e274c0befb703affd35767f17c8ac..4b7278ecbdb48e8878d2c74c96f83681b96893ce 100644
--- a/src/plugins/eva/domains/cvalue/cvalue_domain.mli
+++ b/src/plugins/eva/domains/cvalue/cvalue_domain.mli
@@ -27,6 +27,8 @@ module State : Abstract_domain.Leaf
and type location = Main_locations.PLoc.location
and type state = Cvalue.Model.t * Locals_scoping.clobbered_set
+val registered: Abstractions.Domain.registered
+
(** Specific functions for partitioning optimizations. *)
type prefix
@@ -35,6 +37,13 @@ val distinct_subpart :
State.t -> State.t -> (prefix * Subpart.t * Subpart.t) option
val find_subpart : State.t -> prefix -> Subpart.t option
+(** Special getters. *)
+
+module Getters (Dom : Abstract.Domain.External) : sig
+ val get_cvalue : (Dom.t -> Cvalue.Model.t) option
+ val get_cvalue_or_top : Dom.t -> Cvalue.Model.t
+ val get_cvalue_or_bottom : Dom.t Lattice_bounds.or_bottom -> Cvalue.Model.t
+end
(*
diff --git a/src/plugins/eva/domains/cvalue/cvalue_transfer.ml b/src/plugins/eva/domains/cvalue/cvalue_transfer.ml
index 22b674e46ea768e152224753ce32f0caff4c4ad3..222f8bbe68349524dabe96f1d9b91d1ed3e1e438 100644
--- a/src/plugins/eva/domains/cvalue/cvalue_transfer.ml
+++ b/src/plugins/eva/domains/cvalue/cvalue_transfer.ml
@@ -205,7 +205,7 @@ let actualize_formals state arguments =
let start_call _stmt call _recursion _valuation state =
let with_formals = actualize_formals state call.arguments in
- let stack_with_call = Eva_utils.call_stack () in
+ let stack_with_call = Eva_utils.current_call_stack () in
Db.Value.Call_Value_Callbacks.apply (with_formals, stack_with_call);
`Value with_formals
@@ -214,8 +214,9 @@ let finalize_call stmt call _recursion ~pre:_ ~post:state =
To minimize computations, only do it for function definitions. *)
let state' =
if Kernel_function.is_definition call.kf then
- let stack = (call.kf, Kstmt stmt) :: (Eva_utils.call_stack ()) in
- Builtins_malloc.free_automatic_bases stack state
+ let callstack = Eva_utils.current_call_stack () in
+ let callstack = Callstack.push call.kf stmt callstack in
+ Builtins_malloc.free_automatic_bases callstack state
else state
in
`Value state'
diff --git a/src/plugins/eva/domains/domain_builder.ml b/src/plugins/eva/domains/domain_builder.ml
index 67a85116c6b779b5cf2cb30854c1af18b0de6e36..0305ca8a35fdbb53e57fdbe620642bffc3d7151a 100644
--- a/src/plugins/eva/domains/domain_builder.ml
+++ b/src/plugins/eva/domains/domain_builder.ml
@@ -101,8 +101,8 @@ let simplify_call call =
return = call.Eval.return; }
module Make_Minimal
- (Value: Abstract_value.S)
- (Location: Abstract_location.S)
+ (Value: Abstract_value.Leaf)
+ (Location: Abstract_location.Leaf)
(Domain: Simpler_domains.Minimal)
= struct
@@ -115,6 +115,9 @@ module Make_Minimal
type state = Domain.t
type origin
+ let value_dependencies = Abstract_value.Leaf (module Value)
+ let location_dependencies = Abstract_location.Leaf (module Location)
+
let narrow x _y = `Value x
let top_answer = `Value (Value.top, None), Alarmset.all
@@ -155,8 +158,8 @@ end
module Complete_Minimal
- (Value: Abstract_value.S)
- (Location: Abstract_location.S)
+ (Value: Abstract_value.Leaf)
+ (Location: Abstract_location.Leaf)
(Domain: Simpler_domains.Minimal)
= struct
@@ -186,8 +189,8 @@ end
module Complete_Minimal_with_datatype
- (Value: Abstract_value.S)
- (Location: Abstract_location.S)
+ (Value: Abstract_value.Leaf)
+ (Location: Abstract_location.Leaf)
(Domain: Minimal_with_datatype)
= struct
@@ -226,6 +229,9 @@ module Complete_Simple_Cvalue (Domain: Simpler_domains.Simple_Cvalue)
type state = Domain.t
type origin
+ let value_dependencies = Abstract_value.Leaf (module Main_values.CVal)
+ let location_dependencies = Abstract_location.Leaf (module Main_locations.PLoc)
+
let narrow x _y = `Value x
let extract_expr ~oracle:_ _context state expr =
@@ -604,8 +610,8 @@ module Restrict
let lift_register f state = f (get_state state)
- let register_initial_state callstack =
- lift_register (Domain.Store.register_initial_state callstack)
+ let register_initial_state callstack kf =
+ lift_register (Domain.Store.register_initial_state callstack kf)
let register_state_before_stmt callstack stmt =
lift_register (Domain.Store.register_state_before_stmt callstack stmt)
let register_state_after_stmt callstack stmt =
@@ -622,7 +628,7 @@ module Restrict
| `Top -> `Top
| `Bottom -> `Bottom
| `Value t ->
- let module Hashtbl = Value_types.Callstack.Hashtbl in
+ let module Hashtbl = Callstack.Hashtbl in
let table = Hashtbl.create (Hashtbl.length t) in
Hashtbl.iter (fun key s -> Hashtbl.add table key (inject s)) t;
`Value table
diff --git a/src/plugins/eva/domains/domain_builder.mli b/src/plugins/eva/domains/domain_builder.mli
index a9ab9a1d782440d36a086c14e800f7c0db47e559..66e384b62ac3697472b1ffb0497e3e1db135246e 100644
--- a/src/plugins/eva/domains/domain_builder.mli
+++ b/src/plugins/eva/domains/domain_builder.mli
@@ -73,16 +73,16 @@ end
module Complete (Domain: InputDomain) : LeafDomain with type t := Domain.t
module Complete_Minimal
- (Value: Abstract_value.S)
- (Location: Abstract_location.S)
+ (Value: Abstract_value.Leaf)
+ (Location: Abstract_location.Leaf)
(Domain: Simpler_domains.Minimal)
: 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)
+ (Value: Abstract_value.Leaf)
+ (Location: Abstract_location.Leaf)
(Domain: Simpler_domains.Minimal_with_datatype)
: Abstract_domain.Leaf with type value = Value.t
and type location = Location.location
diff --git a/src/plugins/eva/domains/domain_lift.ml b/src/plugins/eva/domains/domain_lift.ml
index d527ada3927f690d19a2051d03b999c474e899ca..e2b03d231689272d6d0d396b8c513bd7ee44f3be 100644
--- a/src/plugins/eva/domains/domain_lift.ml
+++ b/src/plugins/eva/domains/domain_lift.ml
@@ -22,24 +22,22 @@
open Eval
-module type Conversion = sig
- type extended_value
- type extended_location
- type internal_value
- type internal_location
-
- val extend_val : internal_value -> extended_value
- val restrict_val : extended_value -> internal_value
-
- val extend_loc : internal_location -> extended_location
- val restrict_loc : extended_location -> internal_location
+module type Input_Domain = sig
+ include Abstract_domain.S
+ val key: t Structure.Key_Domain.key
end
+module type Conversion = sig
+ type extended
+ type internal
+ val extend: internal -> extended
+ val restrict: extended -> internal
+end
module Make
- (Domain: Abstract_domain.Leaf)
- (Convert : Conversion with type internal_value := Domain.value
- and type internal_location := Domain.location)
+ (Domain: Input_Domain)
+ (Val: Conversion with type internal := Domain.value)
+ (Loc: Conversion with type internal := Domain.location)
= struct
include (Domain : Datatype.S_with_collections with type t = Domain.t)
@@ -49,38 +47,38 @@ module Make
let log_category = Domain.log_category
- type value = Convert.extended_value
- type location = Convert.extended_location
+ type value = Val.extended
+ type location = Loc.extended
type origin = Domain.origin
let extract_expr ~oracle context state exp =
- let oracle exp = oracle exp >>=: Convert.restrict_val in
+ let oracle exp = oracle exp >>=: Val.restrict in
Domain.extract_expr ~oracle context state exp >>=: fun (value, origin) ->
- Convert.extend_val value, origin
+ Val.extend value, origin
let extract_lval ~oracle context state lval typ loc =
- let oracle exp = oracle exp >>=: Convert.restrict_val in
- let loc = Convert.restrict_loc loc in
+ let oracle exp = oracle exp >>=: Val.restrict in
+ let loc = Loc.restrict loc in
Domain.extract_lval ~oracle context state lval typ loc
>>=: fun (value, origin) ->
- Convert.extend_val value, origin
+ Val.extend value, origin
let backward_location state lval typ loc value =
Domain.backward_location
- state lval typ (Convert.restrict_loc loc) (Convert.restrict_val value)
+ state lval typ (Loc.restrict loc) (Val.restrict value)
>>-: fun (loc, value) ->
- Convert.extend_loc loc, Convert.extend_val value
+ Loc.extend loc, Val.extend value
let reduce_further state expr value =
- let list = Domain.reduce_further state expr (Convert.restrict_val value) in
- List.map (fun (e, v) -> e, Convert.extend_val v) list
+ let list = Domain.reduce_further state expr (Val.restrict value) in
+ List.map (fun (e, v) -> e, Val.extend v) list
- let lift_left left = { left with lloc = Convert.restrict_loc left.lloc }
+ let lift_left left = { left with lloc = Loc.restrict left.lloc }
let lift_flagged_value value =
- { value with v = value.v >>-: Convert.restrict_val }
+ { value with v = value.v >>-: Val.restrict }
let lift_assigned = function
- | Assign value -> Assign (Convert.restrict_val value)
+ | Assign value -> Assign (Val.restrict value)
| Copy (lval, value) -> Copy (lift_left lval, lift_flagged_value value)
let lift_argument arg = { arg with avalue = lift_assigned arg.avalue }
@@ -98,7 +96,7 @@ module Make
| `Top -> `Top
in
let lift_record r = { r with value = lift_flagged_value r.value } in
- let lift_loc_record r = { r with loc = Convert.restrict_loc r.loc } in
+ let lift_loc_record r = { r with loc = Loc.restrict r.loc } in
let open Abstract_domain in
let find expr = valuation.find expr >>> lift_record in
let find_loc lval = valuation.find_loc lval >>> lift_loc_record in
@@ -126,7 +124,7 @@ module Make
let show_expr valuation = Domain.show_expr (lift_valuation valuation)
let lift_logic_dep dep =
- let location = Option.map Convert.restrict_loc dep.location in
+ let location = Option.map Loc.restrict dep.location in
{ dep with location }
let lift_logic_assigns = function
@@ -135,7 +133,7 @@ module Make
let logic_assign assigns location state =
let assigns = Option.map (fun (a, s) -> lift_logic_assigns a, s) assigns in
- Domain.logic_assign assigns (Convert.restrict_loc location) state
+ Domain.logic_assign assigns (Loc.restrict location) state
let evaluate_predicate = Domain.evaluate_predicate
let reduce_by_predicate = Domain.reduce_by_predicate
@@ -150,7 +148,7 @@ module Make
let empty = Domain.empty
let initialize_variable lval loc ~initialized init_value state =
- let loc = Convert.restrict_loc loc in
+ let loc = Loc.restrict loc in
Domain.initialize_variable lval loc ~initialized init_value state
let initialize_variable_using_type = Domain.initialize_variable_using_type
diff --git a/src/plugins/eva/domains/domain_lift.mli b/src/plugins/eva/domains/domain_lift.mli
index a1f2fba0a689502ef007bf109e27bdda7e67d7a0..3528a975514e4b1583c11753597cee5f5bd83f95 100644
--- a/src/plugins/eva/domains/domain_lift.mli
+++ b/src/plugins/eva/domains/domain_lift.mli
@@ -20,28 +20,25 @@
(* *)
(**************************************************************************)
+module type Input_Domain = sig
+ include Abstract_domain.S
+ val key: t Structure.Key_Domain.key
+end
module type Conversion = sig
- type extended_value
- type extended_location
- type internal_value
- type internal_location
-
- val extend_val : internal_value -> extended_value
- val restrict_val : extended_value -> internal_value
-
- val extend_loc : internal_location -> extended_location
- val restrict_loc : extended_location -> internal_location
+ type extended
+ type internal
+ val extend: internal -> extended
+ val restrict: extended -> internal
end
-
module Make
- (Domain: Abstract_domain.Leaf)
- (Convert : Conversion with type internal_value := Domain.value
- and type internal_location := Domain.location)
+ (Domain: Input_Domain)
+ (Val: Conversion with type internal := Domain.value)
+ (Loc: Conversion with type internal := Domain.location)
: Abstract.Domain.Internal with type state = Domain.state
- and type value = Convert.extended_value
- and type location = Convert.extended_location
+ and type value = Val.extended
+ and type location = Loc.extended
and type origin = Domain.origin
diff --git a/src/plugins/eva/domains/domain_product.ml b/src/plugins/eva/domains/domain_product.ml
index faa5590ceb6a9ba58aa1edecb081afeec0f8a784..45b71568bd946df35b2042012551fa803f82b1b1 100644
--- a/src/plugins/eva/domains/domain_product.ml
+++ b/src/plugins/eva/domains/domain_product.ml
@@ -302,7 +302,6 @@ module Make
Right.reuse kf bases ~current_input:right_input ~previous_output:right_output
let merge_tbl left_tbl right_tbl =
- let open Value_types in
let tbl = Callstack.Hashtbl.create 7 in
let merge callstack left =
try
@@ -315,7 +314,6 @@ module Make
if Callstack.Hashtbl.length tbl > 0 then `Value tbl else `Bottom
let lift_tbl f tbl =
- let open Value_types in
let new_tbl = Callstack.Hashtbl.create 7 in
let lift cs t = Callstack.Hashtbl.replace new_tbl cs (f t) in
Callstack.Hashtbl.iter lift tbl;
@@ -333,9 +331,9 @@ module Make
let register_global_state b state =
Left.Store.register_global_state b (state >>-: fst);
Right.Store.register_global_state b (state >>-: snd)
- let register_initial_state callstack (left, right) =
- Left.Store.register_initial_state callstack left;
- Right.Store.register_initial_state callstack right
+ let register_initial_state callstack kf (left, right) =
+ Left.Store.register_initial_state callstack kf left;
+ Right.Store.register_initial_state callstack kf right
let register_state_before_stmt callstack stmt (left, right) =
Left.Store.register_state_before_stmt callstack stmt left;
Right.Store.register_state_before_stmt callstack stmt right
diff --git a/src/plugins/eva/domains/domain_store.ml b/src/plugins/eva/domains/domain_store.ml
index 99d9a6c63ce295c49d2cb8bcecee3082d72e9e84..9d8f48ecd40af05f3c35dbbe25ce5540429587d9 100644
--- a/src/plugins/eva/domains/domain_store.ml
+++ b/src/plugins/eva/domains/domain_store.ml
@@ -32,22 +32,22 @@ end
module type S = sig
type t
val register_global_state: bool -> t or_bottom -> unit
- val register_initial_state: Value_types.callstack -> t -> unit
- val register_state_before_stmt: Value_types.callstack -> stmt -> t -> unit
- val register_state_after_stmt: Value_types.callstack -> stmt -> t -> unit
+ val register_initial_state: Callstack.t -> kernel_function -> t -> unit
+ val register_state_before_stmt: Callstack.t -> stmt -> t -> unit
+ val register_state_after_stmt: Callstack.t -> stmt -> t -> unit
(** Allows accessing the states inferred by an Eva analysis after it has
been computed with the domain enabled. *)
val get_global_state: unit -> t or_bottom
val get_initial_state: kernel_function -> t or_bottom
val get_initial_state_by_callstack:
- ?selection:callstack list ->
- kernel_function -> t Value_types.Callstack.Hashtbl.t or_top_bottom
+ ?selection:Callstack.t list ->
+ kernel_function -> t Callstack.Hashtbl.t or_top_bottom
val get_stmt_state: after:bool -> stmt -> t or_bottom
val get_stmt_state_by_callstack:
- ?selection:callstack list ->
- after:bool -> stmt -> t Value_types.Callstack.Hashtbl.t or_top_bottom
+ ?selection:Callstack.t list ->
+ after:bool -> stmt -> t Callstack.Hashtbl.t or_top_bottom
val mark_as_computed: unit -> unit
val is_computed: unit -> bool
@@ -105,7 +105,7 @@ module Make (Domain: InputDomain) = struct
end)
module States_by_callstack =
- Value_types.Callstack.Hashtbl.Make (Domain)
+ Callstack.Hashtbl.Make (Domain)
module Table_By_Callstack =
Cil_state_builder.Stmt_hashtbl(States_by_callstack)
@@ -158,7 +158,6 @@ module Make (Domain: InputDomain) = struct
end)
let update_callstack_table ~after stmt callstack v =
- let open Value_types in
let find,add =
if after
then AfterTable_By_Callstack.find, AfterTable_By_Callstack.add
@@ -184,10 +183,8 @@ module Make (Domain: InputDomain) = struct
| `Bottom -> ()
| `Value state -> Global_State.set state
- let register_initial_state callstack state =
+ let register_initial_state callstack kf state =
if Storage.get () then
- let open Value_types in
- let kf = match callstack with (kf, _) :: _ -> kf | _ -> assert false in
let by_callstack =
try Called_Functions_By_Callstack.find kf
with Not_found ->
@@ -217,7 +214,7 @@ module Make (Domain: InputDomain) = struct
try
let by_callstack = Called_Functions_By_Callstack.find kf in
let state =
- Value_types.Callstack.Hashtbl.fold
+ Callstack.Hashtbl.fold
(fun _cs state acc -> Bottom.join Domain.join acc (`Value state))
by_callstack `Bottom
in
@@ -229,10 +226,10 @@ module Make (Domain: InputDomain) = struct
match selection with
| None -> tbl
| Some list ->
- let new_tbl = Value_types.Callstack.Hashtbl.create (List.length list) in
+ let new_tbl = Callstack.Hashtbl.create (List.length list) in
let add cs =
- let state_opt = Value_types.Callstack.Hashtbl.find_opt tbl cs in
- Option.iter (Value_types.Callstack.Hashtbl.replace new_tbl cs) state_opt
+ let state_opt = Callstack.Hashtbl.find_opt tbl cs in
+ Option.iter (Callstack.Hashtbl.replace new_tbl cs) state_opt
in
List.iter add list;
new_tbl
@@ -263,7 +260,7 @@ module Make (Domain: InputDomain) = struct
match ho with
| None -> `Bottom
| Some h ->
- Value_types.Callstack.Hashtbl.fold
+ Callstack.Hashtbl.fold
(fun _cs state acc -> Bottom.join Domain.join acc (`Value state))
h `Bottom
in
diff --git a/src/plugins/eva/domains/domain_store.mli b/src/plugins/eva/domains/domain_store.mli
index 2eff08d35a87f5d9553b4ae615af97d04a60d065..f8779d56e301db38200b1346aa25da495c684e9a 100644
--- a/src/plugins/eva/domains/domain_store.mli
+++ b/src/plugins/eva/domains/domain_store.mli
@@ -39,22 +39,22 @@ module type S = sig
false, register functions do nothing, and get functions return Top. *)
val register_global_state: bool -> t or_bottom -> unit
- val register_initial_state: Value_types.callstack -> t -> unit
- val register_state_before_stmt: Value_types.callstack -> stmt -> t -> unit
- val register_state_after_stmt: Value_types.callstack -> stmt -> t -> unit
+ val register_initial_state: Callstack.t -> kernel_function -> t -> unit
+ val register_state_before_stmt: Callstack.t -> stmt -> t -> unit
+ val register_state_after_stmt: Callstack.t -> stmt -> t -> unit
(** Allows accessing the states inferred by an Eva analysis after it has
been computed with the domain enabled. *)
val get_global_state: unit -> t or_bottom
val get_initial_state: kernel_function -> t or_bottom
val get_initial_state_by_callstack:
- ?selection:callstack list ->
- kernel_function -> t Value_types.Callstack.Hashtbl.t or_top_bottom
+ ?selection:Callstack.t list ->
+ kernel_function -> t Callstack.Hashtbl.t or_top_bottom
val get_stmt_state: after:bool -> stmt -> t or_bottom
val get_stmt_state_by_callstack:
- ?selection:callstack list ->
- after:bool -> stmt -> t Value_types.Callstack.Hashtbl.t or_top_bottom
+ ?selection:Callstack.t list ->
+ after:bool -> stmt -> t Callstack.Hashtbl.t or_top_bottom
val mark_as_computed: unit -> unit
val is_computed: unit -> bool
diff --git a/src/plugins/eva/domains/equality/equality_domain.ml b/src/plugins/eva/domains/equality/equality_domain.ml
index 9c3d309cafddc1127bb56bd9fe631cdc0823da08..9c7407b2d0138c580d74b96b56252074168718ea 100644
--- a/src/plugins/eva/domains/equality/equality_domain.ml
+++ b/src/plugins/eva/domains/equality/equality_domain.ml
@@ -528,3 +528,20 @@ module Make
| ISEmpty | ISFormals -> Base.SetLattice.empty
| ISCaller -> Base.SetLattice.top
end
+
+
+
+module Functor = struct
+ type location = Precise_locs.precise_location
+ let location_dependencies = Main_locations.ploc
+ module Make (V : Abstract.Value.External) = Make (V)
+end
+
+let registered =
+ let name = "equality" and priority = 8 in
+ let descr =
+ "Infers equalities between syntactic C expressions. \
+ Makes the analysis less dependent on temporary variables and \
+ intermediate computations."
+ in
+ Abstractions.Domain.register_functor ~name ~priority ~descr (module Functor)
diff --git a/src/plugins/eva/domains/equality/equality_domain.mli b/src/plugins/eva/domains/equality/equality_domain.mli
index 56a182e4a562bc10ba07cb09b6d82a8dc5b2827b..0377a640734e4fa4da87efe9dc23f09ab37fa22b 100644
--- a/src/plugins/eva/domains/equality/equality_domain.mli
+++ b/src/plugins/eva/domains/equality/equality_domain.mli
@@ -36,9 +36,11 @@ val key: t Abstract_domain.key
val project: t -> Equality.Set.t
module Make (Value : Abstract.Value.External) : sig
- include Abstract_domain.Leaf with type value = Value.t
- and type location = Precise_locs.precise_location
- and type state = t
+ include Abstract_domain.S with type value = Value.t
+ and type location = Precise_locs.precise_location
+ and type state = t
val pretty_debug : Format.formatter -> t -> unit
end
+
+val registered : Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/gauges/gauges_domain.ml b/src/plugins/eva/domains/gauges/gauges_domain.ml
index 4906186a931315ff8a6ad691b4846240d0630b35..0364f4b0f0ffc9c3c1f98fed02d2ec5c7260b1ca 100644
--- a/src/plugins/eva/domains/gauges/gauges_domain.ml
+++ b/src/plugins/eva/domains/gauges/gauges_domain.ml
@@ -1122,6 +1122,9 @@ module D : Abstract_domain.Leaf
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Main_values.cval
+ let location_dependencies = Main_locations.ploc
+
include G
include Domain_builder.Complete (struct include G let top = empty end)
@@ -1288,3 +1291,11 @@ module D : Abstract_domain.Leaf
let top = G.empty (* must not be used, not neutral w.r.t. join (because
join crashes...)!! *)
end
+
+let registered =
+ let name = "gauges"
+ and descr =
+ "Infers linear inequalities between the variables modified within a loop \
+ and a special loop counter."
+ in
+ Abstractions.Domain.register ~name ~descr ~priority:6 (module D)
diff --git a/src/plugins/eva/domains/gauges/gauges_domain.mli b/src/plugins/eva/domains/gauges/gauges_domain.mli
index d268a29ab40632c4c2a0108e27baba86158db861..983f0e20782b78886d6e3578ab8ba5e96c1840dd 100644
--- a/src/plugins/eva/domains/gauges/gauges_domain.mli
+++ b/src/plugins/eva/domains/gauges/gauges_domain.mli
@@ -26,3 +26,5 @@
module D: Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
+
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/inout_domain.ml b/src/plugins/eva/domains/inout_domain.ml
index fce469fb49423b4973d549844d795b42ded00e54..efcc0bea2fa83a0dd44d5bee81583c8b08811b5f 100644
--- a/src/plugins/eva/domains/inout_domain.ml
+++ b/src/plugins/eva/domains/inout_domain.ml
@@ -204,17 +204,16 @@ module Transfer = struct
end
-module D
- (*: Domain_builder.InputDomain
- with type state = inout
- and type value = Cvalue.V.t
- and type location = Precise_locs.precise_location *)
-= struct
+module Domain = struct
+
type state = inout
type value = Cvalue.V.t
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Main_values.cval
+ let location_dependencies = Main_locations.ploc
+
include (LatticeInout: sig
include Datatype.S_with_collections with type t = state
include Abstract_domain.Lattice with type state := state
@@ -267,6 +266,14 @@ module D
let extract_lval ~oracle:_ _context _state _lv _typ _locs = top_query
end
+include Domain
+
+let registered =
+ let name = "inout"
+ and descr = "Infers the inputs and outputs of each function." in
+ Abstractions.Domain.register ~name ~descr ~priority:5 ~experimental:true
+ (module Domain)
+
(*
Local Variables:
compile-command: "make -C ../../.."
diff --git a/src/plugins/eva/domains/inout_domain.mli b/src/plugins/eva/domains/inout_domain.mli
index a224b7ec61a763fcaabbb16c53f27b55bb8e1d12..64bcde166216da9461af294e60d7be5be634d00a 100644
--- a/src/plugins/eva/domains/inout_domain.mli
+++ b/src/plugins/eva/domains/inout_domain.mli
@@ -22,6 +22,8 @@
(** Computation of inputs of outputs. *)
-module D: Abstract_domain.Leaf
+include Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
+
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/multidim/abstract_structure.ml b/src/plugins/eva/domains/multidim/abstract_structure.ml
index 79f8133794afba6f8794f5d599ad549a8fb80904..ddce48f727fc353e345829b9eaa8b3a20ede1b16 100644
--- a/src/plugins/eva/domains/multidim/abstract_structure.ml
+++ b/src/plugins/eva/domains/multidim/abstract_structure.ml
@@ -220,10 +220,6 @@ struct
struct
module Info = struct let module_name = "Abstract_memory.Disjunction.Map" end
include Datatype.Map (Map.Make (Valuation)) (Valuation) (Info)
-
- (* Defined only for Ocaml >= 4.11 *)
- let filter_map f m =
- fold (fun k x m -> match f k x with None -> m | Some y -> add k y m) m empty
end
module S = (* Structures in the disjunction *)
diff --git a/src/plugins/eva/domains/multidim/multidim_domain.ml b/src/plugins/eva/domains/multidim/multidim_domain.ml
index 4d2cf0c8a9bad96390659645499ac1f0575017fe..2b2bb6301f28d2a3547714dce4c2c3e10f5314e9 100644
--- a/src/plugins/eva/domains/multidim/multidim_domain.ml
+++ b/src/plugins/eva/domains/multidim/multidim_domain.ml
@@ -365,6 +365,9 @@ struct
let name = "multidim"
+ let value_dependencies = Main_values.cval
+ let location_dependencies = Main_locations.ploc
+
type state = t
type value = Value.t
type value_or_uninitialized = Value_or_Uninitialized.t
@@ -941,15 +944,11 @@ let multidim_hook (module Abstract: Abstractions.S) : (module Abstractions.S) =
end)
(* Registers the domain. *)
-let flag =
+let registered =
let name = "multidim"
and descr = "Improve the precision over arrays of structures \
or multidimensional arrays."
- and experimental = true
- and abstraction =
- Abstractions.{ values = Single (module Main_values.CVal);
- domain = Domain (module Domain); }
in
- Abstractions.register ~name ~descr ~experimental abstraction
+ Abstractions.Domain.register ~name ~descr ~experimental:true (module Domain)
-let () = Abstractions.register_hook multidim_hook
+let () = Abstractions.Hooks.register multidim_hook
diff --git a/src/plugins/eva/domains/multidim/multidim_domain.mli b/src/plugins/eva/domains/multidim/multidim_domain.mli
index 5df3635d248f49ca8d75027a40dd28a28303ed1f..ce8f376e509af1586a9c62aca8961812da09b2c6 100644
--- a/src/plugins/eva/domains/multidim/multidim_domain.mli
+++ b/src/plugins/eva/domains/multidim/multidim_domain.mli
@@ -24,4 +24,4 @@ include Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
-val flag: Abstractions.flag
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/multidim/segmentation.ml b/src/plugins/eva/domains/multidim/segmentation.ml
index 06ffc859de30512647526c323c0476eb2eef6157..475933251eaa60f4d2ca7ea589200eeeb63ce19b 100644
--- a/src/plugins/eva/domains/multidim/segmentation.ml
+++ b/src/plugins/eva/domains/multidim/segmentation.ml
@@ -471,7 +471,7 @@ struct
M.compare v1 v2 <?> lazy (B.compare u1 u2)
in
B.compare m1.start m2.start <?>
- lazy (Transitioning.List.compare compare_segments m1.segments m2.segments) <?>
+ lazy (List.compare compare_segments m1.segments m2.segments) <?>
lazy (Bit.compare m1.padding m2.padding)
let equal (m1 : t) (m2 : t) : bool =
@@ -479,7 +479,7 @@ struct
M.equal v1 v2 && B.equal u1 u2
in
B.equal m1.start m2.start &&
- Transitioning.List.equal equal_segments m1.segments m2.segments &&
+ List.equal equal_segments m1.segments m2.segments &&
Bit.equal m1.padding m2.padding
let raw (m : t) : bit =
diff --git a/src/plugins/eva/domains/numerors/numerors_domain.ml b/src/plugins/eva/domains/numerors/numerors_domain.ml
index ec40528a61bead026670aee4fa5c71375fd94195..ab8f9a5eaf0df3332c7eb972fb22412b6c7a3493 100644
--- a/src/plugins/eva/domains/numerors/numerors_domain.ml
+++ b/src/plugins/eva/domains/numerors/numerors_domain.ml
@@ -78,6 +78,7 @@ module Numerors_Value = struct
; ("log", log) ; ("exp", exp) ; ("sqrt", sqrt)
; ("DPRINT", dprint)
]
+
end
(* The numerors domain: a simple memory over the numerors value. *)
@@ -151,17 +152,15 @@ let reduce_cast (module Abstract: Abstractions.S) =
end: Abstractions.S)
(* Register the domain as an Eva abstractions. *)
+let registered =
+ let name = "numerors" and experimental = true in
+ let descr =
+ "Infers ranges for the absolute and relative errors \
+ in floating-point computations. No support of loops."
+ in
+ Abstractions.Domain.register ~name ~experimental ~descr (module Domain)
+
let () =
let open Abstractions in
- let name = "numerors"
- and descr = "Infers ranges for the absolute and relative errors \
- in floating-point computations. No support of loops."
- and experimental = true
- and abstraction =
- { values = Single (module Numerors_value);
- domain = Domain (module Domain); }
- in
- let reduced_product = Main_values.CVal.key, Numerors_value.key, reduce_error in
- ignore (register ~name ~descr ~experimental abstraction);
- register_value_reduction reduced_product;
- register_hook reduce_cast
+ Reducer.register Main_values.CVal.key Numerors_Value.key reduce_error ;
+ Hooks.register reduce_cast
diff --git a/src/plugins/eva/domains/numerors/numerors_domain.mli b/src/plugins/eva/domains/numerors/numerors_domain.mli
index 707b9094300b0f0f16d9f5c235924e2fea512815..184f827d6225b2022c452269ed95f3785c6122aa 100644
--- a/src/plugins/eva/domains/numerors/numerors_domain.mli
+++ b/src/plugins/eva/domains/numerors/numerors_domain.mli
@@ -24,3 +24,5 @@
of floating-point computations.
Nothing is exported: the domain is registered as an analysis abstraction
in the Eva engine, enabled by the -eva-domains numerors option. *)
+
+val registered : Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/numerors/numerors_value.ml b/src/plugins/eva/domains/numerors/numerors_value.ml
index 574087982663173f898299f30c7dc913dcb07f8d..796589a461197016d7ee6b856ac18ade11a9d899 100644
--- a/src/plugins/eva/domains/numerors/numerors_value.ml
+++ b/src/plugins/eva/domains/numerors/numerors_value.ml
@@ -29,7 +29,6 @@ module P = Precisions
module Arith = Numerors_arithmetics
-
(*-----------------------------------------------------------------------------
* Abstract value for numerical errors estimation
*-----------------------------------------------------------------------------
@@ -116,7 +115,6 @@ end
include Datatype.Make(T)
let pretty_debug = pretty
let pretty_typ _ = pretty
-let key = Structure.Key_Value.create_key "numerors_values"
(*-----------------------------------------------------------------------------
@@ -395,3 +393,5 @@ let get_max_absolute_error = function
let get_max_relative_error = function
| Elt x -> Some (snd (I.get_bounds (I.abs (x.Arith.rel_err))))
| _ -> None
+
+let key = Structure.Key_Value.create_key "numerors_values"
diff --git a/src/plugins/eva/domains/octagons.ml b/src/plugins/eva/domains/octagons.ml
index 00adb0b62fdff9fa42f670690688e674271b7a16..950dc8745b371c643e11a8df1865e97798e22982 100644
--- a/src/plugins/eva/domains/octagons.ml
+++ b/src/plugins/eva/domains/octagons.ml
@@ -1616,6 +1616,9 @@ module Domain = struct
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Main_values.cval
+ let location_dependencies = Main_locations.ploc
+
let top_value = `Value (Cvalue.V.top, None), Alarmset.all
(* Evaluator building. *)
@@ -1953,3 +1956,11 @@ module Domain = struct
end
include Domain
+
+let registered =
+ let name = "octagon"
+ and descr =
+ "Infers relations between scalar variables of the form b ≤ ±X ± Y ≤ e, \
+ where X, Y are program variables and b, e are constants."
+ in
+ Abstractions.Domain.register ~name ~descr ~priority:6 (module Domain)
diff --git a/src/plugins/eva/domains/octagons.mli b/src/plugins/eva/domains/octagons.mli
index 2625b8b6b75f0296d68e8cdb9082babcf40cc8d0..ce8f376e509af1586a9c62aca8961812da09b2c6 100644
--- a/src/plugins/eva/domains/octagons.mli
+++ b/src/plugins/eva/domains/octagons.mli
@@ -23,3 +23,5 @@
include Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
+
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/offsm_domain.ml b/src/plugins/eva/domains/offsm_domain.ml
index 26aad6c665b306b8e84a9c2d55e5eba8f38fa08d..6714d6986b29bda399e5ccb49aa039ef05d9b8bc 100644
--- a/src/plugins/eva/domains/offsm_domain.ml
+++ b/src/plugins/eva/domains/offsm_domain.ml
@@ -101,6 +101,9 @@ module D : Abstract_domain.Leaf
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Abstract_value.Leaf (module Offsm_value.Offsm)
+ let location_dependencies = Main_locations.ploc
+
include (Memory: sig
include Datatype.S_with_collections with type t = state
include Abstract_domain.Lattice with type state := state
@@ -224,3 +227,10 @@ module D : Abstract_domain.Leaf
let loc = Precise_locs.imprecise_location location in
kill loc state
end
+
+let registered =
+ let name = "bitwise"
+ and descr =
+ "Infers bitwise information to interpret more precisely bitwise operators."
+ in
+ Abstractions.Domain.register ~name ~descr ~priority:3 (module D)
diff --git a/src/plugins/eva/domains/offsm_domain.mli b/src/plugins/eva/domains/offsm_domain.mli
index 9b69966616999b75f6208ea619504e1f0a25246b..2d38b3c035bda149c8af7573800ab33a4a968dbc 100644
--- a/src/plugins/eva/domains/offsm_domain.mli
+++ b/src/plugins/eva/domains/offsm_domain.mli
@@ -23,3 +23,5 @@
module D : Abstract_domain.Leaf
with type value = Offsm_value.offsm_or_top
and type location = Precise_locs.precise_location
+
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/printer_domain.ml b/src/plugins/eva/domains/printer_domain.ml
index 270925f3ad699eca48fa9607b75ac758a012320f..bda8719c9e632a1c28759f081b5f09f27974642c 100644
--- a/src/plugins/eva/domains/printer_domain.ml
+++ b/src/plugins/eva/domains/printer_domain.ml
@@ -125,4 +125,13 @@ module Simple : Simpler_domains.Simple_Cvalue = struct
state
end
-include Domain_builder.Complete_Simple_Cvalue (Simple)
+module Domain = Domain_builder.Complete_Simple_Cvalue (Simple)
+include Domain
+
+let registered =
+ let name = "printer"
+ and descr =
+ "Debug domain, only useful for developers. Prints the transfer functions \
+ used during the analysis."
+ in
+ Abstractions.Domain.register ~name ~descr ~priority:2 (module Domain)
diff --git a/src/plugins/eva/domains/printer_domain.mli b/src/plugins/eva/domains/printer_domain.mli
index c23cfc215f0c44367b4d2d17f0b68f16352ebf7a..d980026fca690afdd474e4fc859ba0e384c69745 100644
--- a/src/plugins/eva/domains/printer_domain.mli
+++ b/src/plugins/eva/domains/printer_domain.mli
@@ -25,3 +25,5 @@
during an analysis. *)
include Abstract_domain.Leaf with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
+
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/sign_domain.ml b/src/plugins/eva/domains/sign_domain.ml
index ab0ce64335e51ca7b7f010faa459f30a07a2cc94..3e6150e19e4e9babc0da709f62f92450e0cbfd2d 100644
--- a/src/plugins/eva/domains/sign_domain.ml
+++ b/src/plugins/eva/domains/sign_domain.ml
@@ -34,4 +34,11 @@ module Sign_Value = struct
let builtins = []
end
-include Simple_memory.Make_Domain (struct let name = "sign" end) (Sign_Value)
+module Name = struct let name = "sign" end
+module Domain = Simple_memory.Make_Domain (Name) (Sign_Value)
+include Domain
+
+let registered =
+ let name = "sign"
+ and descr = "Infers the sign of program variables." in
+ Abstractions.Domain.register ~name ~descr ~priority:4 (module Domain)
diff --git a/src/plugins/eva/domains/sign_domain.mli b/src/plugins/eva/domains/sign_domain.mli
index e8d8622c30a537200663fd9190a61f77582cf456..585d0f1deea2055c74e0a5b1da099daf90c61e8e 100644
--- a/src/plugins/eva/domains/sign_domain.mli
+++ b/src/plugins/eva/domains/sign_domain.mli
@@ -24,3 +24,5 @@
include Abstract_domain.Leaf with type value = Sign_value.t
and type location = Precise_locs.precise_location
+
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/simple_memory.ml b/src/plugins/eva/domains/simple_memory.ml
index 59bd9034a92fd8ab05765de9f74e9fef66fd81c9..deb6d926511f5d590daef40d9b830084ee78d1a5 100644
--- a/src/plugins/eva/domains/simple_memory.ml
+++ b/src/plugins/eva/domains/simple_memory.ml
@@ -26,12 +26,8 @@ open Eval
type 'value builtin = 'value list -> 'value or_bottom
module type Value = sig
- include Datatype.S
- val top : t
- val join : t -> t -> t
+ include Abstract_value.Leaf
val widen : t -> t -> t
- val narrow : t -> t -> t or_bottom
- val is_included : t -> t -> bool
val track_variable: Cil_types.varinfo -> bool
val pretty_debug: t Pretty_utils.formatter
val builtins: (string * t builtin) list
@@ -198,6 +194,9 @@ module Make_Domain (Info: sig val name: string end) (Value: Value) = struct
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Abstract_value.Leaf (module Value)
+ let location_dependencies = Main_locations.ploc
+
let log_category = Self.register_category ("d-" ^ Info.name)
let widen _kf _stmt = widen
diff --git a/src/plugins/eva/domains/simple_memory.mli b/src/plugins/eva/domains/simple_memory.mli
index 3e9b6377bd23c06e67716b78a6f8de6689054440..f1e67e165a93e697710548ad9fb8058b9a670550 100644
--- a/src/plugins/eva/domains/simple_memory.mli
+++ b/src/plugins/eva/domains/simple_memory.mli
@@ -30,15 +30,10 @@ type 'value builtin = 'value list -> 'value Eval.or_bottom
(** Abstraction of the values variables are mapped to. *)
module type Value = sig
- include Datatype.S
+ include Abstract_value.Leaf
- (** Lattice structure. *)
-
- val top : t
- val join : t -> t -> t
+ (** Widening operation to ensure convergence. *)
val widen : t -> t -> t
- val narrow : t -> t -> t Eval.or_bottom
- val is_included : t -> t -> bool
(** This function must return [true] if the given variable should be
tracked by the domain. All untracked variables are implicitely
diff --git a/src/plugins/eva/domains/symbolic_locs.ml b/src/plugins/eva/domains/symbolic_locs.ml
index 8dd06c85fa33a88e13d6daed4daddeee7173870f..c174803290531a6985cf538763f9483be7edd2ad 100644
--- a/src/plugins/eva/domains/symbolic_locs.ml
+++ b/src/plugins/eva/domains/symbolic_locs.ml
@@ -464,6 +464,9 @@ module D : Abstract_domain.Leaf
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Main_values.cval
+ let location_dependencies = Main_locations.ploc
+
include (Memory: sig
include Datatype.S_with_collections with type t = state
include Abstract_domain.Lattice with type state := state
@@ -637,3 +640,11 @@ module D : Abstract_domain.Leaf
let loc = Precise_locs.imprecise_location location in
Memory.kill loc state
end
+
+let registered =
+ let name = "symbolic-locations"
+ and descr =
+ "Infers values of symbolic locations represented by imprecise lvalues, \
+ such as t[i] or *p when the possible values of [i] or [p] are imprecise."
+ in
+ Abstractions.Domain.register ~name ~descr ~priority:7 (module D)
diff --git a/src/plugins/eva/domains/symbolic_locs.mli b/src/plugins/eva/domains/symbolic_locs.mli
index dba5b5878f7b7b7aaf2bc76f1a7b0e28b120fd0d..72e532a197f2ba8eb9de0bba754d9e280ba8e009 100644
--- a/src/plugins/eva/domains/symbolic_locs.mli
+++ b/src/plugins/eva/domains/symbolic_locs.mli
@@ -26,3 +26,5 @@
module D: Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
+
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/domains/taint_domain.ml b/src/plugins/eva/domains/taint_domain.ml
index 6abf186ae3fd6e7b52aa9c261fb0cabfa20b769f..4c37d351ce496021ba57d010b0577c792356c66f 100644
--- a/src/plugins/eva/domains/taint_domain.ml
+++ b/src/plugins/eva/domains/taint_domain.ml
@@ -295,12 +295,15 @@ module QueriesTaint = struct
end
-module TaintDomain = struct
+module Domain = struct
type state = taint_state
type value = Cvalue.V.t
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Main_values.cval
+ let location_dependencies = Main_locations.ploc
+
include (LatticeTaint: sig
include Datatype.S_with_collections with type t = state
include Abstract_domain.Lattice with type state := state
@@ -380,7 +383,13 @@ module TaintDomain = struct
join state previous_output
end
-include TaintDomain
+include Domain
+
+(* Registers the domain. *)
+let registered =
+ let name = "taint"
+ and descr = "Taint analysis" in
+ Abstractions.Domain.register ~name ~descr ~experimental:true (module Domain)
(* Registers ACSL builtin predicate \tainted. *)
@@ -581,18 +590,7 @@ let interpret_taint_logic
module Dom = Dom
end)
-(* Registers the domain. *)
-let flag =
- let name = "taint"
- and descr = "Taint analysis"
- and experimental = true
- and abstraction =
- Abstractions.{ values = Single (module Main_values.CVal);
- domain = Domain (module TaintDomain); }
- in
- Abstractions.register ~name ~descr ~experimental abstraction
-
-let () = Abstractions.register_hook interpret_taint_logic
+let () = Abstractions.Hooks.register interpret_taint_logic
type taint = Direct | Indirect | Untainted
diff --git a/src/plugins/eva/domains/taint_domain.mli b/src/plugins/eva/domains/taint_domain.mli
index fa31e885b038f02c351fa5b87c073a8b4e5b8c44..2b26fa23af604b9eeb6ce7ff3274a226beee2957 100644
--- a/src/plugins/eva/domains/taint_domain.mli
+++ b/src/plugins/eva/domains/taint_domain.mli
@@ -26,7 +26,7 @@ include Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
-val flag: Abstractions.flag
+val registered: Abstractions.Domain.registered
type taint = | Direct | Indirect | Untainted
diff --git a/src/plugins/eva/domains/traces_domain.ml b/src/plugins/eva/domains/traces_domain.ml
index 396d0cfca6bc06b4a58a60255cb599cc4b1f58eb..cda82de061d84559cc90ea3d4fd7426ee43c62ea 100644
--- a/src/plugins/eva/domains/traces_domain.ml
+++ b/src/plugins/eva/domains/traces_domain.ml
@@ -1089,6 +1089,9 @@ module D = struct
type location = Precise_locs.precise_location
type origin
+ let value_dependencies = Main_values.cval
+ let location_dependencies = Main_locations.ploc
+
include (Traces: sig
include Datatype.S_with_collections with type t = state
include Abstract_domain.Lattice with type state := state
@@ -1260,6 +1263,15 @@ module D = struct
then project_of_cfg return_exp state
end
+let registered =
+ let name = "traces"
+ and descr =
+ "Builds an over-approximation of all the traces that lead to a statement."
+ in
+ Abstractions.Domain.register ~name ~descr ~priority:2 ~experimental:true
+ (module D)
+
+
(*
Local Variables:
diff --git a/src/plugins/eva/domains/traces_domain.mli b/src/plugins/eva/domains/traces_domain.mli
index 7e13fe9d4212dcdf761de59c8329580c06090f56..83dff43f31f74e7c0f9d34a1bc8896d6a0486503 100644
--- a/src/plugins/eva/domains/traces_domain.mli
+++ b/src/plugins/eva/domains/traces_domain.mli
@@ -76,3 +76,5 @@ module D: Abstract_domain.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
and type state = state
+
+val registered: Abstractions.Domain.registered
diff --git a/src/plugins/eva/dune b/src/plugins/eva/dune
index 6877dfd4327e79a383f3fca9c87c3ee06e1952cb..a5aae82cd3584e41c471019a26e2bfd4477b48c1 100644
--- a/src/plugins/eva/dune
+++ b/src/plugins/eva/dune
@@ -105,7 +105,7 @@
(mode (promote (only Eva.mli)))
(deps
gen-api.sh Eva.header
- engine/analysis.mli utils/results.mli parameters.mli
+ engine/analysis.mli types/callstack.mli utils/results.mli parameters.mli
utils/eva_annotations.mli eval.mli domains/cvalue/builtins.mli
utils/cvalue_callbacks.mli legacy/logic_inout.mli utils/eva_results.mli
utils/unit_tests.mli)
diff --git a/src/plugins/eva/engine/abstractions.ml b/src/plugins/eva/engine/abstractions.ml
index 573457ba34d0d5877b5bc14e9c3250c314e523c7..ef09af89e6d91a9a4fafb5035a67f30bb641acaa 100644
--- a/src/plugins/eva/engine/abstractions.ml
+++ b/src/plugins/eva/engine/abstractions.ml
@@ -20,527 +20,649 @@
(* *)
(**************************************************************************)
-(* --- Registration types --------------------------------------------------- *)
-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
+(* --- Values abstraction --------------------------------------------------- *)
+
+module Value = struct
+ type 'v structure = 'v Abstract.Value.structure
+ type 'v key = 'v Abstract.Value.key
+ type 'v dependencies = 'v Abstract_value.dependencies
+ let dec_eq = Abstract.Value.eq_structure
+
+ type 'v value = (module Abstract_value.Leaf with type t = 'v)
+
+ (* When building the abstraction, we will need to compare the dependencies
+ structure with the structured values. *)
+ let rec outline : type v. v dependencies -> v structure = function
+ | Leaf value ->
+ let module V = (val value) in
+ Abstract.Value.Leaf (V.key, (module V))
+ | Node (l, r) -> Abstract.Value.(Node (outline l, outline r))
+
+ (* Folding over values dependencies *)
+ type 'a folder = { folder : 'v. 'v value -> 'a -> 'a }
+ let rec fold : type v. 'a folder -> v dependencies -> 'a -> 'a =
+ fun folder dependencies acc ->
+ match dependencies with
+ | Leaf leaf -> folder.folder leaf acc
+ | Node (l, r) -> fold folder l (fold folder r acc)
+
+ (* The value abstraction build consists of accumulating registered values
+ into a structured value and then adding the needed operators, thus making
+ it interactive. A [Unit] structured abstraction is used for the initial
+ state and is discarded as soon as a real value abstraction is added. *)
+ module type Structured = Abstract.Value.Internal
+ module type Interactive = Abstract.Value.External
+ type 'a or_unit = Unit | Value of 'a
+ type structured = (module Structured) or_unit
+ type interactive = (module Interactive) or_unit
+
+ (* Making a structured value interactive simply consists of adding the
+ needed operations using the Structure.Open functor.*)
+ let make_interactive : structured -> interactive = function
+ | Unit -> Unit
+ | Value (module Structured) ->
+ Value (module struct
+ include Structured
+ include Structure.Open (Abstract.Value) (Structured)
+ end)
-module type leaf_domain = Abstract_domain.Leaf with type location = precise_loc
+ (* Adding a registered value into a structured one consists of deciding if
+ a product is needed (which comes down to checking if the registered
+ value key we want to add is not in the structure), computing it, and
+ updating the structure. *)
+ let add : type v. v value -> structured -> structured =
+ fun (module Val) structured ->
+ let leaf = Abstract.Value.Leaf (Val.key, (module Val)) in
+ match make_interactive structured with
+ | Unit ->
+ Value (module struct
+ include Val
+ let structure = leaf
+ end)
+ | Value (module Interactive) when not (Interactive.mem Val.key) ->
+ Value (module struct
+ include Value_product.Make (Interactive) (Val)
+ let structure = Abstract.Value.Node (Interactive.structure, leaf)
+ end)
+ | _ -> structured
+
+ (* The minimal value abstraction to use. *)
+ let init : structured = Unit
+
+ (* During the complete abstraction build, we need to verify that there is at
+ least one value in the computed abstraction.
+ TODO: better error handling. *)
+ let assert_not_unit = function
+ | Unit -> Self.fatal "The built value cannot be unit."
+ | Value interactive -> interactive
+
+
+ (* When building the complete abstraction, we need to trick locations and
+ domains into thinking that their value dependencies are there, even if
+ the structured value type is not the good one. This is done through a
+ lift that requires conversion operations to interact with the subpart
+ of the structured value that matters for the location or the domain.
+ This functor is responsible of building such conversion operations. *)
+ module type From = sig type value val structure : value structure end
+ module Converter (From : From) (To : Interactive) = struct
+ type extended = To.t
+ let structure = From.structure
+
+ let void_value () =
+ Self.fatal "Cannot register a value module from a Void structure."
+
+ let rec set : type v. v structure -> v -> extended -> extended = function
+ | Leaf (key, _) -> To.set key
+ | Node (s1, s2) -> fun (v1, v2) ext -> set s2 v2 ext |> set s1 v1
+ | Option (s, default) -> fun v -> set s (Option.value ~default v)
+ | Unit -> fun () value -> value
+ | Void -> void_value ()
+
+ let rec get : type v. v structure -> extended -> v = function
+ | Leaf (key, _) -> Option.get (To.get key)
+ | Node (s1, s2) -> fun v -> get s1 v, get s2 v
+ | Option (s, _) -> fun v -> Some (get s v)
+ | Unit -> fun _ -> ()
+ | Void -> void_value ()
+
+ let replace = set structure
+ let extend v = replace v To.top
+ let restrict = get structure
+ end
+end
-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 =
- { values: 'v value;
- domain: 'v domain; }
+(* --- Locations abstraction ------------------------------------------------ *)
+
+module Location = struct
+ type 'l structure = 'l Abstract.Location.structure
+ type 'l dependencies = 'l Abstract_location.dependencies
+ let dec_eq = Abstract.Location.eq_structure
+
+ type 'l location = (module Abstract_location.Leaf with type location = 'l)
+
+ (* When building the abstraction, we will need to compare the dependencies
+ structure with the structured values. *)
+ let rec outline: type v. v dependencies -> v structure = function
+ | Leaf location ->
+ let module Loc = (val location) in
+ Abstract.Location.Leaf (Loc.key, (module Loc))
+ | Node (l, r) -> Abstract.Location.(Node (outline l, outline r))
+
+ (* Folding over values dependencies *)
+ type 'a folder = { folder : 'l. 'l location -> 'a -> 'a }
+ let rec fold : type v. 'a folder -> v dependencies -> 'a -> 'a =
+ fun folder dependencies acc ->
+ match dependencies with
+ | Leaf leaf -> folder.folder leaf acc
+ | Node (l, r) -> fold folder l (fold folder r acc)
+
+ (* Folding over the values dependencies of some locations dependencies. *)
+ let rec fold_values : type v. 'a Value.folder -> v dependencies -> 'a -> 'a =
+ fun folder dependencies acc ->
+ match dependencies with
+ | Leaf (module R) -> Value.fold folder R.value acc
+ | Node (l, r) -> fold_values folder l (fold_values folder r acc)
+
+
+ (* As for the value abstraction, building the location abstraction consists
+ of structuring the needed registered locations and then adding the needed
+ operators to make it interactive. However, a structured location is not
+ as simple as a structured value, as it needs to keep track of the value
+ abstraction it is based on. This value is supposed to be the complete
+ aggregation of all the values that are needed by the requested domains. *)
+ module type Structured = sig
+ type value
+ module Value : Value.Interactive with type t = value
+ module Location : Abstract.Location.Internal with type value = value
+ end
-type 't with_info =
- { name: string;
- experimental: bool;
- priority: int;
- abstraction: 't; }
+ module type Interactive = Abstract.Location.External
+
+ (* We expose the type of the structured value we are based on to statically
+ ensure that we do not temper with it. As for the value abstractions, a
+ [Unit] structured abstraction is used for the initial state and is
+ discarded as soon as a location is added. *)
+ type ('u, 'l) or_unit = Unit of 'u | Location of 'l
+ type 'v value = (module Value.Interactive with type t = 'v)
+ type 'v structured_module = (module Structured with type value = 'v)
+ type 'v structured = ('v value, 'v structured_module) or_unit
+ type 'v interactive_module = (module Interactive with type value = 'v)
+ type 'v interactive = ('v value, 'v interactive_module) or_unit
+
+ (* Initial location builder *)
+ let init (value : 'v value) : 'v structured = Unit value
+
+ (* During the complete abstraction build, we need to verify that there is at
+ least one location in the computed abstraction.
+ TODO: better error handling. *)
+ let assert_not_unit = function
+ | Unit _ -> Self.fatal "The built location cannot be unit."
+ | Location interactive -> interactive
+
+
+ (* Making a structured value interactive simply consists of adding the
+ needed operations using the Structure.Open functor.*)
+ let make_interactive : type v. v structured -> v interactive = function
+ | Unit value -> Unit value
+ | Location (module Structured) ->
+ Location (module struct
+ include Structured.Location
+ include Structure.Open (Abstract.Location) (struct
+ include Structured.Location
+ type t = location
+ end)
+ end)
-type flag = Flag: 'v abstraction with_info -> flag
+ (* Retrieves the value contained in a structured location. *)
+ let get_value : type v. v structured -> v value = function
+ | Unit value -> value
+ | Location (module S) -> (module S.Value)
+
+
+ (* Adding a registered location into a structured one is done in three steps:
+ 1. Lifting the location abstraction we want to add to match the value
+ abstraction contained in the structured abstraction.
+ 2. Combine the given location abstraction with the one contained in the
+ structured abstraction. It comes down to decide if a reduced product is
+ needed.
+ 3. Rebuild a structured abstraction with the new location abstraction. *)
+ let add : type v l. l location -> v structured -> v structured =
+ fun (module Leaf) structured ->
+ let leaf_value_structure = Value.outline Leaf.value in
+ let module To = (val get_value structured) in
+ let lifted_leaf : (module Abstract.Location.Internal with type value = v) =
+ match Value.dec_eq leaf_value_structure To.structure with
+ | Some Eq ->
+ let leaf = Abstract.Location.Leaf (Leaf.key, (module Leaf)) in
+ (module struct include Leaf let structure = leaf end)
+ | None ->
+ let module From = struct
+ type value = Leaf.value
+ let structure = leaf_value_structure
+ end in
+ let module Converter = Value.Converter (From) (To) in
+ (module Location_lift.Make (Leaf) (Converter))
+ in
+ let combined : (module Abstract.Location.Internal with type value = v) =
+ match make_interactive structured with
+ | Unit _ -> lifted_leaf
+ | Location (module Loc) when Loc.mem Leaf.key -> (module Loc)
+ | Location (module Loc) ->
+ (module Locations_product.Make (To) (val lifted_leaf) (Loc))
+ in
+ Location (module struct
+ type value = v
+ module Value = To
+ module Location = (val combined)
+ end)
+
+
+ (* When building the complete abstraction, we need to trick domains into
+ thinking that their locations dependencies are there, even if the
+ structured location type is not the good one. This is done through a
+ lift that requires conversion operations to interact with the subpart
+ of the structured location that matters for the domains. This functor is
+ responsible of building such conversion operations. *)
+ module type From = sig type location val structure : location structure end
+ module Converter (From : From) (To : Interactive) = struct
+ type extended = To.location
+ let structure = From.structure
+
+ let void_location () =
+ Self.fatal "Cannot register a location module from a Void structure."
+
+ let rec set : type l. l structure -> l -> extended -> extended = function
+ | Leaf (key, _) -> To.set key
+ | Node (s1, s2) -> fun (l1, l2) ext -> set s2 l2 ext |> set s1 l1
+ | Option (s, default) -> fun l -> set s (Option.value ~default l)
+ | Unit -> fun () loc -> loc
+ | Void -> void_location ()
+
+ let rec get : type l. l structure -> extended -> l = function
+ | Leaf (key, _) -> Option.get (To.get key)
+ | Node (s1, s2) -> fun l -> get s1 l, get s2 l
+ | Option (s, _) -> fun l -> Some (get s l)
+ | Unit -> fun _ -> ()
+ | Void -> void_location ()
+
+ let replace = set structure
+ let extend l = replace l To.top
+ let restrict = get structure
+ end
+end
-(* --- Config and registration ---------------------------------------------- *)
-module Config = struct
- module OptMode = Datatype.Option (Domain_mode)
- module Element = struct
- type t = flag * Domain_mode.t option
-
- (* Flags are sorted by increasing priority order, and then by name. *)
- let compare (Flag f1, mode1) (Flag f2, mode2) =
- let c = Datatype.Int.compare f1.priority f2.priority in
- if c <> 0 then c else
- let c = Datatype.String.compare f1.name f2.name in
- if c <> 0 then c else
- OptMode.compare mode1 mode2
- end
- include Set.Make (Element)
+(* --- Domains abstraction -------------------------------------------------- *)
- let mem (Flag domain) =
- exists (fun (Flag flag, _mode) -> flag.name = domain.name)
+module Domain = struct
+ module type S = Abstract_domain.S
- let abstractions = ref []
- let dynamic_abstractions = ref []
+ (** Functor domain which can be built over any value abstractions, but with
+ fixed locations dependencies. *)
+ module type Functor = sig
+ type location
+ val location_dependencies: location Abstract_location.dependencies
+ module Make (V : Abstract.Value.External) : sig
+ include Abstract_domain.S
+ with type value = V.t and type location = location
+ val key : state Abstract_domain.key
+ end
+ end
+ (* To simplify the domain registration procedure, we provide common types.
+ However, the code above is still useful to prove some properties, mainly
+ that we do not temper with the dependencies. *)
+ type domain =
+ | Domain : (module Abstract_domain.Leaf) -> domain
+ | Functor : (module Functor) -> domain
+
+ (* Registered domain are saved in mutable lists along with their information:
+ name, experimental status and priority. *)
+ type registered =
+ { name : string
+ ; experimental : bool
+ ; priority : int
+ ; abstraction : domain
+ }
+
+ (* The configuration of an analysis contains a set of registered domains
+ along with their analysis mode. *)
+ type registered_with_mode = registered * Domain_mode.t option
+
+ (* Mutable lists containing statically and dynamically registered domains. *)
+ let static_domains = ref []
+ let dynamic_domains = ref []
+
+ (* Helper function used to register the parameters of a domain. *)
let register_domain_option ~name ~experimental ~descr =
let descr = if experimental then "Experimental. " ^ descr else descr in
Parameters.register_domain ~name ~descr
- let register ~name ~descr ?(experimental=false) ?(priority=0) abstraction =
- register_domain_option ~name ~experimental ~descr;
- let flag = Flag { name; experimental; priority; abstraction } in
- abstractions := flag :: !abstractions;
- flag
+ (* Registration of a leaf or functor domain. *)
+ let register_domain
+ ~name ~descr ?(experimental=false) ?(priority=0) abstraction =
+ register_domain_option ~name ~descr ~experimental ;
+ let registered = { name ; experimental ; priority ; abstraction } in
+ static_domains := registered :: !static_domains ;
+ registered
+
+ (* Registration of a leaf domain. *)
+ let register ~name ~descr ?experimental ?priority domain =
+ register_domain ~name ~descr ?experimental ?priority (Domain domain)
+
+ (* Registration of a functor domain. *)
+ let register_functor ~name ~descr ?experimental ?priority domain =
+ register_domain ~name ~descr ?experimental ?priority (Functor domain)
+ (* Registration of a dynamic domain. *)
let dynamic_register ~name ~descr ?(experimental=false) ?(priority=0) make =
- register_domain_option ~name ~experimental ~descr;
- let make' () : flag =
- Flag { name; experimental; priority; abstraction = make () }
- in
- dynamic_abstractions := (name,make') :: !dynamic_abstractions
+ register_domain_option ~name ~descr ~experimental ;
+ let make () = Domain (make ()) in
+ let make () = { name ; experimental ; priority ; abstraction = make () } in
+ dynamic_domains := (name, make) :: !dynamic_domains
+
+ (* Building the domain abstraction consists of structuring the requested
+ registered domains. To do so, we need to keep track of the values and
+ locations abstraction on which the structured domain will rely. Those
+ abstractions are supposed to be the complete aggregations of all the
+ values (resp locations) that are needed by the requested domains. *)
+ module type Structured = sig
+ type value
+ type location
+ module Value : Value.Interactive with type t = value
+ module Location : Location.Interactive
+ with type value = value and type location = location
+ module Domain : Abstract.Domain.Internal
+ with type value = value and type location = location
+ end
- let configure () =
- let add_main_mode mode =
- let main, _ = Globals.entry_point () in
- (main, Domain_mode.Mode.all) :: mode
+ (* As for the value and location abstractions, a [Unit] structured domain is
+ used for the initial state. *)
+ type ('v, 'l, 's) or_unit = Unit of 'v * 'l | State of 's
+ type 'v value = (module Value.Interactive with type t = 'v)
+ type ('v, 'l) location =
+ (module Location.Interactive with type value = 'v and type location = 'l)
+ type ('v, 'l) structured_module =
+ (module Structured with type value = 'v and type location = 'l)
+ type ('v, 'l) structured =
+ ('v value, ('v, 'l) location, ('v, 'l) structured_module) or_unit
+
+ (* Recovers the value and location abstractions of a structured domain. *)
+ let get : type v l. (v, l) structured -> v value * (v, l) location = function
+ | Unit (value, location) -> (value, location)
+ | State (module S) -> ((module S.Value), (module S.Location))
+
+ (* During the complete abstraction build, we need to verify that there is at
+ least one domain in the computed abstraction.
+ TODO: better error handling. *)
+ let assert_not_unit = function
+ | Unit _ -> Self.fatal "The built domain cannot be unit."
+ | State structured -> structured
+
+
+ (* Internal type used for intermediate results of the add procedure. *)
+ type ('v, 'l) structured_domain =
+ (module Abstract.Domain.Internal with type value = 'v and type location = 'l)
+
+ (* Utility function used to create an identity converter. *)
+ module type Typ = sig type t end
+ let conversion_id (type t) (module T: Typ with type t = t) =
+ (module struct
+ type extended = T.t
+ type internal = T.t
+ let extend x = x
+ let restrict x = x
+ end: Domain_lift.Conversion with type extended = t and type internal = t)
+
+ (* Adding a registered domain into a structured one consists of performing a
+ lifting of the registered one if needed before performing the product,
+ configuring the name and restricting the domain depending of the mode. *)
+ type add_input = registered_with_mode
+ let add : type v l. add_input -> (v, l) structured -> (v, l) structured =
+ fun (registered, mode) structured ->
+ let wkey = Self.wkey_experimental in
+ let { experimental = exp ; name } = registered in
+ if exp then Self.warning ~wkey "The %s domain is experimental." name ;
+ let value, location = get structured in
+ let module Val = (val value) in
+ let module Loc = (val location) in
+ let lifted : (v, l) structured_domain =
+ match registered.abstraction with
+ | Functor (module Functor) ->
+ let locs = Location.outline Functor.location_dependencies in
+ let eq_loc = Location.dec_eq locs Loc.structure in
+ let module D = Functor.Make (Val) in
+ begin match eq_loc with
+ | Some Eq ->
+ (module struct
+ include D
+ let structure = Abstract.Domain.Leaf (D.key, (module D))
+ end)
+ | None ->
+ let module Val = (val conversion_id (module Val)) in
+ let module From = struct include D let structure = locs end in
+ let module Loc = Location.Converter (From) (Loc) in
+ (module Domain_lift.Make (D) (Val) (Loc))
+ end
+ | Domain (module D) ->
+ let loc_deps = Location.outline D.location_dependencies in
+ let val_deps = Value.outline D.value_dependencies in
+ let eq_loc = Location.dec_eq loc_deps Loc.structure in
+ let eq_val = Value.dec_eq val_deps Val.structure in
+ begin match eq_val, eq_loc with
+ | Some Eq, Some Eq ->
+ (module struct
+ include D
+ let structure = Abstract.Domain.Leaf (D.key, (module D))
+ end)
+ | Some Eq, None ->
+ let module Val = (val conversion_id (module Val)) in
+ let module From = struct include D let structure = loc_deps end in
+ let module Loc = Location.Converter (From) (Loc) in
+ (module Domain_lift.Make (D) (Val) (Loc))
+ | None, Some Eq ->
+ let module From = struct include D let structure = val_deps end in
+ let module Val = Value.Converter (From) (Val) in
+ let module LocTyp = struct type t = Loc.location end in
+ let module Loc = (val conversion_id (module LocTyp)) in
+ (module Domain_lift.Make (D) (Val) (Loc))
+ | _, _ ->
+ let module From = struct include D let structure = val_deps end in
+ let module Val = Value.Converter (From) (Val) in
+ let module From = struct include D let structure = loc_deps end in
+ let module Loc = Location.Converter (From) (Loc) in
+ (module Domain_lift.Make (D) (Val) (Loc))
+ end
in
- let add config (name, make) =
- let enabled = Parameters.Domains.mem name in
- try
- let mode = Parameters.DomainsFunction.find name in
- let mode = if enabled then add_main_mode mode else mode in
- add (make (), Some mode) config
- with Not_found ->
- if enabled then add (make (), None) config else config
+ (* Set the name of the domain. *)
+ let module Named = struct
+ include (val lifted)
+ module Store = struct
+ include Store
+ let register_global_state storage state =
+ let no_results = Parameters.NoResultsDomains.mem registered.name in
+ register_global_state (storage && not no_results) state
+ end
+ end in
+ (* Restricts the domain according to [mode]. *)
+ let restricted : (v, l) structured_domain =
+ match mode with
+ | None -> (module Named)
+ | Some kf_modes ->
+ let module Scope = struct let functions = kf_modes end in
+ (module Domain_builder.Restrict (Val) (Named) (Scope))
in
- let aux config (Flag domain as flag) =
- add config (domain.name, (fun () -> flag))
+ let combined : (v, l) structured_domain =
+ match structured with
+ | Unit _ -> restricted
+ | State (module Structured) ->
+ (* The new [domain] becomes the left leaf of the domain product, and
+ will be processed before the domains from [Acc.Dom] during the
+ analysis. *)
+ let module Dom = Structured.Domain in
+ (module Domain_product.Make (Val) (val restricted) (Dom))
+ in
+ State (module struct
+ type value = v
+ type location = l
+ module Value = Val
+ module Location = Loc
+ module Domain = (val combined)
+ end)
+
+
+ (* Build a complete abstraction based on a list of registered domains and a
+ value initial configuration. *)
+ let build domains : (module Structured) =
+ let values =
+ let add_value = Value.{ folder = add } in
+ let add_values values (registered, _) =
+ match registered.abstraction with
+ | Domain (module Domain) ->
+ Value.fold add_value Domain.value_dependencies values |>
+ Location.fold_values add_value Domain.location_dependencies
+ | Functor (module F) ->
+ Location.fold_values add_value F.location_dependencies values
+ in
+ List.fold_left add_values Value.init domains |>
+ Value.make_interactive
+ in
+ let module V = (val Value.assert_not_unit values) in
+ let locations =
+ let init : V.t Location.structured = Location.init (module V) in
+ let add = Location.{ folder = add } in
+ let add_locations locs (registered, _) =
+ match registered.abstraction with
+ | Domain (module D) -> Location.fold add D.location_dependencies locs
+ | Functor (module D) -> Location.fold add D.location_dependencies locs
+ in
+ List.fold_left add_locations init domains |>
+ Location.make_interactive
in
- let config = List.fold_left aux empty !abstractions in
- List.fold_left add config !dynamic_abstractions
-
- (* --- Register default abstractions -------------------------------------- *)
-
- let create_domain ?experimental priority name descr values domain =
- let abstraction = { values = Single values; domain = Domain domain } in
- register ~name ~descr ~priority ?experimental abstraction
-
- (* Register standard domains over cvalues. *)
- let make ?experimental rank name descr =
- create_domain ?experimental rank name descr (module Main_values.CVal)
-
- let cvalue =
- make 9 "cvalue"
- "Main analysis domain, enabled by default. Should not be disabled."
- (module Cvalue_domain.State)
-
- let symbolic_locations =
- make 7 "symbolic-locations"
- "Infers values of symbolic locations represented by imprecise lvalues, \
- such as t[i] or *p when the possible values of [i] or [p] are imprecise."
- (module Symbolic_locs.D)
-
- let equality =
- let descr = "Infers equalities between syntactic C expressions. \
- Makes the analysis less dependent on temporary variables and \
- intermediate computations."
- and abstraction =
- { values = Struct Abstract.Value.Unit;
- domain = Functor (module Equality_domain.Make); }
+ let module L = (val Location.assert_not_unit locations) in
+ let structured : (V.t, L.location) structured =
+ Unit ((module V), (module L))
in
- register ~name:"equality" ~descr ~priority:8 abstraction
-
- let gauges =
- make 6 "gauges"
- "Infers linear inequalities between the variables modified within a loop \
- and a special loop counter."
- (module Gauges_domain.D)
-
- let octagon =
- make 6 "octagon"
- "Infers relations between scalar variables of the form b ≤ ±X ± Y ≤ e, \
- where X, Y are program variables and b, e are constants."
- (module Octagons)
-
- let bitwise =
- create_domain 3 "bitwise"
- "Infers bitwise information to interpret more precisely bitwise operators."
- (module Offsm_value.Offsm) (module Offsm_domain.D)
-
- let sign =
- create_domain 4 "sign"
- "Infers the sign of program variables."
- (module Sign_value) (module Sign_domain)
-
- let inout = make 5 "inout" ~experimental:true
- "Infers the inputs and outputs of each function."
- (module Inout_domain.D)
-
- let traces =
- make 2 "traces" ~experimental:true
- "Builds an over-approximation of all the traces that lead \
- to a statement."
- (module Traces_domain.D)
-
- let printer =
- make 2 "printer"
- "Debug domain, only useful for developers. Prints the transfer functions \
- used during the analysis."
- (module Printer_domain)
-
- (* --- Default and legacy configurations ---------------------------------- *)
-
- let default = configure ()
- let legacy = singleton (cvalue, None)
+ let structured = List.fold_left (fun s d -> add d s) structured domains in
+ let module Structured : Structured = (val assert_not_unit structured) in
+ (module Structured)
end
-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
+(* --- Configuration -------------------------------------------------------- *)
-module Leaf_Location (Loc: Abstract_location.Leaf) = struct
- include Loc
- let structure = Abstract.Location.Leaf (Loc.key, (module Loc))
-end
+module Config = struct
+ module Mode = Datatype.Option (Domain_mode)
+
+ include Set.Make (struct
+ open Domain
+ type t = registered_with_mode
+ let compare (d1, m1) (d2, m2) =
+ let c = Datatype.Int.compare d1.priority d2.priority in
+ if c = 0 then
+ let c = Datatype.String.compare d1.name d2.name in
+ if c = 0 then Mode.compare m1 m2 else c
+ else c
+ end)
-module Leaf_Domain (D: Abstract_domain.Leaf) = struct
- include D
- let structure = Abstract.Domain.Leaf (D.key, (module D))
+ let configure () =
+ let find = Parameters.DomainsFunction.find in
+ let find name = try Some (find name) with Not_found -> None in
+ let main () = Globals.entry_point () |> fst in
+ let add_main_mode modes = (main (), Domain_mode.Mode.all) :: modes in
+ let dynamic (name, make) config =
+ let enabled = Parameters.Domains.mem name in
+ let enable modes = if enabled then add_main_mode modes else modes in
+ match find name with
+ | None -> if enabled then add (make (), None) config else config
+ | Some modes -> add (make (), Some (enable modes)) config
+ in
+ let static d = dynamic (d.Domain.name, fun () -> d) in
+ let fold f xs acc = List.fold_left (fun acc x -> f x acc) acc xs in
+ fold static !Domain.static_domains empty |>
+ fold dynamic !Domain.dynamic_domains
end
-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 Internal_Value = struct
- open Abstract.Value
- type value_key_module = V : 'v key * 'v data -> value_key_module
+(* --- Value reduced product ----------------------------------------------- *)
- 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)
+module type Value_with_reduction = sig
+ include Abstract.Value.External
+ val reduce : t -> t
+end
- let void_value () =
- Self.fatal
- "Cannot register a value module from a Void structure."
-
- let add_value_structure value internal =
- let rec aux: type v. (module Internal) -> v structure -> (module Internal) =
- fun value -> function
- | Option (s, _) -> aux value s
- | Leaf (key, v) -> add_value_leaf value (V (key, v))
- | Node (s1, s2) -> aux (aux value s1) s2
- | Unit -> value
- | Void -> void_value ()
- in
- aux value internal
+module Reducer = struct
+ type 'a key = 'a Value.key
+ type ('a, 'b) reducer = 'a -> 'b -> 'a * 'b
+ type action = Action : 'a key * 'b key * ('a, 'b) reducer -> action
- let build_values config initial_value =
- let build (Flag flag, _) acc =
- match flag.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)
- | Option (s, default) -> fun v -> set s (Option.value ~default:default v)
- | Unit -> fun () value -> value
- | Void -> void_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, _) -> Option.get (Value.get key)
- | Node (s1, s2) ->
- let get1 = get s1 and get2 = get s2 in
- fun v -> get1 v, get2 v
- | Option (s, _) -> fun v -> Some (get s v)
- | Unit -> fun _ -> ()
- | Void -> void_value ()
- in
- get structure
+ let actions = ref []
+
+ let register left right reducer =
+ actions := (Action (left, right, reducer)) :: !actions
- type extended_location = Main_locations.PLoc.location
+ module Make (Value : Abstract.Value.External) = struct
+ include Value
- let restrict_loc = fun x -> x
- let extend_loc = fun x -> x
+ let make_reduction acc (Action (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 = f (get1 v) (get2 v) in
+ let reducer v = let v1, v2 = reduce v in set1 v1 (set2 v2 v) in
+ reducer :: acc
+ | _, _ -> acc
+
+ let reduce =
+ let list = List.fold_left make_reduction [] !actions in
+ fun v -> List.fold_left (fun v reduce -> reduce v) v list
end
end
-(* --- 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) dname mode (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
- (* Set the name of the domain. *)
- let module Domain = struct
- include (val domain)
- module Store = struct
- include Store
- let register_global_state storage state =
- let no_results = Parameters.NoResultsDomains.mem dname in
- register_global_state (storage && not no_results) state
- end
- end in
- (* Restricts the domain according to [mode]. *)
- let domain : (module internal_domain with type value = Acc.Val.t) =
- match mode with
- | None -> (module Domain)
- | Some kf_modes ->
- let module Scope = struct let functions = kf_modes end in
- let module Domain =
- Domain_builder.Restrict
- (Acc.Val)
- (Domain)
- (Scope)
- in
- (module Domain)
- in
- 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
- (module struct
- module Val = Acc.Val
- module Loc = Acc.Loc
- module Dom = (val domain)
- end : Acc)
-
-let warn_experimental flag =
- if flag.experimental then
- Self.(warning ~wkey:wkey_experimental
- "The %s domain is experimental." flag.name)
-
-let build_domain config abstract =
- let build (Flag flag, mode) acc =
- warn_experimental flag;
- add_domain flag.name mode flag.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
-(* --- Value reduced product ----------------------------------------------- *)
-
-module type Value = sig
- include Abstract.Value.External
- val reduce : t -> t
-end
+(* --- Finalizing abstractions build ---------------------------------------- *)
module type S = sig
- module Val : Value
+ module Val : Value_with_reduction
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
+ module Dom : Abstract.Domain.External
+ with type value = Val.t and type location = Loc.location
end
-module type Eva = sig
+module type S_with_evaluation = 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 Eval : Evaluation_sig.S
+ with type state = Dom.t
+ and type value = Val.t
+ and type loc = Loc.location
+ and type origin = Dom.origin
end
-
-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
-
-let value_reduced_product = ref []
-
-let register_value_reduction reduced_product =
- value_reduced_product := (R reduced_product) :: !value_reduced_product
-
-(* 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
- | Some ival ->
- try
- let ival' = Cvalue.V.project_ival cvalue in
- if Ival.is_int ival'
- then
- let reduced_ival = Ival.narrow ival ival' in
- let cvalue = Cvalue.V.inject_ival reduced_ival in
- cvalue, Some reduced_ival
- else cvalue, Some 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
-
- 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
+module Hooks = struct
+ let hooks = ref []
+ type hook = (module S) -> (module S)
+ let register (f : hook) = hooks := f :: !hooks
+ let apply abst = List.fold_left (fun acc f -> f acc) abst !hooks
end
-(* --- Final hook ----------------------------------------------------------- *)
-
-let final_hooks = ref []
-
-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
-
-(* --- Building abstractions ------------------------------------------------ *)
-
-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 Open (Structured : Domain.Structured) : S = struct
+ module Val = Reducer.Make (Structured.Value)
+ module Loc = Structured.Location
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)
-
- let get_cvalue_or_bottom = function
- | `Bottom -> Cvalue.Model.bottom
- | `Value state -> get_cvalue_or_top state
+ include Structured.Domain
+ include Structure.Open (Abstract.Domain) (Structured.Domain)
end
end
-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 = 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
- let abstractions = (module Open (val abstractions): S) in
- apply_final_hooks abstractions
-
-module Default = (val make Config.default)
-module Legacy = (val make Config.legacy)
+ let abstractions = Config.elements config |> Domain.build in
+ let abstractions = (module Open (val abstractions) : S) in
+ Hooks.apply abstractions
diff --git a/src/plugins/eva/engine/abstractions.mli b/src/plugins/eva/engine/abstractions.mli
index be3c32e05155142ce18afb9f54512883ffc30a6e..395c1000004fd1daa3e1da233835ac06ded88787 100644
--- a/src/plugins/eva/engine/abstractions.mli
+++ b/src/plugins/eva/engine/abstractions.mli
@@ -20,162 +20,129 @@
(* *)
(**************************************************************************)
-(** 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, detailed in the {!Abstract_value} signature;
- - location abstractions, detailed in the {!Abstract_location} signature;
- - state abstractions, or abstract domains, detailed in {!Abstract_domain}.
-*)
-
-(** Module types of value abstractions: either a single leaf module, or
- a compound of several modules described by a structure. In this last case,
- the structure must not contain the Void constructor. *)
-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. *)
-type 'v abstraction =
- { values: 'v value; (** The value abstraction. *)
- domain: 'v domain ; (** The domain over the value abstraction. *)
- }
-
-(** Information about a registered abstraction. *)
-type 't with_info =
- { name: string; (** Name of the domain. Must be unique. *)
- experimental: bool; (** Is the domain experimental? *)
- priority: int; (** Domains with higher priority are processed first. *)
- abstraction: 't; (** The abstract value and the domain. *)
- }
-
-(** Flag for an abstract domain. A domain can be programmatically enabled via
- its flag. See module {!Config} for more details. *)
-type flag = Flag: 'v abstraction with_info -> flag
-
-(** Registers an abstract domain. Returns a flag for the given domain.
- - [name] must be unique. The domain is used if the -eva-domains option
- has been set to [name].
- - [descr] is a description printed in the help message of -eva-domains.
- - [experimental] is false by default. If set to true, a warning is emitted
- when the domain is enabled.
- - [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. The default priority is 0. *)
-val register:
- name:string -> descr:string -> ?experimental:bool -> ?priority:int ->
- 'v abstraction -> flag
-
-(** Register a dynamic abstraction: the abstraction is built by applying
- the last argument when starting an analysis, if the -eva-domains option
- has been set to [name]. See function {!register} for more details. *)
-val dynamic_register:
- name:string -> descr:string -> ?experimental:bool -> ?priority:int ->
- (unit -> 'v abstraction) -> unit
-
-(** 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
- val reduce : t -> t
-end
+(** {2 Registration of abstract domains.} *)
+
+module Domain : sig
+
+ (** Witness of the registration of an abstract domain, it can be used to
+ programmatically enable the domain. *)
+ type registered
+
+ (** Registers a leaf abstract domain.
+ - [name] must be unique. The domain is enabled by -eva-domains [name].
+ - [descr] is a description printed in the help message of -eva-domains.
+ - [experimental] is false by default. If set to true, a warning is emitted
+ when the domain is enabled.
+ - [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. The default priority is 0. *)
+ val register :
+ name:string -> descr:string -> ?experimental:bool -> ?priority:int ->
+ (module Abstract_domain.Leaf) -> registered
+
+ (** Registers a dynamic domain, which is built at the start of an analysis
+ analysis using the function given as last argument.
+ See function {!register} for more details. *)
+ val dynamic_register :
+ name:string -> descr:string -> ?experimental:bool -> ?priority:int ->
+ (unit -> (module Abstract_domain.Leaf)) -> unit
+
+ (** Functor domain which can be built over any value abstractions, but with
+ fixed locations dependencies. *)
+ module type Functor = sig
+ type location
+ val location_dependencies: location Abstract_location.dependencies
+ module Make (V : Abstract.Value.External) : sig
+ include Abstract_domain.S
+ with type value = V.t and type location = location
+ val key : state Abstract_domain.key
+ end
+ end
+
+ (** Registers a functor domain. See function {!register} for more details. *)
+ val register_functor:
+ name:string -> descr:string -> ?experimental:bool -> ?priority:int ->
+ (module Functor) -> registered
-(** 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
- and type location = Loc.location
end
-(** 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
- and type value = Val.t
- and type loc = Loc.location
- and type origin = Dom.origin
+
+(** {2 Reduced product between value abstractions.} *)
+
+(** Value reduced product registration. Registering a value reduced product
+ requires the keys of each value abstractions involved along with a reducer,
+ i.e. a function that perform the reduction. *)
+module Reducer : sig
+ type ('a, 'b) reducer = 'a -> 'b -> 'a * 'b
+ val register :
+ 'a Abstract_value.key -> 'b Abstract_value.key -> ('a, 'b) reducer -> unit
end
-(** 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
(** {2 Configuration of an analysis.} *)
(** Configuration defining the abstractions to be used in an analysis.
- A configuration is a set of flags, i.e. a set of abstract domains. Each flag
- comes with an optional mode. None is the default mode: the given domain is
+ A configuration is a set of registered abstract domains. Each domain comes
+ with an optional analysis mode. None is the default mode: the domain is
enabled for the whole analysis. See {!Domain_mode} for more details. *)
module Config : sig
- include Set.S with type elt = flag * Domain_mode.t option
-
- (** Returns true if the given flag is in the configuration. *)
- val mem: flag -> t -> bool
-
- (** Flags for the standard domains currently provided in Eva. *)
-
- val cvalue: flag
- val equality: flag
- val symbolic_locations: flag
- val gauges: flag
- val octagon: 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. *)
+ type t
+
+ (** Creates the configuration according to the analysis parameters. *)
+ val configure : unit -> t
+
+ (** Creates a custom configuration from a list of registered abstract domains,
+ associated with optional analysis modes. [None] is the default mode: the
+ domain is enabled for the whole analysis. See {!Domain_mode} for more
+ details. *)
+ val of_list : (Domain.registered * Domain_mode.t option) list -> t
+
+ (** Are two configurations identical? *)
+ val equal : t -> t -> bool
end
-(** Creates the configuration according to the analysis parameters. *)
-val configure: unit -> Config.t
+
+
+(** {2 Types and functions used in the engine.} *)
+
+(** The value abstractions signature used in the engine, with the reduction
+ function of the reduced product. *)
+module type Value_with_reduction = sig
+ include Abstract.Value.External
+ val reduce : t -> t
+end
+
+(** The three abstractions used in an Eva analysis. *)
+module type S = sig
+ module Val : Value_with_reduction
+ 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
+
+(* The three abstractions plus an evaluation engine for these abstractions. *)
+module type S_with_evaluation = sig
+ include S
+ module Eval : Evaluation_sig.S
+ with type state = Dom.t
+ and type value = Val.t
+ and type loc = Loc.location
+ and type origin = Dom.origin
+end
(** Builds the abstractions according to a configuration. *)
-val make: Config.t -> (module S)
+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
+
+(** {2 Analysis low level modifications.} *)
+
+(** Registration of a hook, i.e. a function that modifies directly the three
+ abstractions after their building by the engine and before the start of
+ each analysis. *)
+module Hooks : sig
+ type hook = (module S) -> (module S)
+ val register : hook -> unit
+end
diff --git a/src/plugins/eva/engine/analysis.ml b/src/plugins/eva/engine/analysis.ml
index a390c9398cfd06d88ea2a8f813466d6d78b4b143..a93c6903e27d182ab6bc564fa6a3b82ae951c8ad 100644
--- a/src/plugins/eva/engine/analysis.ml
+++ b/src/plugins/eva/engine/analysis.ml
@@ -25,8 +25,14 @@ open Eval
type computation_state = Self.computation_state =
| NotComputed | Computing | Computed | Aborted
-let current_computation_state = Self.current_computation_state
-let register_computation_hook = Self.register_computation_hook
+let current_computation_state = Self.ComputationState.get
+let register_computation_hook ?on f =
+ let f' = match on with
+ | None -> f
+ | Some s -> fun s' -> if s = s' then f s
+ in
+ Self.ComputationState.add_hook_on_change f'
+
let is_computed = Self.is_computed
let self = Self.state
let emitter = Eva_utils.emitter
@@ -55,13 +61,13 @@ module type Results = sig
val get_global_state: unit -> state or_top_bottom
val get_stmt_state : after:bool -> stmt -> state or_top_bottom
val get_stmt_state_by_callstack:
- ?selection:callstack list ->
- after:bool -> stmt -> state Value_types.Callstack.Hashtbl.t or_top_bottom
+ ?selection:Callstack.t list ->
+ after:bool -> stmt -> state Callstack.Hashtbl.t or_top_bottom
val get_initial_state:
kernel_function -> state or_top_bottom
val get_initial_state_by_callstack:
- ?selection:callstack list ->
- kernel_function -> state Value_types.Callstack.Hashtbl.t or_top_bottom
+ ?selection:Callstack.t list ->
+ kernel_function -> state Callstack.Hashtbl.t or_top_bottom
val eval_expr : state -> exp -> value evaluated
val copy_lvalue: state -> lval -> value flagged_value evaluated
@@ -72,7 +78,7 @@ module type Results = sig
end
module type S = sig
- include Abstractions.Eva
+ include Abstractions.S_with_evaluation
include Results with type state := Dom.state
and type value := Val.t
and type location := Loc.location
@@ -81,7 +87,7 @@ end
module type Analyzer = sig
include S
val compute_from_entry_point : kernel_function -> lib_entry:bool -> unit
- val compute_from_init_state: kernel_function -> Dom.t -> unit
+ (* val compute_from_init_state: kernel_function -> Dom.t -> unit *)
val initial_state: lib_entry:bool -> Dom.t or_bottom
end
@@ -90,7 +96,7 @@ module Make (Abstract: Abstractions.S) = struct
module Abstract = struct
include Abstract
- module Eval = Evaluation.Make (Abstract.Val) (Abstract.Loc) (Abstract.Dom)
+ module Eval = Evaluation.Make (Val) (Loc) (Dom)
end
include Abstract
@@ -149,20 +155,15 @@ module Make (Abstract: Abstractions.S) = struct
end
-module Legacy = Make (Abstractions.Legacy)
-module Default =
- (val
- (if Abstractions.Config.(equal default legacy)
- then (module Legacy)
- else (module Make (Abstractions.Default)))
- : Analyzer)
+let default = Abstractions.Config.of_list [Cvalue_domain.registered, None]
+module Default : Analyzer = Make (val Abstractions.make default)
+
(* Reference to the current configuration (built by Abstractions.configure from
the parameters of Eva regarding the abstractions used in the analysis) and
the current Analyzer module. *)
-let ref_analyzer =
- ref (Abstractions.Config.default, (module Default : Analyzer))
+let ref_analyzer = ref (default, (module Default : Analyzer))
(* Returns the current Analyzer module. *)
let current_analyzer () = (module (val (snd !ref_analyzer)): S)
@@ -182,15 +183,15 @@ let set_current_analyzer config (analyzer: (module Analyzer)) =
let cvalue_initial_state () =
let module A = (val snd !ref_analyzer) in
+ let module G = (Cvalue_domain.Getters (A.Dom)) in
let _, lib_entry = Globals.entry_point () in
- A.Dom.get_cvalue_or_bottom (A.initial_state ~lib_entry)
+ G.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 Abstractions.Config.(equal config legacy) then (module Legacy: Analyzer)
- else if Abstractions.Config.(equal config default) then (module Default)
+ if Abstractions.Config.(equal config default) then (module Default : Analyzer)
else
let module Abstract = (val Abstractions.make config) in
let module Analyzer = Make (Abstract) in
@@ -200,7 +201,7 @@ let make_analyzer config =
(* Builds the analyzer according to the parameters of Eva. *)
let reset_analyzer () =
- let config = Abstractions.configure () in
+ let config = Abstractions.Config.configure () in
(* If the configuration has not changed, do not reset the Analyzer but uses
the reference instead. *)
if not (Abstractions.Config.equal config (fst !ref_analyzer))
@@ -215,7 +216,7 @@ let force_compute () =
let kf, lib_entry = Globals.entry_point () in
reset_analyzer ();
(* The new analyzer can be accesed through hooks *)
- Self.set_computation_state Computing;
+ Self.ComputationState.set Computing;
let module Analyzer = (val snd !ref_analyzer) in
Analyzer.compute_from_entry_point ~lib_entry kf
diff --git a/src/plugins/eva/engine/analysis.mli b/src/plugins/eva/engine/analysis.mli
index 3cb30baf2214b8afd75d27e8ef5fed42b9d88798..8dd74f365d0902882070a351b18b404853d35eef 100644
--- a/src/plugins/eva/engine/analysis.mli
+++ b/src/plugins/eva/engine/analysis.mli
@@ -31,13 +31,13 @@ module type Results = sig
val get_global_state: unit -> state or_top_bottom
val get_stmt_state : after:bool -> stmt -> state or_top_bottom
val get_stmt_state_by_callstack:
- ?selection:callstack list ->
- after:bool -> stmt -> state Value_types.Callstack.Hashtbl.t or_top_bottom
+ ?selection:Callstack.t list ->
+ after:bool -> stmt -> state Callstack.Hashtbl.t or_top_bottom
val get_initial_state:
kernel_function -> state or_top_bottom
val get_initial_state_by_callstack:
- ?selection:callstack list ->
- kernel_function -> state Value_types.Callstack.Hashtbl.t or_top_bottom
+ ?selection:Callstack.t list ->
+ kernel_function -> state Callstack.Hashtbl.t or_top_bottom
val eval_expr : state -> exp -> value evaluated
val copy_lvalue: state -> lval -> value flagged_value evaluated
@@ -60,7 +60,7 @@ end
module type S = sig
- include Abstractions.Eva
+ include Abstractions.S_with_evaluation
include Results with type state := Dom.state
and type value := Val.t
and type location := Loc.location
diff --git a/src/plugins/eva/engine/compute_functions.ml b/src/plugins/eva/engine/compute_functions.ml
index 5e913a57d2c6738e82bcb20c861fa11a0cbc8177..9fda306efa9a0cafb74be4405962cf7d244a63ce 100644
--- a/src/plugins/eva/engine/compute_functions.ml
+++ b/src/plugins/eva/engine/compute_functions.ml
@@ -141,7 +141,7 @@ let register_signal_handler () =
let restore_sigint = register_handler Sys.sigint interrupt in
fun () -> restore_sigusr1 (); restore_sigint ()
-module Make (Abstract: Abstractions.Eva) = struct
+module Make (Abstract: Abstractions.S_with_evaluation) = struct
module PowersetDomain = Powerset.Make (Abstract.Dom)
@@ -154,6 +154,8 @@ module Make (Abstract: Abstractions.Eva) = struct
Iterator.Computer
(Abstract) (PowersetDomain) (Transfer) (Init) (Logic) (Spec)
+ include Cvalue_domain.Getters (Abstract.Dom)
+
let initial_state = Init.initial_state
let get_cval =
@@ -166,6 +168,14 @@ module Make (Abstract: Abstractions.Eva) = struct
| None -> fun _ -> assert false
| Some get -> fun location -> get location
+ let apply_call_hooks call state =
+ let cvalue_state = get_cvalue_or_top state in
+ Cvalue_callbacks.apply_call_hooks call.callstack call.kf cvalue_state
+
+ let apply_call_results_hooks call state =
+ let cvalue_state = get_cvalue_or_top state in
+ Cvalue_callbacks.apply_call_results_hooks call.callstack call.kf cvalue_state
+
(* ----- Mem Exec cache --------------------------------------------------- *)
module MemExec = Mem_exec.Make (Abstract.Val) (Abstract.Dom)
@@ -185,8 +195,7 @@ module Make (Abstract: Abstractions.Eva) = struct
in
call_result
| Some (states, i) ->
- let cvalue = Abstract.Dom.get_cvalue_or_top init_state in
- Cvalue_callbacks.apply_call_hooks call.callstack call.kf `Memexec cvalue;
+ apply_call_hooks call init_state `Reuse;
(* Evaluate the preconditions of kf, to update the statuses
at this call. *)
let spec = Annotations.funspec call.kf in
@@ -202,8 +211,7 @@ module Make (Abstract: Abstractions.Eva) = struct
Self.debug ~dkey
"calling Record_Value_New callbacks on saved previous result";
end;
- let reuse = Cvalue_callbacks.Reuse i in
- Cvalue_callbacks.apply_call_results_hooks call.callstack call.kf reuse;
+ apply_call_results_hooks call init_state (`Reuse i);
(* call can be cached since it was cached once *)
Transfer.{states; cacheable = Cacheable; builtin=false}
@@ -226,8 +234,12 @@ module Make (Abstract: Abstractions.Eva) = struct
let vi = Kernel_function.get_vi call.kf in
if Cil.is_in_libc vi.vattr then
Library_functions.warn_unsupported_spec vi.vorig_name;
- Spec.compute_using_specification ~warn:true kinstr call spec state,
- Eval.Cacheable
+ let states =
+ Spec.compute_using_specification ~warn:true kinstr call spec state
+ in
+ let cvalue_states = List.map (fun (_, s) -> get_cvalue_or_top s) states in
+ apply_call_results_hooks call state (`Spec cvalue_states);
+ states, Eval.Cacheable
(* Interprets a [call] at callsite [kinstr] in state [state], using its
specification or body according to [target]. If [-eva-show-progress] is
@@ -238,17 +250,16 @@ module Make (Abstract: Abstractions.Eva) = struct
if pp then
Self.feedback
"@[computing for function %a.@\nCalled from %a.@]"
- Value_types.Callstack.pretty_short call.callstack
+ Callstack.pretty_short call.callstack
Cil_datatype.Location.pretty (Cil_datatype.Kinstr.loc kinstr);
- let cvalue_state = Abstract.Dom.get_cvalue_or_top state in
let compute, kind =
match target with
- | `Def (fundec, save_results) ->
- compute_using_body fundec ~save_results, `Def
+ | `Body (fundec, save_results) ->
+ compute_using_body fundec ~save_results, `Body
| `Spec funspec ->
- compute_using_spec funspec, `Spec funspec
+ compute_using_spec funspec, `Spec
in
- Cvalue_callbacks.apply_call_hooks call.callstack call.kf kind cvalue_state;
+ apply_call_hooks call state kind;
let resulting_states, cacheable = compute kinstr call state in
if pp then
Self.feedback
@@ -282,6 +293,7 @@ module Make (Abstract: Abstractions.Eva) = struct
then
Self.feedback ~current:true "Call to builtin %s%s"
name (if kf_name = name then "" else " for function " ^ kf_name);
+ apply_call_hooks call state `Builtin;
(* Do not track garbled mixes created when interpreting the specification,
as the result of the cvalue builtin will overwrite them. *)
Locations.Location_Bytes.do_track_garbled_mix false;
@@ -290,18 +302,17 @@ module Make (Abstract: Abstractions.Eva) = struct
in
Locations.Location_Bytes.do_track_garbled_mix true;
let final_state = join_states states in
- let cvalue_state = Abstract.Dom.get_cvalue_or_top state in
match final_state with
| `Bottom ->
- let kind = `Spec spec in
- Cvalue_callbacks.apply_call_hooks call.callstack call.kf kind cvalue_state;
+ apply_call_results_hooks call state (`Builtin ([], None));
let cacheable = Eval.Cacheable in
Transfer.{states; cacheable; builtin=true}
| `Value final_state ->
let cvalue_call = get_cvalue_call call in
- let post = Abstract.Dom.get_cvalue_or_top final_state in
+ let post = get_cvalue_or_top final_state in
+ let pre = get_cvalue_or_top state in
let cvalue_states =
- Builtins.apply_builtin builtin cvalue_call ~pre:cvalue_state ~post
+ Builtins.apply_builtin builtin cvalue_call ~pre ~post
in
let insert cvalue_state =
Partition.Key.empty,
@@ -332,7 +343,7 @@ module Make (Abstract: Abstractions.Eva) = struct
match target with
| `Builtin builtin_info -> compute_builtin builtin_info kinstr call state
| `Spec _ as spec -> compute_using_spec_or_body spec kinstr call state
- | `Def _ as def ->
+ | `Body _ as def ->
let compute = compute_using_spec_or_body def in
if Parameters.MemExecAll.get ()
then compute_and_cache_call compute kinstr call state
@@ -342,25 +353,24 @@ module Make (Abstract: Abstractions.Eva) = struct
(* ----- Main call -------------------------------------------------------- *)
- let store_initial_state kf init_state =
- Abstract.Dom.Store.register_initial_state (Eva_utils.call_stack ()) init_state;
- let cvalue_state = Abstract.Dom.get_cvalue_or_top init_state in
- Db.Value.Call_Value_Callbacks.apply (cvalue_state, [kf, Kglobal])
+ let store_initial_state callstack kf init_state =
+ Abstract.Dom.Store.register_initial_state callstack kf init_state;
+ let cvalue_state = get_cvalue_or_top init_state in
+ Db.Value.Call_Value_Callbacks.apply (cvalue_state, callstack)
let compute kf init_state =
let restore_signals = register_signal_handler () in
let compute () =
- Eva_utils.push_call_stack kf Kglobal;
- store_initial_state kf init_state;
- let callstack = [kf, Kglobal] in
+ let callstack = Eva_utils.init_call_stack kf in
+ store_initial_state callstack kf init_state;
let call = { kf; callstack; arguments = []; rest = []; return = None; } in
let final_result = compute_call Kglobal call None init_state in
let final_states = List.map snd (final_result.Transfer.states) in
let final_state = PowersetDomain.(final_states |> of_list |> join) in
- Eva_utils.pop_call_stack ();
+ Eva_utils.clear_call_stack ();
Self.feedback "done for function %a" Kernel_function.pretty kf;
Abstract.Dom.Store.mark_as_computed ();
- Self.(set_computation_state Computed);
+ Self.(ComputationState.set Computed);
post_analysis ();
Abstract.Dom.post_analysis final_state;
Summary.print_summary ();
@@ -369,7 +379,7 @@ module Make (Abstract: Abstractions.Eva) = struct
in
let cleanup () =
Abstract.Dom.Store.mark_as_computed ();
- Self.(set_computation_state Aborted);
+ Self.(ComputationState.set Aborted);
post_analysis_cleanup ~aborted:true
in
Eva_utils.protect compute ~cleanup
@@ -387,7 +397,7 @@ module Make (Abstract: Abstractions.Eva) = struct
match initial_state with
| `Bottom ->
Abstract.Dom.Store.mark_as_computed ();
- Self.(set_computation_state Aborted);
+ Self.(ComputationState.set Aborted);
Self.result "Eva not started because globals \
initialization is not computable.";
Eval_annots.mark_invalid_initializers ()
diff --git a/src/plugins/eva/engine/compute_functions.mli b/src/plugins/eva/engine/compute_functions.mli
index 2eea8219cdbbf5e9a8a7c664e4640155da7d6919..28f78965dbb2d54008aabe51674bbf084a49f3d8 100644
--- a/src/plugins/eva/engine/compute_functions.mli
+++ b/src/plugins/eva/engine/compute_functions.mli
@@ -25,7 +25,7 @@
open Cil_types
open Eval
-module Make (Abstract: Abstractions.Eva)
+module Make (Abstract: Abstractions.S_with_evaluation)
: sig
(** Compute a call to the main function. *)
diff --git a/src/plugins/eva/engine/evaluation.ml b/src/plugins/eva/engine/evaluation.ml
index fa55a38798a0e020a7e632e9aa39de4bbd4712c3..7a58005d92be8f394687268b4a7f44a76084b3e7 100644
--- a/src/plugins/eva/engine/evaluation.ml
+++ b/src/plugins/eva/engine/evaluation.ml
@@ -183,36 +183,6 @@ let exp_alarm_signed_converted_downcast =
let signed_exp = Cil.new_exp ~loc:exp.eloc (CastE (signed_typ, exp)) in
signed_exp)
-module type S = sig
- type state
- type value
- type origin
- type loc
- module Valuation : Valuation with type value = value
- and type origin = origin
- and type loc = loc
- val to_domain_valuation:
- Valuation.t -> (value, loc, origin) Abstract_domain.valuation
- val evaluate :
- ?valuation:Valuation.t -> ?reduction:bool -> ?subdivnb:int ->
- state -> exp -> (Valuation.t * value) evaluated
- val copy_lvalue :
- ?valuation:Valuation.t -> ?subdivnb:int ->
- state -> lval -> (Valuation.t * value flagged_value) evaluated
- val lvaluate :
- ?valuation:Valuation.t -> ?subdivnb:int -> for_writing:bool ->
- state -> lval -> (Valuation.t * loc * typ) evaluated
- val reduce:
- ?valuation:Valuation.t -> state -> exp -> bool -> Valuation.t evaluated
- val assume:
- ?valuation:Valuation.t -> state -> exp -> value -> Valuation.t or_bottom
- val eval_function_exp:
- ?subdivnb:int -> exp -> ?args:exp list -> state ->
- (Kernel_function.t * Valuation.t) list evaluated
- val interpret_truth:
- alarm:(unit -> Alarms.t) -> 'a -> 'a Abstract_value.truth -> 'a evaluated
-end
-
let return t = `Value t, Alarmset.none
(* Intersects [alarms] with the only possible alarms from the dereference of
@@ -895,7 +865,7 @@ module Make
| AddrOf v | StartOf v ->
lval_to_loc context ~for_writing:false ~reduction:false v
>>= fun (loc, _, _) ->
- let value = Loc.to_value loc in
+ (Loc.to_value loc, Alarmset.none) >>= fun value ->
let v = assume_pointer expr value in
compute_reduction v false
@@ -1394,7 +1364,7 @@ module Make
| Mem expr, offset ->
match offset with
| NoOffset ->
- let loc_value = Loc.to_value location in
+ Loc.to_value location >>- fun loc_value ->
backward_eval fuel state expr (Some loc_value) >>-: fun _ -> ()
| _ ->
let reduce_valid_index = true in
@@ -1691,7 +1661,6 @@ module Make
| _ -> assert false
end
-
(*
Local Variables:
compile-command: "make -C ../../../.."
diff --git a/src/plugins/eva/engine/evaluation.mli b/src/plugins/eva/engine/evaluation.mli
index 6197f1d07fb23dae081e2cb38e226c17dbb3148e..ff7487ecf1bfdbf17609864a1cd00161b3329066 100644
--- a/src/plugins/eva/engine/evaluation.mli
+++ b/src/plugins/eva/engine/evaluation.mli
@@ -20,111 +20,6 @@
(* *)
(**************************************************************************)
-open Cil_types
-open Eval
-
-(** Generic evaluation and reduction of expressions and left values. *)
-
-module type S = sig
-
- (** State of abstract domain. *)
- type state
-
- (** Numeric values to which the expressions are evaluated. *)
- type value
-
- (** Origin of values. *)
- type origin
-
- (** Location of an lvalue. *)
- type loc
-
- (** Results of an evaluation: the results of all intermediate calculation (the
- value of each expression and the location of each lvalue) are cached here.
- See {!Eval} for more details. *)
- module Valuation : Valuation with type value = value
- and type origin = origin
- and type loc = loc
-
- (** Evaluation functions store the results of an evaluation into [Valuation.t]
- maps. Abstract domains read these results from [Abstract_domain.valuation]
- records. This function converts the former into the latter. *)
- val to_domain_valuation:
- Valuation.t -> (value, loc, origin) Abstract_domain.valuation
-
- (** [evaluate ~valuation state expr] evaluates the expression [expr] in the
- state [state], and returns the pair [result, alarms], where:
- - [alarms] are the set of alarms ensuring the soundness of the evaluation;
- - [result] is either `Bottom if the evaluation leads to an error,
- 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.
-
- Optional arguments are:
- - [valuation] is a cache of already computed expressions; empty by default.
- - [reduction] allows the deactivation of the backward reduction performed
- after the forward evaluation; true by default.
- - [subdivnb] is the maximum number of subdivisions performed on non-linear
- sub-expressions of [expr]. If a lvalue occurs several times in [expr],
- its value can be split up to [subdivnb] times to gain more precision.
- Set to the value of the option -eva-subdivide-non-linear by default. *)
- val evaluate :
- ?valuation:Valuation.t -> ?reduction:bool -> ?subdivnb:int ->
- state -> exp -> (Valuation.t * value) evaluated
-
- (** Computes the value of a lvalue, with possible indeterminateness: the
- returned value may be uninitialized, or contain escaping addresses.
- Also returns the alarms resulting of the evaluation of the lvalue location,
- and a valuation containing all the intermediate results of the evaluation.
- The [valuation] argument is a cache of already computed expressions.
- It is empty by default.
- [subdivnb] is the maximum number of subdivisions performed on non-linear
- expressions. *)
- val copy_lvalue :
- ?valuation:Valuation.t -> ?subdivnb:int ->
- state -> lval -> (Valuation.t * value flagged_value) evaluated
-
- (** [lvaluate ~valuation ~for_writing state lval] evaluates the left value
- [lval] in the state [state]. Same general behavior as [evaluate] above
- but evaluates the lvalue into a location and its type.
- The boolean [for_writing] indicates whether the lvalue is evaluated to be
- read or written. It is useful for the emission of the alarms, and for the
- reduction of the location.
- [subdivnb] is the maximum number of subdivisions performed on non-linear
- expressions (including the possible pointer and offset of the lvalue). *)
- val lvaluate :
- ?valuation:Valuation.t -> ?subdivnb:int -> for_writing:bool ->
- state -> lval -> (Valuation.t * loc * typ) evaluated
-
- (** [reduce ~valuation state expr positive] evaluates the expression [expr]
- in the state [state], and then reduces the [valuation] such that
- the expression [expr] evaluates to a zero or a non-zero value, according
- to [positive]. By default, the empty valuation is used. *)
- val reduce:
- ?valuation:Valuation.t ->
- state -> exp -> bool -> Valuation.t evaluated
-
- (** [assume ~valuation state expr value] assumes in the [valuation] that
- the expression [expr] has the value [value] in the state [state],
- and backward propagates this information to the subterm of [expr].
- If [expr] has not been already evaluated in the [valuation], its forward
- evaluation takes place first, but the alarms are dismissed. By default,
- the empty valuation is used.
- The function returns the updated valuation, or bottom if it discovers
- a contradiction. *)
- val assume:
- ?valuation:Valuation.t ->
- state -> exp -> value -> Valuation.t or_bottom
-
- val eval_function_exp:
- ?subdivnb:int -> exp -> ?args:exp list -> state ->
- (Kernel_function.t * Valuation.t) list evaluated
- (** Evaluation of the function argument of a [Call] constructor *)
-
- val interpret_truth:
- alarm:(unit -> Alarms.t) -> 'a -> 'a Abstract_value.truth -> 'a evaluated
-end
-
module type Value = sig
include Abstract.Value.External
@@ -146,11 +41,10 @@ module Make
(Loc : Abstract_location.S with type value = Value.t)
(Domain : Queries with type value = Value.t
and type location = Loc.location)
- : S with type state = Domain.state
- and type value = Value.t
- and type origin = Domain.origin
- and type loc = Loc.location
-
+ : Evaluation_sig.S with type state = Domain.state
+ and type value = Value.t
+ and type origin = Domain.origin
+ and type loc = Loc.location
(*
Local Variables:
diff --git a/src/plugins/eva/engine/evaluation_sig.ml b/src/plugins/eva/engine/evaluation_sig.ml
new file mode 100644
index 0000000000000000000000000000000000000000..75673541afa231aa24ae910d904560b2e69cafd4
--- /dev/null
+++ b/src/plugins/eva/engine/evaluation_sig.ml
@@ -0,0 +1,126 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2023 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+open Cil_types
+open Eval
+
+(** Generic evaluation and reduction of expressions and left values. *)
+
+module type S = sig
+
+ (** State of abstract domain. *)
+ type state
+
+ (** Numeric values to which the expressions are evaluated. *)
+ type value
+
+ (** Origin of values. *)
+ type origin
+
+ (** Location of an lvalue. *)
+ type loc
+
+ (** Results of an evaluation: the results of all intermediate calculation (the
+ value of each expression and the location of each lvalue) are cached here.
+ See {!Eval} for more details. *)
+ module Valuation : Valuation with type value = value
+ and type origin = origin
+ and type loc = loc
+
+ (** Evaluation functions store the results of an evaluation into [Valuation.t]
+ maps. Abstract domains read these results from [Abstract_domain.valuation]
+ records. This function converts the former into the latter. *)
+ val to_domain_valuation:
+ Valuation.t -> (value, loc, origin) Abstract_domain.valuation
+
+ (** [evaluate ~valuation state expr] evaluates the expression [expr] in the
+ state [state], and returns the pair [result, alarms], where:
+ - [alarms] are the set of alarms ensuring the soundness of the evaluation;
+ - [result] is either `Bottom if the evaluation leads to an error,
+ 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.
+
+ Optional arguments are:
+ - [valuation] is a cache of already computed expressions; empty by default.
+ - [reduction] allows the deactivation of the backward reduction performed
+ after the forward evaluation; true by default.
+ - [subdivnb] is the maximum number of subdivisions performed on non-linear
+ sub-expressions of [expr]. If a lvalue occurs several times in [expr],
+ its value can be split up to [subdivnb] times to gain more precision.
+ Set to the value of the option -eva-subdivide-non-linear by default. *)
+ val evaluate :
+ ?valuation:Valuation.t -> ?reduction:bool -> ?subdivnb:int ->
+ state -> exp -> (Valuation.t * value) evaluated
+
+ (** Computes the value of a lvalue, with possible indeterminateness: the
+ returned value may be uninitialized, or contain escaping addresses.
+ Also returns the alarms resulting of the evaluation of the lvalue location,
+ and a valuation containing all the intermediate results of the evaluation.
+ The [valuation] argument is a cache of already computed expressions.
+ It is empty by default.
+ [subdivnb] is the maximum number of subdivisions performed on non-linear
+ expressions. *)
+ val copy_lvalue :
+ ?valuation:Valuation.t -> ?subdivnb:int ->
+ state -> lval -> (Valuation.t * value flagged_value) evaluated
+
+ (** [lvaluate ~valuation ~for_writing state lval] evaluates the left value
+ [lval] in the state [state]. Same general behavior as [evaluate] above
+ but evaluates the lvalue into a location and its type.
+ The boolean [for_writing] indicates whether the lvalue is evaluated to be
+ read or written. It is useful for the emission of the alarms, and for the
+ reduction of the location.
+ [subdivnb] is the maximum number of subdivisions performed on non-linear
+ expressions (including the possible pointer and offset of the lvalue). *)
+ val lvaluate :
+ ?valuation:Valuation.t -> ?subdivnb:int -> for_writing:bool ->
+ state -> lval -> (Valuation.t * loc * typ) evaluated
+
+ (** [reduce ~valuation state expr positive] evaluates the expression [expr]
+ in the state [state], and then reduces the [valuation] such that
+ the expression [expr] evaluates to a zero or a non-zero value, according
+ to [positive]. By default, the empty valuation is used. *)
+ val reduce:
+ ?valuation:Valuation.t ->
+ state -> exp -> bool -> Valuation.t evaluated
+
+ (** [assume ~valuation state expr value] assumes in the [valuation] that
+ the expression [expr] has the value [value] in the state [state],
+ and backward propagates this information to the subterm of [expr].
+ If [expr] has not been already evaluated in the [valuation], its forward
+ evaluation takes place first, but the alarms are dismissed. By default,
+ the empty valuation is used.
+ The function returns the updated valuation, or bottom if it discovers
+ a contradiction. *)
+ val assume:
+ ?valuation:Valuation.t ->
+ state -> exp -> value -> Valuation.t or_bottom
+
+ val eval_function_exp:
+ ?subdivnb:int -> exp -> ?args:exp list -> state ->
+ (Kernel_function.t * Valuation.t) list evaluated
+ (** Evaluation of the function argument of a [Call] constructor *)
+
+ val interpret_truth:
+ alarm:(unit -> Alarms.t) -> 'a -> 'a Abstract_value.truth -> 'a evaluated
+end
diff --git a/src/plugins/eva/engine/function_calls.ml b/src/plugins/eva/engine/function_calls.ml
index 9e641c47631d8bb00a3a77537d174723b84387de..9a0a589a1e372b5742c068f56c21ed2d6c7402ae 100644
--- a/src/plugins/eva/engine/function_calls.ml
+++ b/src/plugins/eva/engine/function_calls.ml
@@ -49,12 +49,14 @@ module Callers = Kernel_function.Map.Make (StmtSet)
module CallersTable = Kernel_function.Make_Table (Callers) (val info "Callers")
let register_call kinstr kf =
- match kinstr, Eva_utils.call_stack () with
+ let callstack = Eva_utils.current_call_stack () in
+ let kf', kinstr' = Callstack.top_call callstack in
+ assert (Kernel_function.equal kf kf');
+ assert (Cil_datatype.Kinstr.equal kinstr kinstr');
+ match kinstr, Callstack.top_caller callstack with
| Kglobal, _ -> CallersTable.add kf Kernel_function.Map.empty
- | Kstmt _, ([] | [_]) -> assert false
- | Kstmt stmt, (kf', kinstr') :: (caller, _) :: _ ->
- assert (Kernel_function.equal kf kf');
- assert (Cil_datatype.Kinstr.equal kinstr kinstr');
+ | Kstmt _, None -> assert false
+ | Kstmt stmt, Some caller ->
let callsite = StmtSet.singleton stmt in
let change calls =
let prev_stmts = Kernel_function.Map.find_opt caller calls in
@@ -91,7 +93,7 @@ let nb_callsites () =
type analysis_target =
[ `Builtin of string * Builtins.builtin * cacheable * funspec
| `Spec of Cil_types.funspec
- | `Def of Cil_types.fundec * bool ]
+ | `Body of Cil_types.fundec * bool ]
type results = Complete | Partial | NoResults
type analysis_status =
@@ -136,7 +138,7 @@ let register_status kf kind =
match kind with
| `Builtin (name, _, _, _) -> Builtin name
| `Spec _ -> SpecUsed
- | `Def (_, results) -> Analyzed (if results then Complete else NoResults)
+ | `Body (_, results) -> Analyzed (if results then Complete else NoResults)
in
let change prev_status = merge_status prev_status status in
ignore (StatusTable.memo ~change (fun _ -> status) kf)
@@ -167,7 +169,7 @@ let analysis_target ~recursion_depth callsite kf =
| Definition (def, _) ->
if Kernel_function.Set.mem kf (Parameters.UsePrototype.get ())
then `Spec (Annotations.funspec kf)
- else `Def (def, save_results def)
+ else `Body (def, save_results def)
let define_analysis_target ?(recursion_depth = -1) callsite kf =
let kind = analysis_target callsite kf ~recursion_depth in
diff --git a/src/plugins/eva/engine/function_calls.mli b/src/plugins/eva/engine/function_calls.mli
index 58b10813a22cbce7b106f8308511f8e97612145a..eaa080700d26f2b22da62524a7816d950d1647a3 100644
--- a/src/plugins/eva/engine/function_calls.mli
+++ b/src/plugins/eva/engine/function_calls.mli
@@ -37,7 +37,7 @@ val partial_results: unit -> bool
type analysis_target =
[ `Builtin of string * Builtins.builtin * Eval.cacheable * funspec
| `Spec of Cil_types.funspec
- | `Def of Cil_types.fundec * bool ]
+ | `Body of Cil_types.fundec * bool ]
(** Define the analysis target of a function according to Eva parameters.
Also registers the call in tables for the functions below. *)
diff --git a/src/plugins/eva/engine/initialization.ml b/src/plugins/eva/engine/initialization.ml
index 7cccb65020e25018c7191d12951acd08ca77ffc8..ed47b68bad299b793f3b1cfc6e84dcb5d3652d8a 100644
--- a/src/plugins/eva/engine/initialization.ml
+++ b/src/plugins/eva/engine/initialization.ml
@@ -82,8 +82,8 @@ let counter = ref 0
module Make
(Domain: Abstract.Domain.External)
- (Eva: Evaluation.S with type state = Domain.state
- and type loc = Domain.location)
+ (Eva: Evaluation_sig.S with type state = Domain.state
+ and type loc = Domain.location)
(Transfer: Transfer_stmt.S with type state = Domain.t)
= struct
@@ -95,6 +95,7 @@ module Make
fst (Eva.lvaluate ~for_writing:false Domain.top lval)
>>> fun (_valuation, loc, _typ) -> loc
+ include Cvalue_domain.Getters (Domain)
(* ------------------------- Apply initializer ---------------------------- *)
@@ -272,7 +273,7 @@ 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 with
+ match get_cvalue with
| None -> Self.abort "Function Db.Value.fun_set_args cannot be \
used without the Cvalue domain"
| Some get_cvalue ->
@@ -308,14 +309,18 @@ module Make
let initialize_global_variable ~lib_entry vi init state =
Cil.CurrentLoc.set vi.vdecl;
let state = Domain.enter_scope Abstract_domain.Global [vi] state in
- if vi.vsource then
- let initialize =
- if lib_entry || (vi.vstorage = Extern)
- then initialize_var_lib_entry
- else initialize_var_not_lib_entry ~local:false
- in
- initialize Kglobal vi init.init state
- else state
+ let state = if vi.vsource then
+ let initialize =
+ if lib_entry || (vi.vstorage = Extern)
+ then initialize_var_lib_entry
+ else initialize_var_not_lib_entry ~local:false
+ in
+ initialize Kglobal vi init.init state
+ else state
+ in
+ state
+
+
(* Compute the initial state with all global variable initialized. *)
let compute_global_state ~lib_entry () =
@@ -366,7 +371,7 @@ module Make
else global_state ~lib_entry
let print_initial_cvalue_state state =
- let cvalue_state = Domain.get_cvalue_or_bottom state in
+ let cvalue_state = 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/eva/engine/initialization.mli b/src/plugins/eva/engine/initialization.mli
index 9012946abe082baf204f551152efae99468bb9da..872206abe61796ac482a107efdd3d344668ca87b 100644
--- a/src/plugins/eva/engine/initialization.mli
+++ b/src/plugins/eva/engine/initialization.mli
@@ -45,8 +45,8 @@ end
module Make
(Domain: Abstract.Domain.External)
- (Eva: Evaluation.S with type state = Domain.state
- and type loc = Domain.location)
+ (Eva: Evaluation_sig.S with type state = Domain.state
+ and type loc = Domain.location)
(Transfer: Transfer_stmt.S with type state = Domain.t)
: S with type state := Domain.t
diff --git a/src/plugins/eva/engine/iterator.ml b/src/plugins/eva/engine/iterator.ml
index 2a0c7af021ac216b6eae8cea7f8315e3604f3ece..e97c859d276e889eadf25f1374727816f36479fa 100644
--- a/src/plugins/eva/engine/iterator.ml
+++ b/src/plugins/eva/engine/iterator.ml
@@ -45,7 +45,7 @@ let blocks_share_locals b1 b2 =
| _, _ -> false
module Make_Dataflow
- (Abstract : Abstractions.Eva)
+ (Abstract : Abstractions.S_with_evaluation)
(States : Powerset.S with type state = Abstract.Dom.t)
(Transfer : Transfer_stmt.S with type state = Abstract.Dom.t)
(Init: Initialization.S with type state := Abstract.Dom.t)
@@ -63,6 +63,7 @@ module Make_Dataflow
= struct
module Domain = Abstract.Dom
+ include Cvalue_domain.Getters (Domain)
(* --- Analysis parameters --- *)
@@ -121,12 +122,6 @@ module Make_Dataflow
let active_behaviors = Logic.create AnalysisParam.initial_state kf
- (* Compute the locals that we must enter in scope when we start the analysis
- of [block]. The other ones will be introduced on the fly, when we
- encounter a [Local_init] instruction. *)
- let block_toplevel_locals block =
- List.filter (fun vi -> not vi.vdefined) block.blocals
-
let initial_states =
let state = AnalysisParam.initial_state
and call_kinstr = AnalysisParam.call_kinstr
@@ -266,8 +261,15 @@ module Make_Dataflow
: transfer_function =
lift' (fun s -> Transfer.assign s (Kstmt stmt) dest exp)
+ (* All variables local to a block are introduced in domain states when
+ entering the block. Variables explicitly initialized at declaration time
+ (for which vi.vdefined is true) enter the scope too early, as they should
+ be introduced on the fly when encountering their [Local_init] instruction.
+ However, goto statements can skip their declaration/initialization, so it
+ is safer to always introduce all local variables (without initialize them)
+ when entering a block. *)
let transfer_enter (block : block) : transfer_function =
- let vars = block_toplevel_locals block in
+ let vars = block.blocals in
if vars = [] then id else lift (Transfer.enter_scope kf vars)
let transfer_leave (block : block) : transfer_function =
@@ -288,20 +290,12 @@ module Make_Dataflow
let transfer_instr (stmt : stmt) (instr : instr) : transfer_function =
match instr with
| Local_init (vi, AssignInit exp, _loc) ->
- let kind = Abstract_domain.Local kf in
let transfer state =
- let state = Domain.enter_scope kind [vi] state in
Init.initialize_local_variable stmt vi exp state
in
lift' transfer
| Local_init (vi, ConsInit (f, args, k), loc) ->
- let kind = Abstract_domain.Local kf in
let as_func dest callee args _loc (key, state) =
- (* This variable enters the scope too early, as it should
- be introduced after the call to [f] but before the assignment
- to [v]. This is currently not possible, at least without
- splitting Transfer.call in two. *)
- let state = Domain.enter_scope kind [vi] state in
transfer_call stmt dest callee args (key, state)
in
Cil.treat_constructor_as_func as_func vi f args k loc
@@ -441,7 +435,7 @@ module Make_Dataflow
edge_info.fireable <- true;
flow
- let gather_cvalues states = match Domain.get_cvalue with
+ let gather_cvalues states = match get_cvalue with
| Some get -> List.map get states
| None -> []
@@ -449,7 +443,7 @@ module Make_Dataflow
(* TODO: apply on all domains. *)
let states = Partitioning.contents f in
let cvalue_states = gather_cvalues states in
- let callstack = Eva_utils.call_stack () in
+ let callstack = Eva_utils.current_call_stack () in
Cvalue_callbacks.apply_statement_hooks callstack stmt cvalue_states
let update_vertex ?(widening : bool = false) (v : vertex)
@@ -681,7 +675,7 @@ module Make_Dataflow
then VertexTable.memo merged_states v get_smashed_store
else `Bottom
and lift_to_cvalues table =
- StmtTable.map (fun _ s -> Domain.get_cvalue_or_top s) (Lazy.force table)
+ StmtTable.map (fun _ s -> 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)
@@ -696,12 +690,12 @@ module Make_Dataflow
(StmtTable.map (fun _stmt (v,_) ->
let store = get_vertex_store v in
let states = Partitioning.expanded store in
- List.map (fun (_k,x) -> Domain.get_cvalue_or_top x) states)
+ List.map (fun (_k,x) -> get_cvalue_or_top x) states)
automaton.stmt_table)
in
let merged_pre_cvalues = lazy (lift_to_cvalues merged_pre_states)
and merged_post_cvalues = lazy (lift_to_cvalues merged_post_states) in
- let callstack = Eva_utils.call_stack () in
+ let callstack = Eva_utils.current_call_stack () in
if save_results then begin
let register_pre = Domain.Store.register_state_before_stmt callstack
and register_post = Domain.Store.register_state_after_stmt callstack in
@@ -729,8 +723,9 @@ module Make_Dataflow
Cvalue_callbacks.{ before_stmts = merged_pre_cvalues;
after_stmts = merged_post_cvalues }
in
- let results = Cvalue_callbacks.Store (states, Mem_exec.new_counter ()) in
- Cvalue_callbacks.apply_call_results_hooks callstack kf results;
+ let cvalue_init = get_cvalue_or_top initial_state in
+ let results = `Body (states, Mem_exec.new_counter ()) in
+ Cvalue_callbacks.apply_call_results_hooks callstack kf cvalue_init results;
if not (Db.Value.Record_Value_After_Callbacks.is_empty ())
then begin
if Parameters.ValShowProgress.get () then
@@ -744,7 +739,7 @@ end
module Computer
- (Abstract : Abstractions.Eva)
+ (Abstract : Abstractions.S_with_evaluation)
(States : Powerset.S with type state = Abstract.Dom.t)
(Transfer : Transfer_stmt.S with type state = Abstract.Dom.t)
(Init: Initialization.S with type state := Abstract.Dom.t)
diff --git a/src/plugins/eva/engine/iterator.mli b/src/plugins/eva/engine/iterator.mli
index 1c70fd4b0e17a75e7454e721b731edd3b606a829..0d1f9944063057b116f95a53af45b2766169cd64 100644
--- a/src/plugins/eva/engine/iterator.mli
+++ b/src/plugins/eva/engine/iterator.mli
@@ -27,7 +27,7 @@ val signal_abort: unit -> unit
module Computer
(* Abstractions with the evaluator. *)
- (Abstract: Abstractions.Eva)
+ (Abstract: Abstractions.S_with_evaluation)
(* Set of states of abstract domain. *)
(States : Powerset.S with type state = Abstract.Dom.t)
(* Transfer functions for statement on the abstract domain. *)
diff --git a/src/plugins/eva/engine/recursion.ml b/src/plugins/eva/engine/recursion.ml
index 30d7fb29e4c0284fe6429a221de6d49f68dd1760..b2fb66139b2ce3db51094c6f76ebd585d7d11ac3 100644
--- a/src/plugins/eva/engine/recursion.ml
+++ b/src/plugins/eva/engine/recursion.ml
@@ -192,8 +192,9 @@ let make_recursion call depth =
{ depth; substitution; base_substitution; withdrawal; base_withdrawal; }
let make call =
- let is_same_kf (f, _) = Kernel_function.equal f call.kf in
- let previous_calls = List.filter is_same_kf call.callstack in
+ let is_same_kf = Kernel_function.equal call.kf in
+ let all_calls = Callstack.to_kf_list call.callstack in
+ let previous_calls = List.filter is_same_kf all_calls in
let depth = List.length previous_calls - 1 in
if depth > 0
then Some (make_recursion call depth)
diff --git a/src/plugins/eva/engine/subdivided_evaluation.ml b/src/plugins/eva/engine/subdivided_evaluation.ml
index 5e0ea2abac87900a9cc23b77e0e8cf90000a6bcd..60949a0ef0a7ade04b1e9f198791293a5ef1029c 100644
--- a/src/plugins/eva/engine/subdivided_evaluation.ml
+++ b/src/plugins/eva/engine/subdivided_evaluation.ml
@@ -856,8 +856,8 @@ module Make
| Lval (host, off as lval) ->
if Cil.typeHasQualifier "volatile" (Cil.typeOfLval lval) then `Value acc
else
- let loc = find_loc valuation lval in
- if Cvalue.V.cardinal_zero_or_one (get_cval (Loc.to_value loc))
+ Loc.to_value (find_loc valuation lval) >>- fun value ->
+ if Cvalue.V.cardinal_zero_or_one (get_cval value)
then
(* no variable in the host or in the offset can be influential. Check
the contents of the location, on which we might want to enumerate*)
diff --git a/src/plugins/eva/engine/transfer_specification.ml b/src/plugins/eva/engine/transfer_specification.ml
index 0821c12b0356dc91faf181ece6239c65c245c2d8..ebde0b8888044622355b7b71954dc3915149f5b7 100644
--- a/src/plugins/eva/engine/transfer_specification.ml
+++ b/src/plugins/eva/engine/transfer_specification.ml
@@ -179,6 +179,7 @@ module Make
module Domain = Abstract.Dom
module Location = Abstract.Loc
+ include Cvalue_domain.Getters (Domain)
(* Most transfer functions about logic return a set of states instead of a
single state, and States.empty instead of bottom. We thus use this monad
@@ -239,7 +240,7 @@ module Make
let set_location loc = set_ploc (Main_locations.PLoc.make loc)
let make_env state =
- Eval_terms.env_assigns ~pre:(Domain.get_cvalue_or_top state)
+ Eval_terms.env_assigns ~pre:(get_cvalue_or_top state)
(* Evaluates the location affected by an assigns, allocates, frees or \from
clause. Returns None if the clause cannot be interpreted. *)
@@ -322,7 +323,7 @@ module Make
end
in
let check_one_state state =
- let cvalue_state = Domain.get_cvalue_or_top state in
+ let cvalue_state = get_cvalue_or_top state in
List.iter (check_one_assign cvalue_state) assigns
in
States.iter check_one_state states
diff --git a/src/plugins/eva/engine/transfer_stmt.ml b/src/plugins/eva/engine/transfer_stmt.ml
index 71042b2b2e41baab8d8f7d0c49e811f686231910..75e3571534fd65d3b671950aa9250ccfcb87ed59 100644
--- a/src/plugins/eva/engine/transfer_stmt.ml
+++ b/src/plugins/eva/engine/transfer_stmt.ml
@@ -114,12 +114,13 @@ let substitution_visitor table = object
| Some vi -> Cil.ChangeTo vi
end
-module Make (Abstract: Abstractions.Eva) = struct
+module Make (Abstract: Abstractions.S_with_evaluation) = struct
module Value = Abstract.Val
module Location = Abstract.Loc
module Domain = Abstract.Dom
module Eval = Abstract.Eval
+ include Cvalue_domain.Getters (Domain)
type state = Domain.t
type value = Value.t
@@ -312,7 +313,7 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Returns the result of a call, and a boolean that indicates whether a
builtin has been used to interpret the call. *)
let process_call stmt call recursion valuation state =
- Eva_utils.push_call_stack call.kf (Kstmt stmt);
+ Eva_utils.push_call_stack call.kf stmt;
let cleanup () =
Eva_utils.pop_call_stack ();
(* Changed by compute_call_ref, called from process_call *)
@@ -324,7 +325,8 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Process the call according to the domain decision. *)
match Domain.start_call stmt call recursion domain_valuation state with
| `Value state ->
- Domain.Store.register_initial_state (Eva_utils.call_stack ()) state;
+ let callstack = Eva_utils.current_call_stack () in
+ Domain.Store.register_initial_state callstack call.kf state;
!compute_call_ref stmt call recursion state
| `Bottom ->
{ states = []; cacheable = Cacheable; builtin=false }
@@ -533,7 +535,7 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Create an Eval.call *)
let create_call stmt kf args =
let return = Library_functions.get_retres_vi kf in
- let callstack = (kf, Kstmt stmt) :: Eva_utils.call_stack () in
+ let callstack = Callstack.push kf stmt (Eva_utils.current_call_stack ()) in
let arguments, rest =
let formals = Kernel_function.get_formals kf in
let rec format_arguments acc args formals = match args, formals with
@@ -633,7 +635,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, Location.get Main_locations.PLoc.key with
+ match 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 ->
@@ -727,12 +729,14 @@ module Make (Abstract: Abstractions.Eva) = struct
(* Legacy callbacks for the cvalue domain, usually called by
{Cvalue_transfer.start_call}. *)
- let apply_cvalue_callback kf ki_call state =
- let stack_with_call = (kf, ki_call) :: Eva_utils.call_stack () in
- let cvalue_state = Domain.get_cvalue_or_top state in
+ let apply_cvalue_callback kf stmt state =
+ let call_stack = Eva_utils.current_call_stack () in
+ let stack_with_call = Callstack.push kf stmt call_stack in
+ let cvalue_state = get_cvalue_or_top state in
Db.Value.Call_Value_Callbacks.apply (cvalue_state, stack_with_call);
- let kind = `Builtin None in
- Cvalue_callbacks.apply_call_hooks stack_with_call kf kind cvalue_state
+ Cvalue_callbacks.apply_call_hooks stack_with_call kf cvalue_state `Builtin;
+ Cvalue_callbacks.apply_call_results_hooks stack_with_call kf cvalue_state
+ (`Builtin ([cvalue_state], None))
(* --------------------- Process the call statement ---------------------- *)
@@ -751,7 +755,7 @@ module Make (Abstract: Abstractions.Eva) = struct
(* The special Frama_C_ functions to print states are handled here. *)
if apply_special_directives ~subdivnb kf args state
then
- let () = apply_cvalue_callback kf ki_call state in
+ let () = apply_cvalue_callback kf stmt state in
[(Partition.Key.empty, state)]
else
(* Create the call. *)
diff --git a/src/plugins/eva/engine/transfer_stmt.mli b/src/plugins/eva/engine/transfer_stmt.mli
index a54bfe15b9cc5b7b6849a5cabfaeba4c9674ede0..7da3e2be794787a059471923e14b7d7bdacf7260 100644
--- a/src/plugins/eva/engine/transfer_stmt.mli
+++ b/src/plugins/eva/engine/transfer_stmt.mli
@@ -58,7 +58,7 @@ module type S = sig
(stmt -> (loc, value) call -> recursion option -> state -> call_result) ref
end
-module Make (Abstract: Abstractions.Eva)
+module Make (Abstract: Abstractions.S_with_evaluation)
: S with type state = Abstract.Dom.t
and type value = Abstract.Val.t
and type loc = Abstract.Loc.location
diff --git a/src/plugins/eva/eval.ml b/src/plugins/eva/eval.ml
index f0c0403a672540d8c414d63a8cc17e95f64b69c4..c08bf95bb6c864b0ca6bf378c554ed7eb5fced51 100644
--- a/src/plugins/eva/eval.ml
+++ b/src/plugins/eva/eval.ml
@@ -239,13 +239,9 @@ type ('loc, 'value) argument = {
avalue: ('loc, 'value) assigned;
}
-
-type call_site = kernel_function * kinstr
-type callstack = call_site list
-
type ('loc, 'value) call = {
kf: kernel_function;
- callstack: callstack;
+ callstack: Callstack.t;
arguments: ('loc, 'value) argument list;
rest: (exp * ('loc, 'value) assigned) list;
return: varinfo option;
diff --git a/src/plugins/eva/eval.mli b/src/plugins/eva/eval.mli
index 08793e093b818ab4da6b4cdb5cceb3695db5d70f..cee30db5319525e4a12c72c0a2ad0e6a09d15824 100644
--- a/src/plugins/eva/eval.mli
+++ b/src/plugins/eva/eval.mli
@@ -223,21 +223,10 @@ type ('loc, 'value) argument = {
avalue: ('loc, 'value) assigned; (** The value of the concrete argument. *)
}
-(** A call_stack is a list, telling which function was called at which
- site. The head of the list tells about the latest call. *)
-
-(** A call site: the function called, and the call statement
- (or [Kglobal] for the main function. *)
-type call_site = kernel_function * kinstr
-
-(* A call stack is a list of call sites. The head is the latest call.
- The last element is the main function. *)
-type callstack = call_site list
-
(** A function call. *)
type ('loc, 'value) call = {
kf: kernel_function; (** The called function. *)
- callstack: callstack; (** The current callstack
+ callstack: Callstack.t; (** The current callstack
(with this call on top). *)
arguments: ('loc, 'value) argument list; (** The arguments of the call. *)
rest: (exp * ('loc, 'value) assigned) list; (** Extra-arguments. *)
diff --git a/src/plugins/eva/gui/gui_callstacks_filters.ml b/src/plugins/eva/gui/gui_callstacks_filters.ml
index c8817ff00aaa9c2f5b04f82d830492109e8ca0dd..f4af6ba1b8016f7529c2a4329364297781c4d420 100644
--- a/src/plugins/eva/gui/gui_callstacks_filters.ml
+++ b/src/plugins/eva/gui/gui_callstacks_filters.ml
@@ -22,17 +22,19 @@
open Cil_types
-type rcallstack = Value_types.callstack
+type rcallstack = (Cil_types.kernel_function * Cil_types.kinstr) list
let empty = []
-let from_callstack = List.rev
+let from_callstack cs = Callstack.to_call_list cs
let callstack_matches_callstack (rcs1:rcallstack) (rcs2:rcallstack) =
let rec aux q1 q2 = match q1, q2 with
| [], _ | _, [] -> true
- | call1 :: q1, call2 :: q2 ->
- Value_types.Callsite.equal call1 call2 && aux q1 q2
+ | (kf1, kinstr1) :: q1, (kf2, kinstr2) :: q2 ->
+ Kernel_function.equal kf1 kf2
+ && Cil_datatype.Kinstr.equal kinstr1 kinstr2
+ && aux q1 q2
in
aux rcs1 rcs2
@@ -62,7 +64,7 @@ let has_matching_callstack ~after csf stmt =
| `Bottom -> false
| `Value h ->
try
- Value_types.Callstack.Hashtbl.iter
+ Callstack.Hashtbl.iter
(fun cs' _state ->
let rcs' = from_callstack cs' in
if callstack_matches csf rcs' then raise Exit
@@ -95,7 +97,7 @@ let register_to_zone_functions (module Eval: Gui_eval.S) =
let eval_filter csf stmt ev v =
match Eval.Analysis.get_stmt_state_by_callstack ~after:false stmt with
| `Value h ->
- Value_types.Callstack.Hashtbl.fold
+ Callstack.Hashtbl.fold
(fun cs state acc ->
let rcs' = from_callstack cs in
if callstack_matches csf rcs' then
diff --git a/src/plugins/eva/gui/gui_callstacks_filters.mli b/src/plugins/eva/gui/gui_callstacks_filters.mli
index b5bb5924d36f560eafa26d4061520c2823145da0..39da15edb11ae559db931ffb99a84682c07c8da7 100644
--- a/src/plugins/eva/gui/gui_callstacks_filters.mli
+++ b/src/plugins/eva/gui/gui_callstacks_filters.mli
@@ -26,7 +26,7 @@
type rcallstack
val empty: rcallstack
-val from_callstack: Value_types.callstack -> rcallstack
+val from_callstack: Callstack.t -> rcallstack
(** Filters on callstacks. [None] means that all callstacks are active *)
diff --git a/src/plugins/eva/gui/gui_eval.ml b/src/plugins/eva/gui/gui_eval.ml
index 8dd3dbd6d1682d60541f7e119ebd035cfda7470d..bc338ad9cd9f916018566fb902f00affa3b8defe 100644
--- a/src/plugins/eva/gui/gui_eval.ml
+++ b/src/plugins/eva/gui/gui_eval.ml
@@ -93,7 +93,7 @@ module type S = sig
type ('env, 'expr, 'v) evaluation_functions = {
eval_and_warn: 'env -> 'expr -> 'v * bool (* alarm *) * bool (* red *);
- env: Analysis.Dom.t -> Value_types.callstack -> 'env;
+ env: Analysis.Dom.t -> Callstack.t -> 'env;
equal: 'v -> 'v -> bool;
bottom: 'v;
join: 'v -> 'v -> 'v;
@@ -124,7 +124,7 @@ module type S = sig
val predicate_with_red:
gui_loc ->
- (Eval_terms.eval_env * (kinstr * Value_types.callstack),
+ (Eval_terms.eval_env * (kinstr * Callstack.t),
Red_statuses.alarm_or_property * predicate,
Eval_terms.predicate_status or_bottom
) evaluation_functions
@@ -139,6 +139,7 @@ end
module Make (X: Analysis.S) = struct
module Analysis = X
+ include Cvalue_domain.Getters (X.Dom)
let get_precise_loc =
match X.Loc.get Main_locations.PLoc.key with
@@ -151,7 +152,7 @@ module Make (X: Analysis.S) = struct
type ('env, 'expr, 'v) evaluation_functions = {
eval_and_warn: 'env -> 'expr -> 'v * bool * bool;
- env: X.Dom.t -> Value_types.callstack -> 'env;
+ env: X.Dom.t -> Callstack.t -> 'env;
equal: 'v -> 'v -> bool;
bottom: 'v;
join: 'v -> 'v -> 'v;
@@ -202,7 +203,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 = X.Dom.get_cvalue_or_top state in
+ let state = get_cvalue_or_top state in
let aux loc (acc_res, acc_ok) =
let res, ok =
match lv with (* catch simplest pattern *)
@@ -265,7 +266,7 @@ module Make (X: Analysis.S) = struct
}
let null_to_offsetmap state (_:unit) =
- let state = X.Dom.get_cvalue_or_top state in
+ let state = 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
@@ -322,22 +323,22 @@ module Make (X: Analysis.S) = struct
match Db.Value.get_initial_state_callstack kf with
| None -> Cvalue.Model.top (* should not happen *)
| Some h ->
- try Value_types.Callstack.Hashtbl.find h callstack
+ try Callstack.Hashtbl.find h callstack
with Not_found -> Cvalue.Model.top (* should not happen either *)
let env_here kf here callstack =
let pre = pre_kf kf callstack in
- let here = X.Dom.get_cvalue_or_top here in
+ let here = 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 = X.Dom.get_cvalue_or_top here in
+ let here = 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 = X.Dom.get_cvalue_or_top post in
+ let post = get_cvalue_or_top post in
let result =
if Function_calls.use_spec_instead_of_definition kf then
None
@@ -354,8 +355,8 @@ module Make (X: Analysis.S) = struct
(* Maps from callstacks to Value states before and after a GUI location.
The 'after' map is not always available. *)
type states_by_callstack = {
- states_before: X.Dom.t Value_types.Callstack.Hashtbl.t or_top_bottom;
- states_after: X.Dom.t Value_types.Callstack.Hashtbl.t or_top_bottom;
+ states_before: X.Dom.t Callstack.Hashtbl.t or_top_bottom;
+ states_after: X.Dom.t Callstack.Hashtbl.t or_top_bottom;
}
let top_states_by_callstacks = { states_before = `Top; states_after = `Top }
@@ -541,7 +542,7 @@ module Make (X: Analysis.S) = struct
let make_data_all_callstacks_from_states ev ~before ~after expr =
let exn = ref [] in
- let single_callstack = (Value_types.Callstack.Hashtbl.length before) = 1 in
+ let single_callstack = (Callstack.Hashtbl.length before) = 1 in
let v_join_before = ref ev.bottom in
let v_join_after = ref ev.bottom in
let ok_join = ref true in
@@ -564,14 +565,14 @@ module Make (X: Analysis.S) = struct
let ev = { ev with eval_and_warn } in
(* Rows by callstack *)
let list =
- Value_types.Callstack.Hashtbl.fold
+ Callstack.Hashtbl.fold
(fun callstack before acc ->
let before = ev.env before callstack in
let after = match after with
| `Top | `Bottom as x -> x
| `Value after ->
try
- let after = Value_types.Callstack.Hashtbl.find after callstack in
+ let after = Callstack.Hashtbl.find after callstack in
`Value (ev.env after callstack)
(* If a callstack exists before the statement but is not found
after, then the post state for this callstack is bottom. *)
diff --git a/src/plugins/eva/gui/gui_eval.mli b/src/plugins/eva/gui/gui_eval.mli
index 31916a24c65376e536cebd2d9796e21e203f0b44..52be333c333b9f80a9fe5adf38fb87f9a486b5fb 100644
--- a/src/plugins/eva/gui/gui_eval.mli
+++ b/src/plugins/eva/gui/gui_eval.mli
@@ -61,7 +61,7 @@ module type S = sig
(** This is the record that encapsulates all evaluation functions *)
type ('env, 'expr, 'v) evaluation_functions = {
eval_and_warn: 'env -> 'expr -> 'v * bool (* alarm *) * bool (* red *);
- env: Analysis.Dom.t -> Value_types.callstack -> 'env;
+ env: Analysis.Dom.t -> Callstack.t -> 'env;
equal: 'v -> 'v -> bool;
bottom: 'v;
join: 'v -> 'v -> 'v;
@@ -108,7 +108,7 @@ module type S = sig
val predicate_with_red:
gui_loc ->
- (Eval_terms.eval_env * (kinstr * Value_types.callstack),
+ (Eval_terms.eval_env * (kinstr * Callstack.t),
Red_statuses.alarm_or_property * predicate,
Eval_terms.predicate_status Lattice_bounds.or_bottom
) evaluation_functions
diff --git a/src/plugins/eva/gui/gui_types.ml b/src/plugins/eva/gui/gui_types.ml
index e52339afa5e8918bdbd00c42cb15234e8671064b..3f989adaf5db8eb63d43507cab31ea63783d8d19 100644
--- a/src/plugins/eva/gui/gui_types.ml
+++ b/src/plugins/eva/gui/gui_types.ml
@@ -25,20 +25,20 @@ open Cil_types
type gui_callstack =
| GC_Filtered (* Some results have been hidden by a filter *)
| GC_Consolidated (* Join of all possible callstacks *)
- | GC_Single of Value_types.callstack (* Only one callstack possible here *)
- | GC_Callstack of Value_types.callstack (* One of multiple callstacks *)
+ | GC_Single of Callstack.t (* Only one callstack possible here *)
+ | GC_Callstack of Callstack.t (* One of multiple callstacks *)
let hash_gui_callstack = function
| GC_Filtered -> 0
| GC_Consolidated -> 1
- | GC_Single cs -> 2 * Value_types.Callstack.hash cs
- | GC_Callstack cs -> 4 * Value_types.Callstack.hash cs
+ | GC_Single cs -> 2 * Callstack.hash cs
+ | GC_Callstack cs -> 4 * Callstack.hash cs
let compare_gui_callstack cs1 cs2 = match cs1, cs2 with
| GC_Filtered, GC_Filtered -> 0
| GC_Consolidated, GC_Consolidated -> 0
| GC_Single cs1, GC_Single cs2 | GC_Callstack cs1, GC_Callstack cs2 ->
- Value_types.Callstack.compare cs1 cs2
+ Callstack.compare cs1 cs2
| _, GC_Filtered -> 1
| GC_Filtered, _ -> -1
| _, GC_Consolidated -> 1
@@ -135,7 +135,7 @@ module type S = sig
val equal_gui_after : value gui_after -> value gui_after -> bool
end
-module Make (V: Abstractions.Value) = struct
+module Make (V: Abstract.Value.External) = struct
let pretty_gui_res fmt = function
| GR_Empty -> ()
@@ -227,44 +227,45 @@ let gui_loc_loc = function
let kf_of_gui_loc = function
| GL_Stmt (kf, _) | GL_Pre kf | GL_Post kf -> kf
+let pop_last_call cs =
+ match cs.Callstack.stack with
+ | (_, stmt) :: ((kf, _) :: _ as stack)-> Some (stmt, kf, { cs with stack })
+ | [_, stmt] -> Some (stmt, cs.entry_point, { cs with stack = [] })
+ | [] -> None
+
(* This pretty-printer drops the toplevel kf, which is always the function
in which we are pretty-printing the expression/term *)
let pretty_callstack fmt cs =
- match cs with
- | [_, Kglobal] -> ()
- | (_kf_cur, Kstmt callsite) :: q -> begin
- let rec aux callsite = function
- | (kf, callsite') :: q -> begin
- Format.fprintf fmt "%a (%a%t)"
- Kernel_function.pretty kf
- Cil_datatype.Location.pretty (Cil_datatype.Stmt.loc callsite)
- (fun fmt ->
- if Gui_parameters.debug_atleast 1 then
- Format.fprintf fmt ", %d" callsite.sid);
- match callsite' with
- | Kglobal -> ()
- | Kstmt callsite' ->
- Format.fprintf fmt " â†@ ";
- aux callsite' q
- end
- | _ -> assert false
- in
- Format.fprintf fmt "@[<hv>%a" Value_types.Callstack.pretty_hash cs;
- aux callsite q;
- Format.fprintf fmt "@]"
- end
- | _ -> assert false
+ match pop_last_call cs with
+ | None -> ()
+ | Some (stmt, caller, q) ->
+ let rec aux stmt caller cs =
+ Format.fprintf fmt "%a (%a%t)"
+ Kernel_function.pretty caller
+ Cil_datatype.Location.pretty (Cil_datatype.Stmt.loc stmt)
+ (fun fmt ->
+ if Gui_parameters.debug_atleast 1 then
+ Format.fprintf fmt ", %d" stmt.sid);
+ match pop_last_call cs with
+ | None -> ()
+ | Some (stmt, caller, q) ->
+ Format.fprintf fmt " â†@ ";
+ aux stmt caller q
+ in
+ Format.fprintf fmt "@[<hv>%a" Callstack.pretty_hash cs;
+ aux stmt caller q;
+ Format.fprintf fmt "@]"
(* This pretty-printer prints only the lists of the functions, not
the locations *)
let pretty_callstack_short fmt cs =
- match cs with
- | [_, Kglobal] -> ()
- | (_kf_cur, Kstmt _callsite) :: q ->
- Format.fprintf fmt "%a" Value_types.Callstack.pretty_hash cs;
+ match Callstack.pop cs with
+ | None -> ()
+ | Some q ->
+ Format.fprintf fmt "%a" Callstack.pretty_hash cs;
+ let list = List.rev (Callstack.to_kf_list q) in
Pretty_utils.pp_flowlist ~left:"@[" ~sep:" â†@ " ~right:"@]"
- (fun fmt (kf, _) -> Kernel_function.pretty fmt kf) fmt q
- | _ -> assert false
+ Kernel_function.pretty fmt list
(*
diff --git a/src/plugins/eva/gui/gui_types.mli b/src/plugins/eva/gui/gui_types.mli
index fdc05aa6401b9103a1521c7ff6974bf902535ace..04b713cd82aa5d8f73ccb4d14baa58a38cbeddfe 100644
--- a/src/plugins/eva/gui/gui_types.mli
+++ b/src/plugins/eva/gui/gui_types.mli
@@ -23,8 +23,8 @@
type gui_callstack =
| GC_Filtered
| GC_Consolidated
- | GC_Single of Value_types.callstack
- | GC_Callstack of Value_types.callstack
+ | GC_Single of Callstack.t
+ | GC_Callstack of Callstack.t
val hash_gui_callstack : gui_callstack -> int
val compare_gui_callstack : gui_callstack -> gui_callstack -> int
@@ -69,9 +69,9 @@ val gui_loc_loc : gui_loc -> Cil_types.location
val kf_of_gui_loc : gui_loc -> Cil_types.kernel_function
val pretty_callstack :
- Format.formatter -> Value_types.callstack -> unit
+ Format.formatter -> Callstack.t -> unit
val pretty_callstack_short :
- Format.formatter -> Value_types.callstack -> unit
+ Format.formatter -> Callstack.t -> unit
type 'a gui_res =
| GR_Empty
@@ -99,7 +99,7 @@ module type S = sig
end
(** The types below depend on the abstract values currently available. *)
-module Make (V : Abstractions.Value) : sig
+module Make (V : Abstract.Value.External) : sig
include S with type value := V.t
val get_cvalue : (V.t -> Main_values.CVal.t) option
diff --git a/src/plugins/eva/legacy/eval_annots.ml b/src/plugins/eva/legacy/eval_annots.ml
index 6ce1404d2491364dfcf653b5435a65fe4e865778..ca814b26cfbc3252f2e1a491436c22efa230b1e5 100644
--- a/src/plugins/eva/legacy/eval_annots.ml
+++ b/src/plugins/eva/legacy/eval_annots.ml
@@ -117,7 +117,7 @@ let c_labels kf cs =
if stmt.labels != [] then
try
let hstate = Db.Value.Table_By_Callstack.find stmt in
- let state = Value_types.Callstack.Hashtbl.find hstate cs in
+ let state = Callstack.Hashtbl.find hstate cs in
Cil_datatype.Logic_label.Map.add (StmtLabel (ref stmt)) state acc
with Not_found -> acc
else acc
@@ -143,7 +143,7 @@ let eval_by_callstack kf stmt p =
Unknown
| Some states ->
try
- match Value_types.Callstack.Hashtbl.fold aux_callstack states `Bottom with
+ match Callstack.Hashtbl.fold aux_callstack states `Bottom with
| `Bottom -> Eval_terms.Unknown (* probably never reached *)
| `Value status -> status
with Exit -> Eval_terms.Unknown
diff --git a/src/plugins/eva/legacy/eval_annots.mli b/src/plugins/eva/legacy/eval_annots.mli
index e6e9691cce40c3c99ee614e85f5adad33f51651d..bb4b33cac7a70b9ffb9fa0d2fb474bff0b2ee8aa 100644
--- a/src/plugins/eva/legacy/eval_annots.mli
+++ b/src/plugins/eva/legacy/eval_annots.mli
@@ -26,4 +26,4 @@ val has_requires: spec -> bool
val mark_invalid_initializers: unit -> unit
val mark_unreachable: unit -> unit
val mark_green_and_red: unit -> unit
-val c_labels: kernel_function -> Value_types.callstack -> Eval_terms.labels_states
+val c_labels: kernel_function -> Callstack.t -> Eval_terms.labels_states
diff --git a/src/plugins/eva/locations/locations_product.ml b/src/plugins/eva/locations/locations_product.ml
new file mode 100644
index 0000000000000000000000000000000000000000..e6fad814205d20093d00dd1ced03c3f8c47ece82
--- /dev/null
+++ b/src/plugins/eva/locations/locations_product.ml
@@ -0,0 +1,125 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2023 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+open Eval
+
+
+
+module Make
+ (Value: Abstract_value.S)
+ (Left: Abstract.Location.Internal with type value = Value.t)
+ (Right: Abstract.Location.Internal with type value = Value.t)
+= struct
+ type value = Value.t
+ let structure = Abstract.Location.Node (Left.structure, Right.structure)
+
+ type offset = Left.offset * Right.offset
+ type location = Left.location * Right.location
+
+ let top = Left.top, Right.top
+
+ let equal_loc (l, r) (l', r') =
+ Left.equal_loc l l' && Right.equal_loc r r'
+ let pretty_loc =
+ Pretty_utils.pp_pair Left.pretty_loc Right.pretty_loc
+
+ let equal_offset (l, r) (l', r') =
+ Left.equal_offset l l' && Right.equal_offset r r'
+ let pretty_offset =
+ Pretty_utils.pp_pair Left.pretty_offset Right.pretty_offset
+
+ (* TODO: don't know what to do, used max by default *)
+ let size (l, r) =
+ match Left.size l, Right.size r with
+ | Int_Base.Top, size
+ | size, Int_Base.Top -> size
+ | Int_Base.Value lsize as size, Int_Base.Value rsize ->
+ if Integer.equal lsize rsize then size else
+ Self.fatal
+ "Location product: inconsistent size of the same location \
+ represented by %a (size %a) and %a (size %a)."
+ Left.pretty_loc l Integer.pretty lsize
+ Right.pretty_loc r Integer.pretty rsize
+
+ let replace_base subst (l, r) =
+ Left.replace_base subst l, Right.replace_base subst r
+
+ let assume_no_overlap ~partial (l1, r1) (l2, r2) =
+ let l_truth = Left.assume_no_overlap ~partial l1 l2 in
+ let r_truth = Right.assume_no_overlap ~partial r1 r2 in
+ Value_product.narrow_truth_pair ((l1, l2), l_truth) ((r1, r2), r_truth)
+
+ let assume_valid_location ~for_writing ~bitfield (l, r) =
+ let l_truth = Left.assume_valid_location ~for_writing ~bitfield l in
+ let r_truth = Right.assume_valid_location ~for_writing ~bitfield r in
+ Value_product.narrow_truth (l, l_truth) (r, r_truth)
+
+ let no_offset = Left.no_offset, Right.no_offset
+
+ let forward_field typ varinfo (l, r) =
+ Left.forward_field typ varinfo l, Right.forward_field typ varinfo r
+
+ let forward_variable typ varinfo (l, r) =
+ let* l = Left.forward_variable typ varinfo l in
+ let* r = Right.forward_variable typ varinfo r in
+ `Value (l, r)
+
+ let eval_varinfo varinfo =
+ Left.eval_varinfo varinfo, Right.eval_varinfo varinfo
+
+ let backward_variable varinfo (l, r) =
+ let* l = Left.backward_variable varinfo l in
+ let* r = Right.backward_variable varinfo r in
+ `Value (l, r)
+
+ let backward_field typ varinfo (lo, ro) =
+ let* lo = Left.backward_field typ varinfo lo in
+ let* ro = Right.backward_field typ varinfo ro in
+ `Value (lo, ro)
+
+ (** Both value abstractions produce a sound value abstraction for the same
+ location, so we can narrow their results. *)
+ let to_value (l, r) =
+ let* vleft = Left.to_value l
+ and* vright = Right.to_value r in
+ Value.narrow vleft vright
+
+ let forward_index typ v (l, r) =
+ Left.forward_index typ v l, Right.forward_index typ v r
+
+ let forward_pointer typ v (lo, ro) =
+ let* l = Left.forward_pointer typ v lo in
+ let* r = Right.forward_pointer typ v ro in
+ `Value (l, r)
+
+ let backward_pointer v (lo, ro) (l, r) =
+ let* (lv, lo) = Left.backward_pointer v lo l in
+ let* (rv, ro) = Right.backward_pointer v ro r in
+ let* v = Value.narrow lv rv in
+ `Value (v, (lo, ro))
+
+ let backward_index typ ~index ~remaining:(lrem, rrem) (lo, ro) =
+ let* (lv, lo) = Left.backward_index typ ~index ~remaining:lrem lo in
+ let* (rv, ro) = Right.backward_index typ ~index ~remaining:rrem ro in
+ let* v = Value.narrow lv rv in
+ `Value (v, (lo, ro))
+end
diff --git a/src/plugins/callgraph/gui/graph.gtk.ml b/src/plugins/eva/locations/locations_product.mli
similarity index 82%
rename from src/plugins/callgraph/gui/graph.gtk.ml
rename to src/plugins/eva/locations/locations_product.mli
index 371572617986251b4fdb4e30ce9f07b73c912a82..150c21c89eba0fca1c895b2b9fc553e7e4a02392 100644
--- a/src/plugins/callgraph/gui/graph.gtk.ml
+++ b/src/plugins/eva/locations/locations_product.mli
@@ -20,4 +20,11 @@
(* *)
(**************************************************************************)
-module S = Graph_gtk
+module Make
+ (Value: Abstract_value.S)
+ (Left: Abstract.Location.Internal with type value = Value.t)
+ (Right: Abstract.Location.Internal with type value = Value.t)
+ : Abstract.Location.Internal
+ with type value = Value.t
+ and type location = Left.location * Right.location
+ and type offset = Left.offset * Right.offset
diff --git a/src/plugins/eva/partitioning/auto_loop_unroll.ml b/src/plugins/eva/partitioning/auto_loop_unroll.ml
index 3df1e5d6b2efb702367092fb9854ffc779d43ad5..58b52807752271e0a9c58bb69d832deeb6f78844 100644
--- a/src/plugins/eva/partitioning/auto_loop_unroll.ml
+++ b/src/plugins/eva/partitioning/auto_loop_unroll.ml
@@ -323,7 +323,7 @@ let cross_equality loop lval =
| Some lval -> lval
| None | exception No_equality -> lval
-module Make (Abstract: Abstractions.Eva) = struct
+module Make (Abstract: Abstractions.S_with_evaluation) = struct
open Eval
open Abstract
diff --git a/src/plugins/eva/partitioning/auto_loop_unroll.mli b/src/plugins/eva/partitioning/auto_loop_unroll.mli
index 4bbc478a68584f5c3bcf6543c41883006692d528..1922eb815dfc850ff97e624f4730ff9c58444028 100644
--- a/src/plugins/eva/partitioning/auto_loop_unroll.mli
+++ b/src/plugins/eva/partitioning/auto_loop_unroll.mli
@@ -22,7 +22,7 @@
(** Heuristic for automatic loop unrolling. *)
-module Make (Abstract: Abstractions.Eva) : sig
+module Make (Abstract: Abstractions.S_with_evaluation) : sig
val compute:
max_unroll:int -> Abstract.Dom.t -> Cil_types.stmt -> int option
diff --git a/src/plugins/eva/partitioning/partition.ml b/src/plugins/eva/partitioning/partition.ml
index 14723800087101c1b1049d3fd7a0b910ff631278..13ae29b16c5695f7f8418e115b48e0249b67ce18 100644
--- a/src/plugins/eva/partitioning/partition.ml
+++ b/src/plugins/eva/partitioning/partition.ml
@@ -322,7 +322,7 @@ exception InvalidAction
(* --- Flows --- *)
-module MakeFlow (Abstract: Abstractions.Eva) =
+module MakeFlow (Abstract: Abstractions.S_with_evaluation) =
struct
type state = Abstract.Dom.t
type t = (key * state) list
@@ -536,19 +536,19 @@ struct
let key = { key with dynamic_splits } in
split_state ~monitor term (key, state)
in
- Transitioning.List.concat_map add_split p
+ List.concat_map add_split p
let update_dynamic_splits p =
(* Update one state *)
let update_state (key, state) =
(* Split the states in the list l for the given exp *)
let update_exp term monitor l =
- Transitioning.List.concat_map (split_state ~monitor term) l
+ List.concat_map (split_state ~monitor term) l
in
(* Foreach exp in original state: split *)
SplitMap.fold update_exp key.dynamic_splits [(key,state)]
in
- Transitioning.List.concat_map update_state p
+ List.concat_map update_state p
let map_keys (f : key -> state -> key) (p : t) : t =
List.map (fun (k,x) -> f k x, x) p
diff --git a/src/plugins/eva/partitioning/partition.mli b/src/plugins/eva/partitioning/partition.mli
index caf4e08c2487c27dba54be9916b43945669c14d4..18256b222e2249af59dc67eef3c5128956a6b4f4 100644
--- a/src/plugins/eva/partitioning/partition.mli
+++ b/src/plugins/eva/partitioning/partition.mli
@@ -175,7 +175,7 @@ exception InvalidAction
(** Flows are used to transfer states from one partition to another, by
applying transfer functions and partitioning actions. They do not enforce
the unicity of keys. *)
-module MakeFlow (Abstract: Abstractions.Eva) :
+module MakeFlow (Abstract: Abstractions.S_with_evaluation) :
sig
type state = Abstract.Dom.t
type t
diff --git a/src/plugins/eva/partitioning/trace_partitioning.ml b/src/plugins/eva/partitioning/trace_partitioning.ml
index 2e38c548ff027ad0587432d265d6e0beaff02f6a..ae449dc72983922a90d7215ed43e9f298d7935db 100644
--- a/src/plugins/eva/partitioning/trace_partitioning.ml
+++ b/src/plugins/eva/partitioning/trace_partitioning.ml
@@ -26,7 +26,7 @@ open Partition
let stat_max_widenings = Statistics.register_statement_stat "max-widenings"
module Make
- (Abstract: Abstractions.Eva)
+ (Abstract: Abstractions.S_with_evaluation)
(Kf : sig val kf: kernel_function end) =
struct
module Partition_parameters = Partitioning_parameters.Make (Kf)
diff --git a/src/plugins/eva/partitioning/trace_partitioning.mli b/src/plugins/eva/partitioning/trace_partitioning.mli
index dd8cade8865e1ec7ae490547566e411efb46b588..d6e22fb5345a33f170950df629cd0b38f6b495d1 100644
--- a/src/plugins/eva/partitioning/trace_partitioning.mli
+++ b/src/plugins/eva/partitioning/trace_partitioning.mli
@@ -21,7 +21,7 @@
(**************************************************************************)
module Make
- (Abstract : Abstractions.Eva)
+ (Abstract : Abstractions.S_with_evaluation)
(Kf : sig val kf: Cil_types.kernel_function end) :
sig
(** The states being partitioned *)
diff --git a/src/plugins/eva/self.ml b/src/plugins/eva/self.ml
index eeceead1daaeaacaa0087aa6ce8b77da5ee09a69..072213e1a68c550fc1389bb697e0d79b71937b1c 100644
--- a/src/plugins/eva/self.ml
+++ b/src/plugins/eva/self.ml
@@ -69,11 +69,7 @@ struct
end
module Datatype' = Datatype.Make (Prototype)
- module Hook = Hook.Build (Prototype)
include (State_builder.Ref (Datatype') (Prototype))
-
- let set s = set s; Hook.apply s
- let () = add_hook_on_update (fun r -> Hook.apply !r)
end
let is_computed () =
@@ -81,18 +77,6 @@ let is_computed () =
| Computed | Aborted -> true
| NotComputed | Computing -> false
-let current_computation_state = ComputationState.get
-let set_computation_state = ComputationState.set
-
-(* Register a hook on current computation state *)
-let register_computation_hook ?on f =
- let f' = match on with
- | None -> f
- | Some s -> fun s' -> if s = s' then f s
- in
- ComputationState.Hook.extend f'
-
-
(* Debug categories. *)
let dkey_initial_state = register_category "initial-state"
let dkey_final_states = register_category "final-states"
diff --git a/src/plugins/eva/self.mli b/src/plugins/eva/self.mli
index fef6d68746dfbbc75de2985949496abaef728dd7..3171cb73572f1dbb269df15b2110e6f2e7b996b7 100644
--- a/src/plugins/eva/self.mli
+++ b/src/plugins/eva/self.mli
@@ -31,18 +31,9 @@ val is_computed: unit -> bool
(** Computation state of the analysis. *)
type computation_state = NotComputed | Computing | Computed | Aborted
-(** Get the current computation state of the analysis, updated by
+(** The current computation state of the analysis, updated by
[force_compute] and states updates. *)
-val current_computation_state : unit -> computation_state
-
-(** Set the current computation state. *)
-val set_computation_state: computation_state -> unit
-
-(** Registers a hook that will be called each time the analysis starts or
- finishes. If [on] is given, the hook will only be called when the
- analysis switches to this specific state. *)
-val register_computation_hook: ?on:computation_state ->
- (computation_state -> unit) -> unit
+module ComputationState : State_builder.Ref with type data = computation_state
(** Debug categories responsible for printing initial and final states of Value.
Enabled by default, but can be disabled via the command-line:
diff --git a/src/plugins/callgraph/gui/graph.dgraph.ml b/src/plugins/eva/types/callstack.ml
similarity index 98%
rename from src/plugins/callgraph/gui/graph.dgraph.ml
rename to src/plugins/eva/types/callstack.ml
index 9fda8eaf92a54de409573b94c94c493e43b7f692..160bfd2d48e272a3ee48bbc0de225a1994ea53f5 100644
--- a/src/plugins/callgraph/gui/graph.dgraph.ml
+++ b/src/plugins/eva/types/callstack.ml
@@ -20,4 +20,4 @@
(* *)
(**************************************************************************)
-module S = Dgraph
+include Eva_types.Callstack
diff --git a/src/plugins/eva/types/callstack.mli b/src/plugins/eva/types/callstack.mli
new file mode 100644
index 0000000000000000000000000000000000000000..9e4a7654bbf600985ea25750c94a9dbd0ccc8767
--- /dev/null
+++ b/src/plugins/eva/types/callstack.mli
@@ -0,0 +1,92 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2023 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+[@@@ api_start]
+[@@@ alert "-db_deprecated"]
+
+(** A call is identified by the function called and the call statement *)
+type call = Cil_types.kernel_function * Cil_types.stmt
+
+module Call : Datatype.S with type t = call
+
+(** Eva callstacks. *)
+type callstack = Eva_types.Callstack.callstack = {
+ thread: int;
+ (* An identifier of the thread's callstack. *)
+ entry_point: Cil_types.kernel_function;
+ (** The first function function of the callstack. *)
+ stack: call list;
+ (** A call stack is a list of calls. The head is the latest call. *)
+}
+
+include Datatype.S_with_collections
+ with type t = callstack
+ and module Hashtbl = Eva_types.Callstack.Hashtbl
+
+(** Prints a callstack without displaying call sites. *)
+val pretty_short : Format.formatter -> t -> unit
+
+(** Prints a hash of the callstack when '-kernel-msg-key callstack'
+ is enabled (prints nothing otherwise). *)
+val pretty_hash : Format.formatter -> t -> unit
+
+(** [compare_lex] compares callstack lexicographically, slightly slower
+ than [compare] but in a more natural order, giving more importance
+ to the function at bottom of the callstack - the first functions called. *)
+val compare_lex : t -> t -> int
+
+(*** {2 Stack manipulation} *)
+
+(*** Constructor *)
+val init : ?thread:int -> Cil_types.kernel_function -> t
+
+(** Adds a new call to the top of the callstack. *)
+val push : Cil_types.kernel_function -> Cil_types.stmt -> t -> t
+
+(** Removes the topmost call from the callstack. *)
+val pop : t -> t option
+
+val top : t -> (Cil_types.kernel_function * Cil_types.stmt) option
+val top_kf : t -> Cil_types.kernel_function
+val top_callsite : t -> Cil_types.kinstr
+val top_call : t -> Cil_types.kernel_function * Cil_types.kinstr
+
+(** Returns the function that called the topmost function of the callstack. *)
+val top_caller : t -> Cil_types.kernel_function option
+
+(** {2 Conversion} *)
+
+(** Gives the list of kf in the callstack from the entry point to the top of the
+ callstack (i.e. reverse order of the call stack). *)
+val to_kf_list : t -> Cil_types.kernel_function list
+
+(** Gives the list of call statements from the bottom to the top of the
+ callstack (i.e. reverse order of the call stack). *)
+val to_stmt_list : t -> Cil_types.stmt list
+
+(** Gives the list of call from the bottom to the top of the callstack
+ (i.e. reverse order of the call stack). *)
+val to_call_list : t -> (Cil_types.kernel_function * Cil_types.kinstr) list
+
+[@@@ api_end]
+
+val pretty_debug : Format.formatter -> t -> unit
diff --git a/src/plugins/eva/utils/abstract.ml b/src/plugins/eva/utils/abstract.ml
index 11c54bedde65a23402bffb172c8168234f2f42cb..1ef84e43b66b2516ada82693c6488252cb76a5d8 100644
--- a/src/plugins/eva/utils/abstract.ml
+++ b/src/plugins/eva/utils/abstract.ml
@@ -80,9 +80,5 @@ module Domain = struct
include Structure.External with type t := t
and type 'a key := 'a key
and type 'a data := 'a data
-
- val get_cvalue: (t -> Cvalue.Model.t) option
- val get_cvalue_or_top: t -> Cvalue.Model.t
- val get_cvalue_or_bottom: t Lattice_bounds.or_bottom -> Cvalue.Model.t
end
end
diff --git a/src/plugins/eva/utils/abstract.mli b/src/plugins/eva/utils/abstract.mli
index d3d5e3a3a62a07f60af87054df0a7ac32f00e57f..399aac89323e8e0d894e720a5c4d5ee4e9cc6329 100644
--- a/src/plugins/eva/utils/abstract.mli
+++ b/src/plugins/eva/utils/abstract.mli
@@ -90,10 +90,5 @@ module Domain : sig
include Structure.External with type t := t
and type 'a key := 'a key
and type 'a data := 'a data
-
- (** 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 Lattice_bounds.or_bottom -> Cvalue.Model.t
end
end
diff --git a/src/plugins/eva/utils/cvalue_callbacks.ml b/src/plugins/eva/utils/cvalue_callbacks.ml
index c8fcd6074d88d87f531d5cbff03c3d9d205b0d0c..d5bf54e2f5b77bc048ad80777e94aa85cc0e2c81 100644
--- a/src/plugins/eva/utils/cvalue_callbacks.ml
+++ b/src/plugins/eva/utils/cvalue_callbacks.ml
@@ -24,24 +24,22 @@ open Cil_types
let dkey = Self.dkey_callbacks
-type callstack = (kernel_function * kinstr) list
type state = Cvalue.Model.t
-type analysis_kind =
- [ `Builtin of Value_types.call_froms
- | `Spec of funspec
- | `Def
- | `Memexec ]
+type analysis_kind = [ `Builtin | `Spec | `Body | `Reuse ]
+
+type call_hook =
+ Callstack.t -> Cil_types.kernel_function -> state -> analysis_kind -> unit
module Call =
Hook.Build
- (struct type t = callstack * kernel_function * analysis_kind * state end)
+ (struct type t = Callstack.t * kernel_function * state * analysis_kind end)
let register_call_hook f =
Call.extend (fun (callstack, kf, kind, state) -> f callstack kf kind state)
-let apply_call_hooks callstack kf kind state =
- Call.apply (callstack, kf, kind, state);
+let apply_call_hooks callstack kf state kind =
+ Call.apply (callstack, kf, state, kind);
Db.Value.Call_Type_Value_Callbacks.apply (kind, state, callstack)
@@ -49,32 +47,43 @@ type state_by_stmt = (state Cil_datatype.Stmt.Hashtbl.t) Lazy.t
type results = { before_stmts: state_by_stmt; after_stmts: state_by_stmt }
type call_results =
- | Store of results * int
- | Reuse of int
+ [ `Builtin of state list * Value_types.call_froms
+ | `Spec of state list
+ | `Body of results * int
+ | `Reuse of int
+ ]
+
+type call_results_hook =
+ Callstack.t -> Cil_types.kernel_function -> state -> call_results -> unit
module Call_Results =
- Hook.Build (struct type t = callstack * kernel_function * call_results end)
+ Hook.Build
+ (struct type t = Callstack.t * kernel_function * state * call_results end)
let register_call_results_hook f =
- Call_Results.extend (fun (callstack, kf, results) -> f callstack kf results)
+ Call_Results.extend
+ (fun (callstack, kf, state, results) -> f callstack kf state results)
-let apply_call_results_hooks callstack kf call_results =
+let apply_call_results_hooks callstack kf state call_results =
if Parameters.ValShowProgress.get ()
&& not (Call_Results.is_empty ()
&& Db.Value.Record_Value_Callbacks_New.is_empty ())
then Self.debug ~dkey "now calling Call_Results callbacks";
- Call_Results.apply (callstack, kf, call_results);
+ Call_Results.apply (callstack, kf, state, call_results);
let results =
match call_results with
- | Reuse i -> Value_types.Reuse i
- | Store ({before_stmts; after_stmts}, i) ->
- Value_types.NormalStore ((before_stmts, after_stmts), i)
+ | `Builtin _ | `Spec _ -> None
+ | `Reuse i -> Some (Value_types.Reuse i)
+ | `Body ({before_stmts; after_stmts}, i) ->
+ Some (Value_types.NormalStore ((before_stmts, after_stmts), i))
in
- Db.Value.Record_Value_Callbacks_New.apply (callstack, results)
+ Option.iter
+ (fun r -> Db.Value.Record_Value_Callbacks_New.apply (callstack, r))
+ results
module Statement =
- Hook.Build (struct type t = callstack * stmt * state list end)
+ Hook.Build (struct type t = Callstack.t * stmt * state list end)
let register_statement_hook f =
Statement.extend (fun (callstack, stmt, states) -> f callstack stmt states)
diff --git a/src/plugins/eva/utils/cvalue_callbacks.mli b/src/plugins/eva/utils/cvalue_callbacks.mli
index abc2408b9ec12f4e3b05aa3e0a1eab2a55d6c873..52d0d41330f31893650a9a232d2173376ea029bc 100644
--- a/src/plugins/eva/utils/cvalue_callbacks.mli
+++ b/src/plugins/eva/utils/cvalue_callbacks.mli
@@ -28,22 +28,24 @@
in a future version. Please contact us if you need to register callbacks
to be executed during an Eva analysis. *)
-type callstack = (Cil_types.kernel_function * Cil_types.kinstr) list
type state = Cvalue.Model.t
type analysis_kind =
- [ `Builtin of Value_types.call_froms
- | `Spec of Cil_types.funspec
- | `Def
- | `Memexec ]
+ [ `Builtin (** A cvalue builtin is used to interpret the function. *)
+ | `Spec (** The specification is used to interpret the function. *)
+ | `Body (** The function body is analyzed. This is the standard case. *)
+ | `Reuse (** The results of a previous analysis of the function are reused. *)
+ ]
-(** Registers a function to be applied at the beginning of the analysis of each
- function call. Arguments of the callback are the callstack of the call,
- the function called, the kind of analysis performed by Eva for this call,
- and the cvalue state at the beginning of the call. *)
-val register_call_hook:
- (callstack -> Cil_types.kernel_function -> analysis_kind -> state -> unit)
- -> unit
+(** Signature of a hook to be called before the analysis of each function call.
+ Arguments are the callstack of the call, the function called, the initial
+ cvalue state, and the kind of analysis performed by Eva for this call. *)
+type call_hook =
+ Callstack.t -> Cil_types.kernel_function -> state -> analysis_kind -> unit
+
+(** Registers a function to be applied at the start of the analysis of each
+ function call. *)
+val register_call_hook: call_hook -> unit
type state_by_stmt = (state Cil_datatype.Stmt.Hashtbl.t) Lazy.t
@@ -51,28 +53,36 @@ type results = { before_stmts: state_by_stmt; after_stmts: state_by_stmt }
(** Results of a function call. *)
type call_results =
- | Store of results * int
+ [ `Builtin of state list * Value_types.call_froms
+ (** List of cvalue states at the end of the builtin. *)
+ | `Spec of state list
+ (** List of cvalue states at the end of the call. *)
+ | `Body of results * int
(** Cvalue states before and after each statement of the given function,
plus a unique integer id for the call. *)
- | Reuse of int
- (** The results are the same as a previous call with the given integer id,
- previously recorded with the [Store] constructor. *)
+ | `Reuse of int
+ (** The results are the same as a previous call with the given integer id,
+ previously recorded with the [`Body] constructor. *)
+ ]
+
+(** Signature of a hook to be called after the analysis of each function call.
+ Arguments are the callstack of the call, the function called, the initial
+ cvalue state at the start of the call, and the results from its analysis. *)
+type call_results_hook =
+ Callstack.t -> Cil_types.kernel_function -> state -> call_results -> unit
(** Registers a function to be applied at the end of the analysis of each
- function call. Arguments of the callback are the callstack of the call,
- the function called and the cvalue states resulting from its analysis. *)
-val register_call_results_hook:
- (callstack -> Cil_types.kernel_function -> call_results -> unit)
- -> unit
+ function call. *)
+val register_call_results_hook: call_results_hook -> unit
[@@@ api_end]
val register_statement_hook:
- (callstack -> Cil_types.stmt -> state list -> unit) -> unit
+ (Callstack.t -> Cil_types.stmt -> state list -> unit) -> unit
val apply_call_hooks:
- callstack -> Cil_types.kernel_function -> analysis_kind -> state -> unit
+ Callstack.t -> Cil_types.kernel_function -> state -> analysis_kind -> unit
val apply_call_results_hooks:
- callstack -> Cil_types.kernel_function -> call_results -> unit
+ Callstack.t -> Cil_types.kernel_function -> state -> call_results -> unit
val apply_statement_hooks:
- callstack -> Cil_types.stmt -> state list -> unit
+ Callstack.t -> Cil_types.stmt -> state list -> unit
diff --git a/src/plugins/eva/utils/eva_perf.ml b/src/plugins/eva/utils/eva_perf.ml
index 1efc3d7c32ab56ef25903adfc736f74add3278af..4c0ae010c6ff1309e2e1fd7e93d48f702691b2bf 100644
--- a/src/plugins/eva/utils/eva_perf.ml
+++ b/src/plugins/eva/utils/eva_perf.ml
@@ -218,7 +218,8 @@ module Imperative_callstack_trie(M:sig type t val default:unit -> t end) = struc
n
in find_subtree subnode.subtree b (Some subnode)
- let find_subtree t callstack = find_subtree t (List.rev callstack) None
+ let find_subtree t callstack =
+ find_subtree t (Callstack.to_call_list callstack) None
let find t callstack = (find_subtree t callstack).self
@@ -285,25 +286,25 @@ let display fmt =
end
;;
-let caller_callee_callinfo = function
- | (callee_kf,_)::(caller_kf,_)::_ ->
- (let caller_flat = Kernel_function.Hashtbl.find flat caller_kf in
- try
+let caller_callee_callinfo callstack =
+ match Callstack.top_caller callstack with
+ | Some caller_kf ->
+ let callee_kf = Callstack.top_kf callstack in
+ let caller_flat = Kernel_function.Hashtbl.find flat caller_kf in
+ (try
Kernel_function.Hashtbl.find caller_flat.called_functions callee_kf
with Not_found ->
let call_info = Call_info.create() in
Kernel_function.Hashtbl.add caller_flat.called_functions callee_kf call_info;
call_info)
- | [_] -> Call_info.main
- | [] -> assert false
+ | None -> Call_info.main
;;
let start_doing_perf callstack =
if Parameters.ValShowPerf.get()
then begin
let time = Sys.time() in
- assert (callstack != []);
- let kf = fst (List.hd callstack) in
+ let kf = Callstack.top_kf callstack in
let flat_info =
try Kernel_function.Hashtbl.find flat kf
with Not_found ->
@@ -325,7 +326,7 @@ let stop_doing_perf callstack =
if Parameters.ValShowPerf.get()
then begin
let time = Sys.time() in
- let kf = fst (List.hd callstack) in
+ let kf = Callstack.top_kf callstack in
let flat_info = Kernel_function.Hashtbl.find flat kf in
Call_info.after_call flat_info.call_info time;
let node = Perf_by_callstack.find perf callstack in
@@ -365,14 +366,13 @@ let stack_flamegraph = ref []
(* pretty-prints the functions in a Value callstack, starting by main (i.e.
in reverse order). *)
-let pretty_callstack oc l =
+let pretty_callstack oc callstack =
let rec aux oc = function
| [] -> () (* does not happen in theory *)
- | [main, _] -> Printf.fprintf oc "%s" (Kernel_function.get_name main)
- | (f, _) :: q ->
- Printf.fprintf oc "%a;%s" aux q (Kernel_function.get_name f)
+ | [main] -> Printf.fprintf oc "%s" (Kernel_function.get_name main)
+ | kf :: q -> Printf.fprintf oc "%s;%a" (Kernel_function.get_name kf) aux q
in
- aux oc l
+ aux oc (Callstack.to_kf_list callstack)
(* update the [self_total_time] information for the function being analyzed,
assuming that the current time is [time] *)
@@ -385,9 +385,8 @@ let update_self_total_time time =
(* called when a new function is being analyzed *)
let start_doing_flamegraph callstack =
- match callstack with
- | [] -> assert false
- | [_] ->
+ match callstack.Callstack.stack with
+ | [] ->
(* Analysis of main *)
if not (Parameters.ValPerfFlamegraphs.is_empty ()) then begin
let file = Parameters.ValPerfFlamegraphs.get () in
@@ -401,7 +400,7 @@ let start_doing_flamegraph callstack =
(Printexc.to_string e);
oc_flamegraph := None (* to be on the safe side *)
end
- | _ :: _ :: _ ->
+ | _ :: _ ->
if !oc_flamegraph <> None then
(* Flamegraphs are being computed. Update time spent in current function
so far, then push a slot for the analysis of the new function *)
diff --git a/src/plugins/eva/utils/eva_perf.mli b/src/plugins/eva/utils/eva_perf.mli
index 2c0a2edd183946a7d6970bd7139e2560a7f62ec5..cb4a2af9a1eb768e56c5e454594206e1ef4b0fdf 100644
--- a/src/plugins/eva/utils/eva_perf.mli
+++ b/src/plugins/eva/utils/eva_perf.mli
@@ -22,11 +22,11 @@
(** Call [start_doing] when starting analyzing a new function. The new
function is on the top of the call stack.*)
-val start_doing: Value_types.callstack -> unit
+val start_doing: Callstack.t -> unit
(** Call [start_doing] when finishing analyzing a function. The
function must still be on the top of the call stack. *)
-val stop_doing: Value_types.callstack -> unit
+val stop_doing: Callstack.t -> unit
(** Display a complete summary of performance informations. Can be
called during the analysis. *)
diff --git a/src/plugins/eva/utils/eva_results.ml b/src/plugins/eva/utils/eva_results.ml
index 7bd81b39928f5550e41c6a0a6d3a2265afe3fc2d..6d905282146d539ac22dce9a2c99f6f8928807d3 100644
--- a/src/plugins/eva/utils/eva_results.ml
+++ b/src/plugins/eva/utils/eva_results.ml
@@ -35,7 +35,7 @@ let partition_terminating_instr stmt =
let terminating = ref [] in
let non_terminating = ref [] in
let add x xs = xs := x :: !xs in
- Value_types.Callstack.Hashtbl.iter (fun cs state ->
+ Callstack.Hashtbl.iter (fun cs state ->
if Db.Value.is_reachable state
then add cs terminating
else add cs non_terminating) h;
@@ -49,7 +49,7 @@ let is_non_terminating_instr stmt =
(* {2 Saving and restoring state} *)
-type stmt_by_callstack = Cvalue.Model.t Value_types.Callstack.Hashtbl.t
+type stmt_by_callstack = Cvalue.Model.t Callstack.Hashtbl.t
module AlarmsStmt =
Datatype.Pair_with_collections (Alarms) (Stmt)
@@ -72,7 +72,7 @@ type results = {
let get_results () =
let vue = Emitter.get Eva_utils.emitter in
let main = Some (fst (Globals.entry_point ())) in
- let module CS = Value_types.Callstack in
+ let module CS = Callstack in
let copy_states iter =
let h = Stmt.Hashtbl.create 128 in
let copy stmt hstack = Stmt.Hashtbl.add h stmt (CS.Hashtbl.copy hstack) in
@@ -144,16 +144,16 @@ let set_results results =
let aux_callstack callstack state =
Db.Value.update_callstack_table ~after stmt callstack state;
in
- Value_types.Callstack.Hashtbl.iter aux_callstack h
+ Callstack.Hashtbl.iter aux_callstack h
in
Stmt.Hashtbl.iter (aux_states ~after:false) results.before_states;
Stmt.Hashtbl.iter (aux_states ~after:true) results.after_states;
(* Kf initial state *)
- let aux_initial_state _kf h =
+ let aux_initial_state kf h =
let aux_callstack callstack state =
- Db.Value.merge_initial_state callstack state
+ Db.Value.merge_initial_state callstack kf state
in
- Value_types.Callstack.Hashtbl.iter aux_callstack h
+ Callstack.Hashtbl.iter aux_callstack h
in
Kernel_function.Hashtbl.iter aux_initial_state results.kf_initial_states;
Function_calls.set_results results.kf_callers;
@@ -171,7 +171,7 @@ let set_results results =
let b = Parameters.ResultsAll.get () in
Cvalue_domain.State.Store.register_global_state b
(`Value Cvalue_domain.State.top);
- Self.set_computation_state Computed;
+ Self.ComputationState.set Computed;
Db.Value.mark_as_computed ();
;;
@@ -204,7 +204,7 @@ struct
end
-module CallstackH = HExt(Value_types.Callstack.Hashtbl)
+module CallstackH = HExt(Callstack.Hashtbl)
module StmtH = HExt(Stmt.Hashtbl)
module KfH = HExt(Kernel_function.Hashtbl)
module PropertyH = HExt(Property.Hashtbl)
diff --git a/src/plugins/eva/utils/eva_results.mli b/src/plugins/eva/utils/eva_results.mli
index bc5d4c7d8cd7cf276098184a9abb3b4a94b27bf3..ee688e7b7d7dc4e997c3fa22aaf592d847bcf79c 100644
--- a/src/plugins/eva/utils/eva_results.mli
+++ b/src/plugins/eva/utils/eva_results.mli
@@ -44,7 +44,7 @@ val merge: results -> results -> results
For technical reasons, the top of the callstack must currently
be preserved. *)
val change_callstacks:
- (Value_types.callstack -> Value_types.callstack) -> results -> results
+ (Callstack.t -> Callstack.t) -> results -> results
val eval_tlval_as_location :
?result:Cil_types.varinfo ->
diff --git a/src/plugins/eva/utils/eva_utils.ml b/src/plugins/eva/utils/eva_utils.ml
index 7dbc948a1e05968b67aeee3d0ae3c17ccae81c3e..73dc03924ed0497f7e611994aeb9631803134333 100644
--- a/src/plugins/eva/utils/eva_utils.ml
+++ b/src/plugins/eva/utils/eva_utils.ml
@@ -22,35 +22,53 @@
open Cil_types
-(* Callstacks related types and functions *)
+(* Callstacks related functions *)
-let call_stack : Value_types.callstack ref = ref []
-(* let call_stack_for_callbacks : (kernel_function * kinstr) list ref = ref [] *)
+let current_callstack : Callstack.t option ref = ref None
let clear_call_stack () =
- call_stack := []
-
-let pop_call_stack () =
- Eva_perf.stop_doing !call_stack;
- call_stack := List.tl !call_stack
-;;
-
-let push_call_stack kf ki =
- call_stack := (kf,ki) :: !call_stack;
- Eva_perf.start_doing !call_stack
-;;
-
+ match !current_callstack with
+ | None -> ()
+ | Some cs ->
+ Eva_perf.stop_doing cs;
+ current_callstack := None
+
+let init_call_stack kf =
+ assert (!current_callstack = None);
+ let cs = Callstack.init kf in
+ current_callstack := Some cs;
+ Eva_perf.start_doing cs;
+ cs
+
+let current_call_stack_opt () = !current_callstack
+
+let current_call_stack () =
+ match !current_callstack with
+ | None -> Self.fatal "Callstack not initialized"
+ | Some cs -> cs
let current_kf () =
- let (kf,_) = (List.hd !call_stack) in kf;;
+ let cs = current_call_stack () in
+ Callstack.top_kf cs
-let call_stack () = !call_stack
+let push_call_stack kf stmt =
+ let cs = current_call_stack () in
+ let new_cs = Callstack.push kf stmt cs in
+ current_callstack := Some new_cs;
+ Eva_perf.start_doing new_cs
+
+let pop_call_stack () =
+ let cs = current_call_stack () in
+ Eva_perf.stop_doing cs;
+ current_callstack := Callstack.pop cs
let pp_callstack fmt =
if Parameters.PrintCallstacks.get () then
- Format.fprintf fmt "@ stack: %a"
- Value_types.Callstack.pretty (call_stack())
-;;
+ match !current_callstack with
+ | None -> () (* Stack not initialized; happens when handling global initializations *)
+ | Some cs ->
+ Format.fprintf fmt "@ stack: %a" Callstack.pretty cs
+
(* Assertions emitted during the analysis *)
diff --git a/src/plugins/eva/utils/eva_utils.mli b/src/plugins/eva/utils/eva_utils.mli
index e02e47c866017db14b252a76791b8f7cf046af87..2e3ab131c5c85d921a2eecf7bc1d6fa42912b002 100644
--- a/src/plugins/eva/utils/eva_utils.mli
+++ b/src/plugins/eva/utils/eva_utils.mli
@@ -25,13 +25,31 @@ open Cil_types
(** {2 Callstacks related types and functions} *)
(** Functions dealing with call stacks. *)
+
+(** Clears the current callstack: future accesses to the current callstack
+ will fail. *)
val clear_call_stack : unit -> unit
+
+(** Initializes the current callstack with the main entry point. *)
+val init_call_stack : kernel_function -> Callstack.t
+
+(** Push a new call to the current callstack. *)
+val push_call_stack : kernel_function -> stmt -> unit
+
+(** Removes the topmost call from the current callstack. *)
val pop_call_stack : unit -> unit
-val push_call_stack : kernel_function -> kinstr -> unit
-(** The current function is the one on top of the call stack. *)
+(** Returns the current function, at the top of the current callstack.
+ Fails if no callstack has been initialized. This should only be called
+ during the analysis of a function. *)
val current_kf : unit -> kernel_function
-val call_stack : unit -> Value_types.callstack
+
+(** Returns the current callstack; fails if it has not been initialized.
+ This should only be called during the analysis of a function. *)
+val current_call_stack : unit -> Callstack.t
+
+(** Returns the current callstack, or [None] if it has not been initialized. *)
+val current_call_stack_opt : unit -> Callstack.t option
(** Prints the current callstack. *)
val pp_callstack : Format.formatter -> unit
diff --git a/src/plugins/eva/utils/private.ml b/src/plugins/eva/utils/private.ml
index 3c28cfb69da993bfc8f99d62ffb18c3c4647359f..bb7d45ac49ff7e8a7bad98b07171ae33ef87585b 100644
--- a/src/plugins/eva/utils/private.ml
+++ b/src/plugins/eva/utils/private.ml
@@ -22,10 +22,14 @@
module Abstract_domain = Abstract_domain
module Abstract_value = Abstract_value
+module Abstract_location = Abstract_location
+module Abstract = Abstract
module Abstractions = Abstractions
module Active_behaviors = Active_behaviors
module Alarmset = Alarmset
module Analysis = Analysis
+module Callstack = Callstack
+module Cvalue_domain = Cvalue_domain
module Domain_builder = Domain_builder
module Eva_dynamic = Eva_dynamic
module Eva_results = Eva_results
diff --git a/src/plugins/eva/utils/private.mli b/src/plugins/eva/utils/private.mli
index 2012d89d2920890ab2e46f43185c330c2c050d7f..8fb57decf5b6c805f6776917c96f537c42709bc1 100644
--- a/src/plugins/eva/utils/private.mli
+++ b/src/plugins/eva/utils/private.mli
@@ -26,10 +26,14 @@
module Abstract_domain = Abstract_domain
module Abstract_value = Abstract_value
+module Abstract_location = Abstract_location
+module Abstract = Abstract
module Abstractions = Abstractions
module Active_behaviors = Active_behaviors
module Alarmset = Alarmset
module Analysis = Analysis
+module Callstack = Callstack
+module Cvalue_domain = Cvalue_domain
module Domain_builder = Domain_builder
module Eva_dynamic = Eva_dynamic
module Eva_results = Eva_results
diff --git a/src/plugins/eva/utils/red_statuses.ml b/src/plugins/eva/utils/red_statuses.ml
index dac25fbeb277d1236cb19281984c73c50a17f611..af80f2255c20882ec87a421a26b08ac8a7ddebc2 100644
--- a/src/plugins/eva/utils/red_statuses.ml
+++ b/src/plugins/eva/utils/red_statuses.ml
@@ -51,7 +51,9 @@ module AlarmOrProp = Datatype.Make_with_collections(struct
| Prop p -> 175 + Property.hash p
end)
-module Callstacks = Value_types.Callstack.Set
+module Info = struct let module_name = "CallstackOption" end
+module CallstackOption = Datatype.Option_with_collections (Callstack) (Info)
+module Callstacks = CallstackOption.Set
(* For each alarm or predicate, stores the set of callstacks for which it was
evaluated to False. *)
@@ -81,7 +83,8 @@ let add_red_ap kinstr ap =
try AlarmOrProp.Map.find ap current_map
with Not_found -> Callstacks.empty
in
- let new_callstacks = Callstacks.add (Eva_utils.call_stack ()) callstacks in
+ let new_callstacks =
+ Callstacks.add (Eva_utils.current_call_stack_opt ()) callstacks in
let new_map = AlarmOrProp.Map.add ap new_callstacks current_map in
RedStatusesTable.replace kinstr new_map;
Hook.apply ap
@@ -122,7 +125,7 @@ let is_red_in_callstack kinstr ap callstack =
try
let map = RedStatusesTable.find kinstr in
let callstacks = AlarmOrProp.Map.find ap map in
- Callstacks.mem callstack callstacks
+ Callstacks.mem (Some callstack) callstacks
with Not_found -> false
let get_all () =
diff --git a/src/plugins/eva/utils/red_statuses.mli b/src/plugins/eva/utils/red_statuses.mli
index d18cb14e1eb2b111a201654375f5d72a56540170..12ad7c0588ce8a549193d153bb8f8f5e8d17d807 100644
--- a/src/plugins/eva/utils/red_statuses.mli
+++ b/src/plugins/eva/utils/red_statuses.mli
@@ -40,7 +40,7 @@ val is_red: Property.t -> bool
(* Whether a red status has been emitted for an alarm or a property at the given
kinstr in the given callstack. *)
val is_red_in_callstack:
- kinstr -> alarm_or_property -> Value_types.callstack -> bool
+ kinstr -> alarm_or_property -> Callstack.t -> bool
(* Returns the unsorted list of all alarms and properties for which a red status
has been emitted during the analysis. Also returns the kinstr of the alarm or
diff --git a/src/plugins/eva/utils/results.ml b/src/plugins/eva/utils/results.ml
index 6133518219ca79430760b556261fb28f1329b98c..bc78a896d00c381e9616a2a675b4f7a6b3152029 100644
--- a/src/plugins/eva/utils/results.ml
+++ b/src/plugins/eva/utils/results.ml
@@ -28,10 +28,7 @@ let are_available kf =
| Analyzed (Complete | Partial) -> true
| SpecUsed | Builtin _ | Unreachable | Analyzed NoResults -> false
-module Callstack = Value_types.Callstack
-
-type callstack = Callstack.t
-type 'a by_callstack = (callstack * 'a) list
+type 'a by_callstack = (Callstack.t * 'a) list
type control_point =
| Initial
@@ -41,8 +38,8 @@ type control_point =
type context = {
control_point : control_point;
- selector : callstack list option;
- filter: (callstack -> bool) list;
+ selector : Callstack.t list option;
+ filter: (Callstack.t -> bool) list;
}
type request =
@@ -133,7 +130,7 @@ struct
| `Value state -> ByCallstack [cs,state]
let by_callstack : context ->
- [< `Bottom | `Top | `Value of 'a Value_types.Callstack.Hashtbl.t ] ->
+ [< `Bottom | `Top | `Value of 'a Callstack.Hashtbl.t ] ->
('a, restricted_to_callstack) t =
fun req -> function
| `Top -> Top
@@ -149,13 +146,13 @@ struct
(* Accessors *)
- let callstacks : ('a, restricted_to_callstack) t -> callstack list = function
+ let callstacks: ('a, restricted_to_callstack) t -> Callstack.t list = function
| Top | Bottom -> [] (* What else to do when Top is given ? *)
| ByCallstack l -> List.map fst l
(* Fold *)
- let fold (f : callstack -> 'a -> 'b -> 'b) (acc : 'b) :
+ let fold (f : Callstack.t -> 'a -> 'b -> 'b) (acc : 'b) :
('a, restricted_to_callstack) t -> 'b =
function
| Top | Bottom -> acc (* What else to do when Top is given ? *)
@@ -245,7 +242,8 @@ struct
A.get_stmt_state_by_callstack ?selection ~after:true stmt
|> by_callstack ctx
| Initial ->
- A.get_global_state () |> singleton []
+ let cs = Callstack.init (fst (Globals.entry_point ())) in
+ A.get_global_state () |> singleton cs
| Start kf ->
A.get_initial_state_by_callstack ?selection kf |> by_callstack ctx
@@ -314,10 +312,11 @@ struct
convert r
let get_cvalue_model req =
- match A.Dom.get_cvalue with
+ match A.Dom.get Cvalue_domain.State.key with
| None ->
Result.error DisabledDomain
| Some extract ->
+ let extract s = extract s |> fst in
convert (Response.map_join extract Cvalue.Model.join (get req))
let get_state req key join =
diff --git a/src/plugins/eva/utils/results.mli b/src/plugins/eva/utils/results.mli
index eb362d580b9c100f1c60c2057e8dd5d866e5415b..122dfe95a676937703d5ddf4261f7a88147923c1 100644
--- a/src/plugins/eva/utils/results.mli
+++ b/src/plugins/eva/utils/results.mli
@@ -63,8 +63,6 @@
all requests in the function will lead to a Top error. *)
val are_available : Cil_types.kernel_function -> bool
-type callstack = (Cil_types.kernel_function * Cil_types.kinstr) list
-
type request
type value
@@ -127,16 +125,16 @@ val in_cvalue_state : Cvalue.Model.t -> request
(** Only consider the given callstack.
Replaces previous calls to [in_callstack] or [in_callstacks]. *)
-val in_callstack : callstack -> request -> request
+val in_callstack : Callstack.t -> request -> request
(** Only consider the callstacks from the given list.
Replaces previous calls to [in_callstack] or [in_callstacks]. *)
-val in_callstacks : callstack list -> request -> request
+val in_callstacks : Callstack.t list -> request -> request
(** Only consider callstacks satisfying the given predicate. Several filters
can be added. If callstacks are also selected with [in_callstack] or
[in_callstacks], only the selected callstacks will be filtered. *)
-val filter_callstack : (callstack -> bool) -> request -> request
+val filter_callstack : (Callstack.t -> bool) -> request -> request
(** Working with callstacks *)
@@ -146,11 +144,11 @@ val filter_callstack : (callstack -> bool) -> request -> request
reached by the analysis, or if no information has been saved at this point
(for instance with the -eva-no-results option).
Use [is_empty request] to distinguish these two cases. *)
-val callstacks : request -> callstack list
+val callstacks : request -> Callstack.t list
(** Returns a list of subrequests for each reachable callstack from
the given request. *)
-val by_callstack : request -> (callstack * request) list
+val by_callstack : request -> (Callstack.t * request) list
(** State requests *)
diff --git a/src/plugins/eva/utils/summary.ml b/src/plugins/eva/utils/summary.ml
index 6b2dd8e93b090a26e55b7d5b7b9ea94320bb32c2..5462206ea9e00f519b3b10d5c845c946f877bbf9 100644
--- a/src/plugins/eva/utils/summary.ml
+++ b/src/plugins/eva/utils/summary.ml
@@ -211,19 +211,10 @@ module FunctionStats = struct
let size = 17
end)
- module Hook = Hook.Build (struct
- type t = Cil_types.fundec * fun_stats
- end)
-
- let compute kf =
- let stats = compute_fun_stats kf in
- Hook.apply (kf,stats);
- stats
let get kf =
try Some (find kf)
with Not_found -> None
- let recompute kf = replace kf (compute kf)
- let register_hook = Hook.extend
+ let recompute kf = replace kf (compute_fun_stats kf)
end
diff --git a/src/plugins/eva/utils/summary.mli b/src/plugins/eva/utils/summary.mli
index c9bd45a364d1a3af0b5f56fc8264b09f08519c24..eea1b0df3d35924182505108fc8473281b13a9aa 100644
--- a/src/plugins/eva/utils/summary.mli
+++ b/src/plugins/eva/utils/summary.mli
@@ -65,17 +65,21 @@ type program_stats =
preconds_statuses: statuses; }
module FunctionStats : sig
+ type key = Cil_types.fundec
+ type data = fun_stats
+
(** Get the current analysis statistics for a function *)
- val get: Cil_types.fundec -> fun_stats option
+ val get: key -> data option
(** Iterate on every function statistics *)
- val iter: (Cil_types.fundec -> fun_stats -> unit) -> unit
+ val iter: (key -> data -> unit) -> unit
(** Trigger the recomputation of function stats *)
- val recompute: Cil_types.fundec -> unit
+ val recompute: key -> unit
(** Set a hook on function statistics computation *)
- val register_hook: (Cil_types.fundec * fun_stats -> unit) -> unit
+ val add_hook_on_change:
+ ((key, data) State_builder.hashtbl_event -> unit) -> unit
end
(** Compute analysis statistics. *)
diff --git a/src/plugins/eva/values/abstract_location.ml b/src/plugins/eva/values/abstract_location.ml
index 1cbc439a1f8dbd7e5dc4b23904dc88ff6ded3d36..96f75b0855b0a349b275184a43fdf895de104826 100644
--- a/src/plugins/eva/values/abstract_location.ml
+++ b/src/plugins/eva/values/abstract_location.ml
@@ -44,7 +44,7 @@ module type S = sig
val pretty_loc: Format.formatter -> location -> unit
val pretty_offset : Format.formatter -> offset -> unit
- val to_value : location -> value
+ val to_value : location -> value or_bottom
val size : location -> Int_Base.t
(** [replace_base substitution location] replaces the variables represented
@@ -134,8 +134,19 @@ module type Leaf = sig
(** The key identifies the module and the type [t] of abstract locations. *)
val key: location key
+
+ (** The abstract value on which this location depends. *)
+ val value: value Abstract_value.dependencies
end
+(** Eva abstractions are divided between values, locations and domains.
+ Domains depend on locations, and use this type to declare such dependencies.
+ In the standard case, a domain depends on a single location module [Loc]
+ and uses [Leaf (module Loc)] to declare this dependency. *)
+type 'l dependencies =
+ | Leaf: (module Leaf with type location = 'l) -> 'l dependencies
+ | Node: 'l dependencies * 'r dependencies -> ('l * 'r) dependencies
+
(*
Local Variables:
compile-command: "make -C ../../../.."
diff --git a/src/plugins/eva/values/abstract_value.ml b/src/plugins/eva/values/abstract_value.ml
index 536a009958959fd69e9d70449cba7d11c23610c2..e63cc2c575d9c80f65234f92f420cc9da1b3248e 100644
--- a/src/plugins/eva/values/abstract_value.ml
+++ b/src/plugins/eva/values/abstract_value.ml
@@ -206,6 +206,14 @@ module type Leaf = sig
val key: t key
end
+(** Eva abstractions are divided between values, locations and domains.
+ Locations and domains depend on values, and use this type to declare such
+ dependencies. In the standard case, a domain depends on a single value
+ module [V] and uses [Leaf (module V)] to declare this dependency. *)
+type 'v dependencies =
+ | Leaf: (module Leaf with type t = 'v) -> 'v dependencies
+ | Node: 'l dependencies * 'r dependencies -> ('l * 'r) dependencies
+
(*
Local Variables:
diff --git a/src/plugins/eva/values/location_lift.ml b/src/plugins/eva/values/location_lift.ml
index 5aaee286c0d3d1178a417fcd8e8d7663883e6e7b..769faab7a8c797b552699a8a3ea996bee1c9812c 100644
--- a/src/plugins/eva/values/location_lift.ml
+++ b/src/plugins/eva/values/location_lift.ml
@@ -23,17 +23,16 @@
open Eval
module type Conversion = sig
- type extended_value
- type internal_value
-
- val extend_val : internal_value -> extended_value
- val replace_val : internal_value -> extended_value -> extended_value
- val restrict_val : extended_value -> internal_value
+ type extended
+ type internal
+ val extend : internal -> extended
+ val replace : internal -> extended -> extended
+ val restrict : extended -> internal
end
module Make
(Loc: Abstract_location.Leaf)
- (Convert : Conversion with type internal_value := Loc.value)
+ (Convert : Conversion with type internal := Loc.value)
= struct
(* Import most of [Loc] *)
@@ -41,29 +40,29 @@ module Make
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
+ type value = Convert.extended
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)
+ let to_value loc = Loc.to_value loc >>-: Convert.extend
let forward_index typ value offset =
- Loc.forward_index typ (Convert.restrict_val value) offset
+ Loc.forward_index typ (Convert.restrict value) offset
let forward_pointer typ value offset =
- Loc.forward_pointer typ (Convert.restrict_val value) offset
+ Loc.forward_pointer typ (Convert.restrict value) offset
let backward_pointer value offset loc =
- let v = Convert.restrict_val value in
+ let v = Convert.restrict value in
Loc.backward_pointer v offset loc >>-: fun (v, off) ->
- Convert.replace_val v value, off
+ Convert.replace v value, off
let backward_index typ ~index:value ~remaining offset =
- let index = Convert.restrict_val value in
+ let index = Convert.restrict value in
Loc.backward_index typ ~index ~remaining offset >>-: fun (v, off) ->
- Convert.replace_val v value, off
+ Convert.replace v value, off
end
diff --git a/src/plugins/eva/values/location_lift.mli b/src/plugins/eva/values/location_lift.mli
index 34b80aaa11daac14e7796e10184b66b6bd645e1d..d66d68fb6ca44873bbf1c31eb0ce6943bad92227 100644
--- a/src/plugins/eva/values/location_lift.mli
+++ b/src/plugins/eva/values/location_lift.mli
@@ -21,20 +21,19 @@
(**************************************************************************)
module type Conversion = sig
- type extended_value
- type internal_value
-
- val extend_val : internal_value -> extended_value
- val replace_val : internal_value -> extended_value -> extended_value
- val restrict_val : extended_value -> internal_value
+ type extended
+ type internal
+ val extend : internal -> extended
+ val replace : internal -> extended -> extended
+ val restrict : extended -> internal
end
module Make
(Loc: Abstract_location.Leaf)
- (Convert : Conversion with type internal_value := Loc.value)
+ (Convert : Conversion with type internal := Loc.value)
: Abstract.Location.Internal with type location = Loc.location
and type offset = Loc.offset
- and type value = Convert.extended_value
+ and type value = Convert.extended
(*
diff --git a/src/plugins/eva/values/main_locations.ml b/src/plugins/eva/values/main_locations.ml
index 92d31c7f54b1baeaaf2723e373815aef3cd9bfc3..7f5404f77806cdf22a94ca10c036c481260ad58e 100644
--- a/src/plugins/eva/values/main_locations.ml
+++ b/src/plugins/eva/values/main_locations.ml
@@ -28,8 +28,6 @@ module PLoc = struct
| Precise of Precise_locs.precise_offset
| Imprecise of Cvalue.V.t (* when the offset contains addresses *)
- 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
| Precise o1, Precise o2 -> Precise_locs.equal_offset o1 o2
@@ -43,7 +41,7 @@ module PLoc = struct
let to_value t =
let loc = Precise_locs.imprecise_location t in
- Locations.loc_to_loc_without_size loc
+ `Value (Locations.loc_to_loc_without_size loc)
let size loc = Precise_locs.loc_size loc
@@ -236,8 +234,12 @@ module PLoc = struct
(* No reduction if the offsets are not arithmetics. *)
with Cvalue.V.Not_based_on_null -> `Value (index, remaining)
+ let key = Structure.Key_Location.create_key "precise_locs"
+
+ let value = Abstract_value.Leaf (module Main_values.CVal)
end
+let ploc = Abstract_location.Leaf (module PLoc)
(*
Local Variables:
diff --git a/src/plugins/eva/values/main_locations.mli b/src/plugins/eva/values/main_locations.mli
index 4d95a9933e380e44166fae2d006cc0ce957b77a8..c288fecaebe43ac363756fb9cc8d1f60be8135cf 100644
--- a/src/plugins/eva/values/main_locations.mli
+++ b/src/plugins/eva/values/main_locations.mli
@@ -20,19 +20,19 @@
(* *)
(**************************************************************************)
-(** Main memory locations of Eva: *)
+(** Main memory locations of Eva that can be used by abstract domains. *)
(** Abstract locations built over Precise_locs. *)
module PLoc : sig
-
include Abstract_location.Leaf
with type value = Cvalue.V.t
and type location = Precise_locs.precise_location
val make: Locations.location -> location
-
end
+val ploc: PLoc.location Abstract_location.dependencies
+
(*
Local Variables:
compile-command: "make -C ../../../.."
diff --git a/src/plugins/eva/values/main_values.ml b/src/plugins/eva/values/main_values.ml
index fdd47e5052ce7028de7f6f1cb341b4fc0f9a0012..bdb449966dc64ce435b7d515ab11d963e2e9cc2a 100644
--- a/src/plugins/eva/values/main_values.ml
+++ b/src/plugins/eva/values/main_values.ml
@@ -25,8 +25,6 @@ open Cil_types
module CVal = struct
include Cvalue.V
- let key = Structure.Key_Value.create_key "cvalue"
-
let zero = Cvalue.V.singleton_zero
let one = Cvalue.V.singleton_one
@@ -134,12 +132,15 @@ module CVal = struct
with Abstract_interp.Error_Top -> `Top, true
let replace_base substitution t = snd (Cvalue.V.replace_base substitution t)
+
+ let key = Structure.Key_Value.create_key "cvalue"
end
-module Interval = struct
+let cval = Abstract_value.Leaf (module CVal)
+
+module Interval = struct
include Datatype.Option (Ival)
- let key = Structure.Key_Value.create_key "interval"
let pretty_typ _ = pretty
@@ -192,8 +193,15 @@ module Interval = struct
`Value (None, None)
let backward_cast ~src_typ:_ ~dst_typ:_ ~src_val:_ ~dst_val:_ =
`Value None
+
+ let key = Structure.Key_Value.create_key "interval"
end
+let ival = Abstract_value.Leaf (module Interval)
+
+module Sign = Sign_value
+let sign = Abstract_value.Leaf (module Sign)
+
(*
Local Variables:
compile-command: "make -C ../../../.."
diff --git a/src/plugins/eva/values/main_values.mli b/src/plugins/eva/values/main_values.mli
index dc71abad115a51b916cab31f719006fe27921f29..41fe9c06e0ce50aa889d77871517a9045772802d 100644
--- a/src/plugins/eva/values/main_values.mli
+++ b/src/plugins/eva/values/main_values.mli
@@ -20,14 +20,20 @@
(* *)
(**************************************************************************)
-(** Main numeric values of Eva. *)
+(** Main numeric values of Eva that can be used by abstract domains. *)
-(** Abstract values built over Cvalue.V *)
-module CVal : Abstract_value.Leaf with type t = Cvalue.V.t
+(** Main abstract values built over Cvalue.V, used by most domains. *)
+module CVal: Abstract_value.Leaf with type t = Cvalue.V.t
+val cval: CVal.t Abstract_value.dependencies
-(** Dummy interval: no forward nor backward propagations.
- [None] is top. *)
-module Interval : Abstract_value.Leaf with type t = Ival.t option
+(** Dummy intervals: no forward nor backward propagations,
+ only used as a reduced product with CVal above. [None] is top. *)
+module Interval: Abstract_value.Leaf with type t = Ival.t option
+val ival: Interval.t Abstract_value.dependencies
+
+(** Simple sign values, used by the sign domain. *)
+module Sign: Abstract_value.Leaf with type t = Sign_value.t
+val sign: Sign.t Abstract_value.dependencies
(*
Local Variables:
diff --git a/src/plugins/eva/values/offsm_value.ml b/src/plugins/eva/values/offsm_value.ml
index 35ddb8f38afc8051fb2a606e551258c3ab7753b8..fa44973302f440c4f8e266b00cfa086561421d19 100644
--- a/src/plugins/eva/values/offsm_value.ml
+++ b/src/plugins/eva/values/offsm_value.ml
@@ -372,8 +372,6 @@ module Datatype_Offsm_or_top = Datatype.Make_with_collections(struct
module Offsm : Abstract_value.Leaf with type t = offsm_or_top = struct
include Datatype_Offsm_or_top
- let key = Structure.Key_Value.create_key "offsetmap_value"
-
let pretty_typ typ fmt = function
| Top as o -> pretty fmt o
| O o ->
@@ -469,75 +467,84 @@ module Offsm : Abstract_value.Leaf with type t = offsm_or_top = struct
`Value (O (cast ~old_size ~new_size ~signed o))
| _ -> `Value Top
+ let key = Structure.Key_Value.create_key "offsetmap_value"
end
-
-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. *)
- let to_offsm typ (v, o : t) =
- match o with
- | Top -> inject ~size:(size typ) v
- | O o -> o
-
- (* Ensure that the offsetmap component is not empty *)
- let strengthen_offsm typ (v, o as p : t) : t =
- if o = Top then
- (v, O (to_offsm typ p))
- else p
-
- (* Refine the value component according to the contents of the offsetmap *)
- let strengthen_v typ (v, o as p : t) : t or_bottom =
- match o with
- | Top -> `Value p
- | O o' ->
- let size = size typ in
- (* TODO: this should be done by the transfer function itself... *)
- let v = Cvalue_forward.reinterpret typ v in
- let v_o = V_Or_Uninitialized.get_v (basic_find ~size o') in
- let v_o = Cvalue_forward.reinterpret typ v_o in
- let v = V.narrow v v_o in
- if V.is_bottom v then `Bottom else `Value (v, o)
-
- let forward_unop typ op p =
- match op with
- | BNot ->
- let p' = strengthen_offsm typ p in
- forward_unop typ op p' >>- fun p'' ->
- strengthen_v typ p''
- | _ -> forward_unop typ op p
-
- let forward_binop typ op l r =
- match op with
- | BAnd | BOr | BXor ->
- let l = strengthen_offsm typ l in
- let r = strengthen_offsm typ r in
- forward_binop typ op l r >>- fun p ->
- strengthen_v typ p
- | Shiftlt | Shiftrt ->
- let (v_r, _) = r in
- let (v_l, _) = l in
- begin
- try
- let i = V.project_ival v_r in
- let i = Ival.project_int i in
- let size = size typ in
- let signed = Bit_utils.is_signed_int_enum_pointer typ in
- let dir = if op = Shiftlt then Left else Right in
- let o = shift ~size ~signed (to_offsm typ l) dir i in
- Main_values.CVal.forward_binop typ op v_l v_r >>-: fun v ->
- v, O o
- with V.Not_based_on_null | Ival.Not_Singleton_Int ->
- forward_binop typ op l r
- end
- | _ -> forward_binop typ op l r
-
-end
+(* -------------------------------------------------------------------------- *)
+(* Reduced product between Cvalues and Offsetmaps values *)
+(* -------------------------------------------------------------------------- *)
+
+let size typ = Integer.of_int (Cil.bitsSizeOf typ)
+
+(* Extract an offsetmap from a pair, by converting the value when needed. *)
+let to_offsm typ v = function
+ | Top -> inject ~size:(size typ) v
+ | O o -> o
+
+(* Refine the cvalue according to the contents of the offsetmap. *)
+let strengthen_v typ v offsm : Cvalue.V.t or_bottom =
+ let size = size typ in
+ (* TODO: this should be done by the transfer function itself... *)
+ let v = Cvalue_forward.reinterpret typ v in
+ let v_o = V_Or_Uninitialized.get_v (basic_find ~size offsm) in
+ let v_o = Cvalue_forward.reinterpret typ v_o in
+ let v = V.narrow v v_o in
+ if V.is_bottom v then `Bottom else `Value v
+
+let () = Abstractions.Hooks.register @@ fun (module Abstraction) ->
+ let module Val = Abstraction.Val in
+ match Val.get Main_values.CVal.key, Val.get Offsm.key with
+ | None, _ | _, None -> (module Abstraction)
+ | Some get_cvalue, Some get_offsm ->
+ let module Value = struct
+ include Abstraction.Val
+
+ let set_cvalue = set Main_values.CVal.key
+ let set_offsm = set Offsm.key
+
+ let to_offsm typ t = to_offsm typ (get_cvalue t) (get_offsm t)
+
+ (* Ensure that the offsetmap component is not empty. *)
+ let strengthen_offsm typ t = set_offsm (O (to_offsm typ t)) t
+
+ (* Refine the cvalue component according to the offsetmap component. *)
+ let strengthen_v typ t =
+ match get_offsm t with
+ | Top -> `Value t
+ | O o ->
+ let* v = strengthen_v typ (get_cvalue t) o in
+ `Value (set_cvalue v t)
+
+ let forward_unop typ op t =
+ match op with
+ | BNot ->
+ let t = strengthen_offsm typ t in
+ let* t = forward_unop typ op t in
+ strengthen_v typ t
+ | _ -> forward_unop typ op t
+
+ let forward_binop typ op l r =
+ match op with
+ | BAnd | BOr | BXor ->
+ let l = strengthen_offsm typ l
+ and r = strengthen_offsm typ r in
+ let* t = forward_binop typ op l r in
+ strengthen_v typ t
+ | Shiftlt | Shiftrt ->
+ let* p = forward_binop typ op l r in
+ begin
+ try
+ let i = get_cvalue r |> V.project_ival |> Ival.project_int in
+ let size = size typ in
+ let signed = Bit_utils.is_signed_int_enum_pointer typ in
+ let dir = if op = Shiftlt then Left else Right in
+ let offsm = shift ~size ~signed (to_offsm typ l) dir i in
+ `Value (set_offsm (O offsm) p)
+ with V.Not_based_on_null | Ival.Not_Singleton_Int -> `Value p
+ end
+ | _ -> forward_binop typ op l r
+ end in
+ (module struct
+ include Abstraction
+ module Val = Value
+ end)
diff --git a/src/plugins/eva/values/offsm_value.mli b/src/plugins/eva/values/offsm_value.mli
index cae5bd0efeec1484b5605279916b1ab56403e7c5..fa9b4ef0b4172c9d55e5a6d4562fe6f47871971c 100644
--- a/src/plugins/eva/values/offsm_value.mli
+++ b/src/plugins/eva/values/offsm_value.mli
@@ -27,5 +27,3 @@ val cast :
Cvalue.V_Offsetmap.t -> Cvalue.V_Offsetmap.t
module Offsm : Abstract_value.Leaf with type t = offsm_or_top
-
-module CvalueOffsm : Abstract.Value.Internal with type t = Cvalue.V.t * offsm_or_top
diff --git a/src/plugins/eva/values/sign_value.ml b/src/plugins/eva/values/sign_value.ml
index d60458ec1e0ed6eeb36d4bb26b0b54476b6ad2d8..fdb788c8506f0aec6f0658211b7f3b140032edcc 100644
--- a/src/plugins/eva/values/sign_value.ml
+++ b/src/plugins/eva/values/sign_value.ml
@@ -338,8 +338,5 @@ let backward_unop ~typ_arg:_ _op ~arg:_ ~res:_ = `Value None
(* Not implemented precisely *)
let backward_cast ~src_typ:_ ~dst_typ:_ ~src_val:_ ~dst_val:_ = `Value None
-
-(** {2 Misc} *)
-
(* Eva boilerplate, used to retrieve the domain. *)
let key = Structure.Key_Value.create_key "sign_values"
diff --git a/src/plugins/eva/values/sign_value.mli b/src/plugins/eva/values/sign_value.mli
index aa4030e1e386fdf7d2ee8e05e1f65fdbd6d63d85..26a9145bc44fa0c9ee80cd1b8523bbe291924285 100644
--- a/src/plugins/eva/values/sign_value.mli
+++ b/src/plugins/eva/values/sign_value.mli
@@ -29,5 +29,4 @@ type signs = {
}
include Abstract_value.Leaf with type t = signs
-
val pretty_debug: t Pretty_utils.formatter
diff --git a/src/plugins/eva/values/value_product.ml b/src/plugins/eva/values/value_product.ml
index d0f99098c43092082b9c585ceebec1623ca6ba34..8f2101a68cd756802b98f379afae7fbefb4d47f9 100644
--- a/src/plugins/eva/values/value_product.ml
+++ b/src/plugins/eva/values/value_product.ml
@@ -22,6 +22,28 @@
open Eval
+(* Intersects the truth values [t1] and [t2] coming from [assume_] functions
+ from both abstract values. [v1] and [v2] are the initial values leading to
+ these truth values, that may be reduced by the assumption. [combine]
+ combines values from both abstract values into values of the product. *)
+let narrow_any_truth combine (v1, t1) (v2, t2) = match t1, t2 with
+ | `Unreachable, _ | _, `Unreachable
+ | (`True | `TrueReduced _), `False
+ | `False, (`True | `TrueReduced _) -> `Unreachable
+ | `False, _ | _, `False -> `False
+ | `Unknown v1, `Unknown v2 -> `Unknown (combine v1 v2)
+ | (`Unknown v1 | `TrueReduced v1), `True -> `TrueReduced (combine v1 v2)
+ | `True, (`Unknown v2 | `TrueReduced v2) -> `TrueReduced (combine v1 v2)
+ | (`Unknown v1 | `TrueReduced v1),
+ (`Unknown v2 | `TrueReduced v2) -> `TrueReduced (combine v1 v2)
+ | `True, `True -> `True
+
+let narrow_truth x y = narrow_any_truth (fun left right -> left, right) x y
+
+let narrow_truth_pair x y =
+ let combine (l1, l2) (r1, r2) = (l1, r1), (l2, r2) in
+ narrow_any_truth combine x y
+
module Make
(Left: Abstract_value.S)
(Right: Abstract_value.S)
@@ -48,24 +70,6 @@ module Make
let top_int = Left.top_int, Right.top_int
let inject_int typ i = Left.inject_int typ i, Right.inject_int typ i
- (* Intersects the truth values [t1] and [t2] coming from [assume_] functions
- from both abstract values. [v1] and [v2] are the initial values leading to
- these truth values, that may be reduced by the assumption. [combine]
- combines values from both abstract values into values of the product. *)
- let narrow_any_truth combine (v1, t1) (v2, t2) = match t1, t2 with
- | `Unreachable, _ | _, `Unreachable
- | (`True | `TrueReduced _), `False
- | `False, (`True | `TrueReduced _) -> `Unreachable
- | `False, _ | _, `False -> `False
- | `Unknown v1, `Unknown v2 -> `Unknown (combine v1 v2)
- | (`Unknown v1 | `TrueReduced v1), `True -> `TrueReduced (combine v1 v2)
- | `True, (`Unknown v2 | `TrueReduced v2) -> `TrueReduced (combine v1 v2)
- | (`Unknown v1 | `TrueReduced v1),
- (`Unknown v2 | `TrueReduced v2) -> `TrueReduced (combine v1 v2)
- | `True, `True -> `True
-
- let narrow_truth = narrow_any_truth (fun left right -> left, right)
-
let assume_non_zero (left, right) =
let left_truth = Left.assume_non_zero left
and right_truth = Right.assume_non_zero right in
@@ -89,8 +93,7 @@ module Make
let assume_comparable op (l1, r1) (l2, r2) =
let left_truth = Left.assume_comparable op l1 l2
and right_truth = Right.assume_comparable op r1 r2 in
- let combine (l1, l2) (r1, r2) = (l1, r1), (l2, r2) in
- narrow_any_truth combine ((l1, l2), left_truth) ((r1, r2), right_truth)
+ narrow_truth_pair ((l1, l2), left_truth) ((r1, r2), right_truth)
let constant expr constant =
let left = Left.constant expr constant
diff --git a/src/plugins/eva/values/value_product.mli b/src/plugins/eva/values/value_product.mli
index 43aca79e8140ec25f9c5ea50b33a68ba157a42f8..f53f265b25b1670f777045be22892c8f096c665b 100644
--- a/src/plugins/eva/values/value_product.mli
+++ b/src/plugins/eva/values/value_product.mli
@@ -22,6 +22,18 @@
(** Cartesian product of two value abstractions. *)
+type 'v truth := 'v Abstract_value.truth
+
+(** [narrow_truth (v1, t1) (v2, t2)] intersects the truth values [t1] and [t2]
+ resulting from [assume_] functions for abstract values [v1] and [v2]
+ (that may be reduced by the assumption). *)
+val narrow_truth: 'a * 'a truth -> 'b * 'b truth -> ('a * 'b) truth
+
+(** Same as narrow_truth for truth values involving pairs of abstract values. *)
+val narrow_truth_pair:
+ ('a * 'a) * ('a * 'a) truth -> ('b * 'b) * ('b * 'b) truth ->
+ (('a * 'b) * ('a * 'b)) truth
+
module Make
(Left: Abstract_value.S)
(Right: Abstract_value.S)
diff --git a/src/plugins/from/callwise.ml b/src/plugins/from/callwise.ml
index 3d84dfa8af17e98be504a70776c3cd68e2fc023c..0e5d37b4d35d0d8aaf6bd1613548ee7cd526d7d2 100644
--- a/src/plugins/from/callwise.ml
+++ b/src/plugins/from/callwise.ml
@@ -44,8 +44,6 @@ let merge_call_froms table callsite froms =
(** State for the analysis of one function call *)
type from_state = {
current_function: Kernel_function.t (** Function being analyzed *);
- value_initial_state: Cvalue.Model.t (** State of Eva at the beginning of
- the call *);
table_for_calls: Function_Froms.t Kinstr.Hashtbl.t
(** State of the From plugin for each statement containing a function call
in the body of [current_function]. Updated incrementally each time
@@ -64,59 +62,36 @@ let record_callwise_dependencies_in_db call_site froms =
Tbl.replace call_site (Function_Froms.join previous froms)
with Not_found -> Tbl.add call_site froms
-let call_for_individual_froms callstack _kf call_type value_initial_state =
+let call_for_individual_froms _callstack current_function _state call_type =
if From_parameters.ForceCallDeps.get () then begin
- let current_function, call_site = List.hd callstack in
- let register_from froms =
- record_callwise_dependencies_in_db call_site froms;
- match !call_froms_stack with
- | { table_for_calls } :: _ ->
- merge_call_froms table_for_calls call_site froms;
- | [] ->
- (* Empty call stack: this is the main entry point with no call site. *)
- assert (call_site = Cil_types.Kglobal);
- in
- let compute_from_behaviors bhv =
- let assigns = Ast_info.merge_assigns bhv in
- let froms =
- From_compute.compute_using_prototype_for_state
- value_initial_state current_function assigns
- in
- register_from froms
- in
match call_type with
- | `Def | `Memexec ->
+ | `Body ->
let table_for_calls = Kinstr.Hashtbl.create 7 in
call_froms_stack :=
- { current_function; value_initial_state; table_for_calls } ::
- !call_froms_stack
- | `Builtin (Some (result,_)) ->
- register_from result
- | `Builtin None ->
- let behaviors =
- Eva.Logic_inout.valid_behaviors current_function value_initial_state
- in
- compute_from_behaviors behaviors
- | `Spec spec ->
- compute_from_behaviors spec.Cil_types.spec_behavior
+ { current_function; table_for_calls } :: !call_froms_stack
+ | `Reuse | `Builtin | `Spec -> ()
end
-let end_record call_stack froms =
- let (current_function_value, call_site) = List.hd call_stack in
- record_callwise_dependencies_in_db call_site froms;
- (* pop + record in top of stack the froms of function that just finished *)
+let pop_local_table kf =
match !call_froms_stack with
- | {current_function} :: ({table_for_calls = table} :: _ as tail) ->
- if current_function_value != current_function then
+ | { current_function } :: tail ->
+ if kf != current_function then
From_parameters.fatal "calldeps %a != %a@."
- Kernel_function.pretty current_function
- Kernel_function.pretty current_function_value;
- call_froms_stack := tail;
- merge_call_froms table call_site froms
-
- | _ -> (* the entry point, probably *)
- Tbl.mark_as_computed ();
- call_froms_stack := []
+ Kernel_function.pretty current_function Kernel_function.pretty kf;
+ call_froms_stack := tail
+ | _ -> From_parameters.fatal "calldeps: internal stack is empty"
+
+let end_record callstack froms =
+ let callsite = Eva.Callstack.top_callsite callstack in
+ record_callwise_dependencies_in_db callsite froms;
+ match callsite, !call_froms_stack with
+ | Kstmt _, { table_for_calls } :: _ ->
+ merge_call_froms table_for_calls callsite froms
+ | Kglobal, [] -> (* the entry point *)
+ Tbl.mark_as_computed ()
+ | _ ->
+ From_parameters.fatal
+ "calldeps: internal stack is inconsistent with Eva callstack"
module MemExec =
@@ -152,29 +127,31 @@ let compute_call_from_value_states current_function states =
Callwise_Froms.compute_and_return current_function
-let record_for_individual_froms callstack cur_kf value_res =
+let record_for_individual_froms callstack kf pre_state value_res =
if From_parameters.ForceCallDeps.get () then begin
- let froms = match value_res with
- | Eva.Cvalue_callbacks.Store ({before_stmts}, memexec_counter) ->
+ let froms =
+ match value_res with
+ | `Body (Eva.Cvalue_callbacks.{before_stmts}, memexec_counter) ->
let froms =
- if Eva.Analysis.save_results cur_kf
- then compute_call_from_value_states cur_kf (Lazy.force before_stmts)
+ if Eva.Analysis.save_results kf
+ then compute_call_from_value_states kf (Lazy.force before_stmts)
else Function_Froms.top
in
- let pre_state = match !call_froms_stack with
- | [] -> assert false
- | { value_initial_state } :: _ -> value_initial_state
- in
if From_parameters.VerifyAssigns.get () then
- Eva.Logic_inout.verify_assigns cur_kf ~pre:pre_state froms;
+ Eva.Logic_inout.verify_assigns kf ~pre:pre_state froms;
MemExec.replace memexec_counter froms;
+ pop_local_table kf;
froms
-
- | Reuse counter ->
- MemExec.find counter
+ | `Reuse counter -> MemExec.find counter
+ | `Builtin (_states, Some (result,_)) -> result
+ | `Builtin (_states, None)
+ | `Spec _states ->
+ let bhv = Eva.Logic_inout.valid_behaviors kf pre_state in
+ let assigns = Ast_info.merge_assigns bhv in
+ From_compute.compute_using_prototype_for_state
+ pre_state kf assigns
in
end_record callstack froms
-
end
diff --git a/src/plugins/gui/design.ml b/src/plugins/gui/design.ml
index d9e13758325b50ceeb393c0d654d61e97542e8bb..2442eb86f7141a0e31f1af8e7d7047843abaa5d5 100644
--- a/src/plugins/gui/design.ml
+++ b/src/plugins/gui/design.ml
@@ -1891,27 +1891,26 @@ let toplevel play =
let error_manager =
new Gtk_helper.error_manager (splash_w:>GWindow.window_skel)
in
- let init_crashed = ref true in
+ let init_crash = ref None in
error_manager#protect
~cancelable:true ~parent:(splash_w:>GWindow.window_skel)
(fun () ->
- (try
- play ();
- (* This is a good point to start using real asynchronous tasks
- management: plug-ins launched from command line have finished
- their asynchronous tasks thanks to the default Task.on_idle. *)
- Task.on_idle :=
- (fun f -> ignore (Glib.Timeout.add ~ms:50 ~callback:f));
- let project_name = Gui_parameters.Project_name.get () in
- if project_name = "" then
- Project.set_current_as_last_created ()
- else
- Project.set_current (Project.from_unique_name project_name);
- Ast.compute ()
- with e -> (* An error occurred: we need to enforce the splash screen
- realization before we create the error dialog widget.*)
- force_s (); raise e);
- init_crashed := false);
+ try
+ play ();
+ (* This is a good point to start using real asynchronous tasks
+ management: plug-ins launched from command line have finished
+ their asynchronous tasks thanks to the default Task.on_idle. *)
+ Task.on_idle :=
+ (fun f -> ignore (Glib.Timeout.add ~ms:50 ~callback:f));
+ let project_name = Gui_parameters.Project_name.get () in
+ if project_name = "" then
+ Project.set_current_as_last_created ()
+ else
+ Project.set_current (Project.from_unique_name project_name);
+ Ast.compute ()
+ with e -> (* An error occurred: we need to enforce the splash screen
+ realization before we create the error dialog widget.*)
+ force_s (); init_crash := Some e; raise e);
if Ast.is_computed () then
(* if the ast has parsed, but a plugin has crashed, we display the gui *)
error_manager#protect ~cancelable:false
@@ -1921,18 +1920,18 @@ let toplevel play =
Glib.Timeout.remove tid;
reparent_console main_ui#lower_notebook;
splash_w#destroy ();
- (* Display the console if a crash has occurred. Otherwise, display
- the information panel *)
- if !init_crashed then
- (main_ui#lower_notebook#goto_page 2;
- (* BY TODO: this should scroll to the end of the console. It
- does not work at all after the reparent, and only partially
- before (scrollbar is wrong) *)
- let end_console = splash_out#buffer#end_iter in
- ignore (splash_out#scroll_to_iter ~yalign:0. end_console)
- )
- else
- main_ui#lower_notebook#goto_page 0
+ (* Display the console and an error dialog if a crash has occurred.
+ Otherwise, display the information panel. *)
+ match !init_crash with
+ | None -> main_ui#lower_notebook#goto_page 0
+ | Some e ->
+ main_ui#lower_notebook#goto_page 2;
+ (* BY TODO: this should scroll to the end of the console. It
+ does not work at all after the reparent, and only partially
+ before (scrollbar is wrong) *)
+ let end_console = splash_out#buffer#end_iter in
+ ignore (splash_out#scroll_to_iter ~yalign:0. end_console);
+ error_manager#error ~reset:true "%s" (Cmdline.protect e);
)
in
ignore (Glib.Idle.add (fun () -> in_idle (); false));
diff --git a/src/plugins/gui/gtk_helper.ml b/src/plugins/gui/gtk_helper.ml
index fd6b8762e486ad03c124f332b8acad806992cfb7..7ca273c4caa42910c0f3909f27ce949ff3eaadcf 100644
--- a/src/plugins/gui/gtk_helper.ml
+++ b/src/plugins/gui/gtk_helper.ml
@@ -738,6 +738,7 @@ class error_manager ?reset (o_parent:GWindow.window_skel) : host =
~title:"Error"
~position:`CENTER_ALWAYS
~modal:true
+ ~destroy_with_parent:true
()
in
ignore (w#connect#response ~callback:(fun _ -> w#destroy ()));
diff --git a/src/plugins/gui/help_manager.ml b/src/plugins/gui/help_manager.ml
index d0e1fedf9ea17fd08e0c576e6348fef59e01418b..0ac0ab6798b22bfc04ea81c49090ad2190cd248a 100644
--- a/src/plugins/gui/help_manager.ml
+++ b/src/plugins/gui/help_manager.ml
@@ -56,6 +56,7 @@ let show main_ui =
"Melody Méaulle";
"Benjamin Monate";
"Yannick Moy";
+ "Pierre Nigron";
"Anne Pacalet";
"Valentin Perrelle";
"Guillaume Petiot";
diff --git a/src/plugins/gui/pretty_source.ml b/src/plugins/gui/pretty_source.ml
index b2d1ddff1c55e1e828fe2b87a59df5a4a9676fbc..60293a2379d7727fc783a6061b85c4e5ebc778ed 100644
--- a/src/plugins/gui/pretty_source.ml
+++ b/src/plugins/gui/pretty_source.ml
@@ -260,14 +260,14 @@ let buffer_formatter state source =
let emit_open_tag s =
let s = Extlib.format_string_of_stag s in
(* Ignore tags that are not ours *)
- if Extlib.string_prefix "guitag:" s then
+ if String.starts_with ~prefix:"guitag:" s then
Stack.push (source#end_iter#offset, Tag.find s) starts ;
""
in
let emit_close_tag s =
let s = Extlib.format_string_of_stag s in
(try
- if Extlib.string_prefix "guitag:" s then
+ if String.starts_with ~prefix:"guitag:" s then
let (p,sid) = Stack.pop starts in
Locs.add state (p, source#end_iter#offset) sid
with Stack.Empty -> (* This should probably be a hard error *)
diff --git a/src/plugins/inout/cumulative_analysis.ml b/src/plugins/inout/cumulative_analysis.ml
index 02490caad65bd6a940c807d6c1ee97abda12ecfb..9fd6d8dcfe08947ead6ec1cc3ed539dfc867a6cc 100644
--- a/src/plugins/inout/cumulative_analysis.ml
+++ b/src/plugins/inout/cumulative_analysis.ml
@@ -39,9 +39,9 @@ let specialize_state_on_call ?stmt kf =
match stmt with
| None -> Eva.Results.(at_start_of kf |> get_cvalue_model)
| Some stmt ->
- let filter = function
- | (_, Kstmt s) :: _ -> Cil_datatype.Stmt.equal s stmt
- | _ -> false
+ let filter = fun cs -> match Eva.Callstack.top_callsite cs with
+ | Kstmt s -> Cil_datatype.Stmt.equal s stmt
+ | Kglobal -> false
in
Eva.Results.(at_start_of kf |> filter_callstack filter |> get_cvalue_model)
diff --git a/src/plugins/inout/operational_inputs.ml b/src/plugins/inout/operational_inputs.ml
index d3240b5f5a6713dccf230a2a31951d017fd9c6b1..fd6ac73903827b6801ff1d08f5f660f0a7f864e8 100644
--- a/src/plugins/inout/operational_inputs.ml
+++ b/src/plugins/inout/operational_inputs.ml
@@ -184,18 +184,14 @@ let eval_assigns kf state assigns =
over_outputs_if_termination = r.over_outputs_d;
}
-let compute_using_prototype_state state kf =
+let compute_using_spec state kf =
let behaviors = Eva.Logic_inout.valid_behaviors kf state in
let assigns = Ast_info.merge_assigns behaviors in
eval_assigns kf state assigns
-let compute_using_given_spec_state state funspec kf =
- let assigns = Ast_info.merge_assigns funspec.spec_behavior in
- eval_assigns kf state assigns
-
let compute_using_prototype ?stmt kf =
let state = Cumulative_analysis.specialize_state_on_call ?stmt kf in
- compute_using_prototype_state state kf
+ compute_using_spec state kf
(* Results of this module, consolidated by functions. Formals and locals
are stored *)
@@ -207,13 +203,16 @@ module Internals =
let size = 17
end)
-module CallsiteHash = Value_types.Callsite.Hashtbl
+module Callsite =
+ Datatype.Pair_with_collections (Kernel_function) (Cil_datatype.Kinstr)
+ (struct let module_name = "From.Callsite" end)
+module CallsiteHash = Callsite.Hashtbl
(* Results of an an entire call, represented by a pair (stmt, kernel_function).
*)
module CallwiseResults =
State_builder.Hashtbl
- (Value_types.Callsite.Hashtbl)
+ (Callsite.Hashtbl)
(Inout_type)
(struct
let size = 17
@@ -561,48 +560,37 @@ module Callwise = struct
Internals.replace kf (Inout_type.join v prev);
;;
- let merge_local_table_in_global_ones =
- CallsiteHash.iter merge_call_in_global_tables
- ;;
-
let call_inout_stack = ref []
- let call_for_callwise_inout callstack _kf call_type state =
- let (current_function, ki as call_site) = List.hd callstack in
- let merge_inout inout =
- Db.Operational_inputs.Record_Inout_Callbacks.apply (callstack, inout);
- if ki = Kglobal
- then merge_call_in_global_tables call_site inout
- else
- let _above_function, table =
- try List.hd !call_inout_stack
- with Failure _ -> assert false
- in
- merge_call_in_local_table call_site table inout
- in
- match call_type with
- | `Builtin (Some (froms,sure_out)) ->
- let in_, out_ = extract_inout_from_froms froms in
- let inout = {
- over_inputs_if_termination = in_;
- over_inputs = in_;
- over_logic_inputs = Zone.bottom;
- over_outputs_if_termination = out_ ;
- over_outputs = out_;
- under_outputs_if_termination = sure_out;
- } in
- merge_inout inout
- | `Def | `Memexec ->
+ let call_for_callwise_inout _callstack kf _state = function
+ | `Body ->
let table_current_function = CallsiteHash.create 7 in
- call_inout_stack :=
- (current_function, table_current_function) :: !call_inout_stack
- | `Spec spec ->
- let inout =compute_using_given_spec_state state spec current_function in
- merge_inout inout
- | `Builtin None ->
- let inout = compute_using_prototype_state state current_function in
- merge_inout inout
+ call_inout_stack := (kf, table_current_function) :: !call_inout_stack
+ | `Reuse | `Spec | `Builtin -> ()
+
+ let pop_local_table kf =
+ match !call_inout_stack with
+ | (kf', table) :: tail ->
+ if not (Kernel_function.equal kf kf') then
+ Inout_parameters.fatal "callwise inout: %a != %a@."
+ Kernel_function.pretty kf Kernel_function.pretty kf';
+ CallsiteHash.iter merge_call_in_global_tables table;
+ call_inout_stack := tail;
+ | [] -> Inout_parameters.fatal "callwise: internal stack is empty"
+
+ let end_record callstack kf inout =
+ Db.Operational_inputs.Record_Inout_Callbacks.apply (callstack, inout);
+ let callsite = Eva.Callstack.top_callsite callstack in
+ match callsite, !call_inout_stack with
+ | Kstmt _, (_caller, table) :: _ ->
+ merge_call_in_local_table (kf, callsite) table inout;
+ | Kglobal, [] -> (* the entry point *)
+ merge_call_in_global_tables (kf, callsite) inout;
+ CallwiseResults.mark_as_computed ()
+ | _ ->
+ Inout_parameters.fatal
+ "callwise: internal stack is inconsistent with Eva callstack"
module MemExec =
@@ -616,25 +604,6 @@ module Callwise = struct
end)
- let end_record call_stack inout =
- merge_local_table_in_global_ones (snd (List.hd !call_inout_stack));
-
- let (current_function, _ as call_site) = List.hd call_stack in
- (* pop + record in top of stack the inout of function that just finished*)
- match !call_inout_stack with
- | (current_function2, _) :: (((_caller, table) :: _) as tail) ->
- if current_function2 != current_function then
- Inout_parameters.fatal "callwise inout %a != %a@."
- Kernel_function.pretty current_function (* g *)
- Kernel_function.pretty current_function2 (* f *);
- call_inout_stack := tail;
- merge_call_in_local_table call_site table inout;
-
- | _ -> (* the entry point, probably *)
- merge_call_in_global_tables call_site inout;
- call_inout_stack := [];
- CallwiseResults.mark_as_computed ()
-
let compute_call_from_value_states kf call_stack states =
let module Fenv = (val Dataflows.function_env kf: Dataflows.FUNCTION_ENV) in
let module Computer = Computer(Fenv)(
@@ -673,9 +642,10 @@ module Callwise = struct
in
Computer.end_dataflow ()
- let record_for_callwise_inout callstack kf value_res =
- let inout = match value_res with
- | Eva.Cvalue_callbacks.Store ({before_stmts}, memexec_counter) ->
+ let record_for_callwise_inout callstack kf pre_state value_res =
+ let inout =
+ match value_res with
+ | `Body (Eva.Cvalue_callbacks.{before_stmts}, memexec_counter) ->
let inout =
if Eva.Analysis.save_results kf
then
@@ -684,12 +654,23 @@ module Callwise = struct
else top
in
MemExec.replace memexec_counter inout;
+ pop_local_table kf;
inout
- | Reuse counter ->
- MemExec.find counter
+ | `Reuse counter -> MemExec.find counter
+ | `Spec _states
+ | `Builtin (_states, None) -> compute_using_spec pre_state kf
+ | `Builtin (_states, Some (froms,sure_out)) ->
+ let in_, out_ = extract_inout_from_froms froms in
+ {
+ over_inputs_if_termination = in_;
+ over_inputs = in_;
+ over_logic_inputs = Zone.bottom;
+ over_outputs_if_termination = out_ ;
+ over_outputs = out_;
+ under_outputs_if_termination = sure_out;
+ }
in
- Db.Operational_inputs.Record_Inout_Callbacks.apply (callstack, inout);
- end_record callstack inout
+ end_record callstack kf inout
(* Register our callbacks inside the value analysis *)
diff --git a/src/plugins/metrics/metrics_cilast.ml b/src/plugins/metrics/metrics_cilast.ml
index 1fdd721413c96da3ddae333ab3014616b02c2e39..86674e7ae64dd6b2254605da867bba40f5ec2450 100644
--- a/src/plugins/metrics/metrics_cilast.ml
+++ b/src/plugins/metrics/metrics_cilast.ml
@@ -509,11 +509,10 @@ let pretty_used_files used_files =
Datatype.Filepath.Set.mem path cmdline_files
) used_files
in
+ let is_c_file s = String.ends_with ~suffix:".c" s && s <> ".c" in
let used_included_c_files =
Datatype.Filepath.Set.filter
- (fun f ->
- Extlib.string_suffix ~strict:true ".c"
- (f : Filepath.Normalized.t :> string))
+ (fun f -> is_c_file (f : Filepath.Normalized.t :> string))
used_included_files
in
let used_implicitly_included_c_files =
diff --git a/src/plugins/nonterm/nonterm_run.ml b/src/plugins/nonterm/nonterm_run.ml
index 3d35dd91f99e0642024a0478f144c252abeb9464..176678b5e498016794add8061f174db1042246fd 100644
--- a/src/plugins/nonterm/nonterm_run.ml
+++ b/src/plugins/nonterm/nonterm_run.ml
@@ -91,17 +91,16 @@ let pretty_stmt_kind fmt stmt =
let pp_numbered_stacks fmt callstacks =
if List.length callstacks < 2 then
Format.fprintf fmt "stack: %a"
- (Pretty_utils.pp_list ~sep:": " Value_types.Callstack.pretty) callstacks
+ (Pretty_utils.pp_list ~sep:": " Eva.Callstack.pretty) callstacks
else
(* number callstacks *)
let numbered_callstacks =
- let count = ref 0 in
- List.map (fun cs -> incr count; (!count, cs)) callstacks
+ List.mapi (fun i cs -> (i+1, cs)) callstacks
in
Format.fprintf fmt "%a"
(Pretty_utils.pp_list ~sep:"@\n"
(Pretty_utils.pp_pair ~pre:"stack " ~sep:": "
- Format.pp_print_int Value_types.Callstack.pretty))
+ Format.pp_print_int Eva.Callstack.pretty))
numbered_callstacks
let wkey_stmt = Self.register_warn_category "stmt"
@@ -306,21 +305,6 @@ let collect_nonterminating_statements fd nonterm_stacks =
) vis#get_instr_stmts;
!new_nonterm_stmts
-let rec cmp_callstacks_aux cs1 cs2 =
- match cs1, cs2 with
- | [], [] -> 0
- | [], _ -> -1
- | _, [] -> 1
- | (kf1, ki1) :: r1, (kf2, ki2) :: r2 ->
- let c = Cil_datatype.Kinstr.compare ki1 ki2 in
- if c <> 0 then c else
- let c = Kernel_function.compare kf1 kf2 in
- if c <> 0 then c else
- cmp_callstacks_aux r1 r2
-
-let cmp_callstacks cs1 cs2 =
- if cs1 == cs2 then 0 else cmp_callstacks_aux (List.rev cs1) (List.rev cs2)
-
let run () =
if not (Ast.is_computed ()) then
Self.abort "nonterm requires a computed AST";
@@ -344,7 +328,7 @@ let run () =
let warned_kfs =
Stmt.Hptset.fold (fun stmt acc ->
let cs = Hashtbl.find nonterm_stacks stmt in
- let cs = List.sort cmp_callstacks cs in
+ let cs = List.sort Eva.Callstack.compare_lex cs in
warn_nonterminating_statement stmt cs;
Kernel_function.Set.add (Kernel_function.find_englobing_kf stmt) acc
) new_nonterm_stmts Kernel_function.Set.empty
diff --git a/src/plugins/server/states.ml b/src/plugins/server/states.ml
index 00b346c51657caf06acd642c091d0325cce252b5..9d9ccc7357709b48a4965bb547839e161cb26e12 100644
--- a/src/plugins/server/states.ml
+++ b/src/plugins/server/states.ml
@@ -65,6 +65,20 @@ let register_value (type a) ~package ~name ~descr
Option.iter (register_hook signal) add_hook ;
signal
+module type Value = sig
+ type data
+ val get: unit -> data
+ val add_hook_on_change: (data -> unit) -> unit
+end
+
+let register_framac_value (type a) ~package ~name ~descr
+ ~(output : a Request.output)
+ (state : (module Value with type data = a)) =
+ let module State = (val state) in
+ register_value ~package ~name ~descr ~output
+ ~get:State.get
+ ~add_hook:State.add_hook_on_change ()
+
(* -------------------------------------------------------------------------- *)
(* --- States --- *)
(* -------------------------------------------------------------------------- *)
@@ -91,6 +105,21 @@ let register_state (type a) ~package ~name ~descr
Option.iter (register_hook signal) add_hook ;
signal
+module type State = sig
+ type data
+ val set: data -> unit
+ val get: unit -> data
+ val add_hook_on_change: (data -> unit) -> unit
+end
+
+let register_framac_state (type a) ~package ~name ~descr
+ ~(data : a data)
+ (state : (module State with type data = a)) =
+ let module State = (val state) in
+ register_state ~package ~name ~descr ~data
+ ~get:State.get ~set:State.set
+ ~add_hook:State.add_hook_on_change ()
+
(* -------------------------------------------------------------------------- *)
(* --- Model Signature --- *)
(* -------------------------------------------------------------------------- *)
@@ -215,12 +244,15 @@ let update array k =
m.updates <- Kmap.add (array.key k) (Add k) m.updates ;
Request.emit array.signal
-let remove array k =
+let remove_key array k =
let m = content array in
if not m.cleared then
- m.updates <- Kmap.add (array.key k) Remove m.updates ;
+ m.updates <- Kmap.add k Remove m.updates ;
Request.emit array.signal
+let remove array k =
+ remove_key array (array.key k)
+
let signal array = array.signal
(* -------------------------------------------------------------------------- *)
@@ -389,4 +421,30 @@ let register_array ~package ~name ~descr ~key
Option.iter (install_hook signal (fun () -> reload array)) add_reload_hook ;
array
+module type TableState = sig
+ type key
+ type data
+ val iter: (key -> data -> unit) -> unit
+ val add_hook_on_change:
+ ((key, data) State_builder.hashtbl_event -> unit) -> unit
+end
+
+let register_framac_array (type key) (type data) ~package ~name ~descr ~key
+ ?keyName ?keyType
+ (model : (key * data) model)
+ (table : (module TableState with type key = key and type data = data)) =
+ let module Table = (val table) in
+ let array = register_array ~package ~name ~descr ?keyName ?keyType
+ ~key:(fun (k,_d) -> key k)
+ ~iter:(fun f -> Table.iter (fun k d -> f (k,d)))
+ model
+ in
+ let handle_event = function
+ | State_builder.Update (k,d) -> update array (k,d)
+ | Remove k -> remove_key array (key k)
+ | Clear -> reload array
+ in
+ install_hook array.signal handle_event (Table.add_hook_on_change);
+ array
+
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/states.mli b/src/plugins/server/states.mli
index 947c2a424edd71367a0c205eabd2d4ac84cf8f35..ff52812c698287bced7066dda914765051118b63 100644
--- a/src/plugins/server/states.mli
+++ b/src/plugins/server/states.mli
@@ -51,6 +51,23 @@ val register_value :
?add_hook:('b callback) ->
unit -> Request.signal
+(** Sub-signature of [State_builder.Ref] for [register_framac_value]. *)
+module type Value = sig
+ type data
+ val get: unit -> data
+ val add_hook_on_change: (data -> unit) -> unit
+end
+
+(** Same as [register_value] but takes a [State_builder.Ref] module as
+ parameter. *)
+val register_framac_value :
+ package:package ->
+ name:string ->
+ descr:Markdown.text ->
+ output:'a Request.output ->
+ (module Value with type data = 'a) ->
+ Request.signal
+
(** Register a (projectified) state and generates the associated signal and
requests:
- Signal [<name>.sig] is emitted on value updates;
@@ -74,6 +91,24 @@ val register_state :
?add_hook:('b callback) ->
unit -> Request.signal
+(** Sub-signature of [State_builder.Ref] for [register_framac_state]. *)
+module type State = sig
+ type data
+ val set: data -> unit
+ val get: unit -> data
+ val add_hook_on_change: (data -> unit) -> unit
+end
+
+(** Same as [register_state] but takes a [State_builder.Ref] module as
+ parameter. *)
+val register_framac_state :
+ package:package ->
+ name:string ->
+ descr:Markdown.text ->
+ data:'a Data.data ->
+ (module State with type data = 'a) ->
+ Request.signal
+
type 'a model (** Columns array model *)
(** Creates an empty array model. *)
@@ -147,4 +182,26 @@ val register_array :
?add_reload_hook:(unit callback) ->
'a model -> 'a array
+(** Sub-signature of [State_builder.Hashtbl] for [register_framac_array]. *)
+module type TableState = sig
+ type key
+ type data
+ val iter: (key -> data -> unit) -> unit
+ val add_hook_on_change:
+ ((key, data) State_builder.hashtbl_event -> unit) -> unit
+end
+
+(** Same as [register_array] but takes a [State_builder.Hashtbl] module as
+ parameter. *)
+val register_framac_array :
+ package:package ->
+ name:string ->
+ descr:Markdown.text ->
+ key:('k -> string) ->
+ ?keyName:string ->
+ ?keyType:jtype ->
+ ('k * 'd) model ->
+ (module TableState with type key = 'k and type data = 'd) ->
+ ('k * 'd) array
+
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/studia/writes.ml b/src/plugins/studia/writes.ml
index 5958368970b0acd176334fff1d5163aecef5a54e..d5a2f6b0584af1ebbf9e74565b1580c54437dfe6 100644
--- a/src/plugins/studia/writes.ml
+++ b/src/plugins/studia/writes.ml
@@ -42,7 +42,6 @@ let (<?>) c lcmp =
let compare w1 w2 =
let open Cil_datatype in
- let module List = Transitioning.List in
match w1, w2 with
| Assign s1, Assign s2
| CallDirect s1, CallDirect s2
diff --git a/src/plugins/users/users_register.ml b/src/plugins/users/users_register.ml
index d4ec19e6516847d2d1c3d979e46be3c5ae2bf37b..25fd111322f8f8abfc1fc2e866dc0fd388b8e707 100644
--- a/src/plugins/users/users_register.ml
+++ b/src/plugins/users/users_register.ml
@@ -49,15 +49,16 @@ let compute_users _ =
if Eva.Results.is_called kf
then
let callstacks = Eva.Results.(at_start_of kf |> callstacks) in
- let process_callstack list =
- let process_element (user, _call_site) =
+ let process_callstack callstack =
+ let users = List.tl (List.rev (Eva.Callstack.to_kf_list callstack)) in
+ let process_element user =
ignore
(Users.memo
~change:(Kernel_function.Hptset.add kf)
(fun _ -> Kernel_function.Hptset.singleton kf)
user)
in
- List.iter process_element (List.tl list)
+ List.iter process_element users
in
List.iter process_callstack callstacks
in
diff --git a/src/plugins/variadic/classify.ml b/src/plugins/variadic/classify.ml
index 053d1b52b0ea3ec8f3a385482576e20868bb2daa..32d4c8c2c3690afd523cc768515874f2ba7813f3 100644
--- a/src/plugins/variadic/classify.ml
+++ b/src/plugins/variadic/classify.ml
@@ -113,7 +113,7 @@ let mk_format_fun vi f_kind f_buffer ~format_pos =
let is_frama_c_builtin name =
Ast_info.is_frama_c_builtin name ||
Cil_builtins.Builtin_functions.mem name ||
- Extlib.string_prefix "__FRAMAC_" name (* Mthread prefixes *)
+ String.starts_with ~prefix:"__FRAMAC_" name (* Mthread prefixes *)
let va_builtins = [
"__builtin_va_start";
@@ -162,7 +162,7 @@ let classify_std env vi = match vi.vname with
(* stropts.h *)
| "ioctl" -> mk_overload env ["__va_ioctl_void" ; "__va_ioctl_int" ; "__va_ioctl_ptr"]
- | n when Extlib.string_prefix "__sync_" n -> Misc
+ | n when String.starts_with ~prefix:"__sync_" n -> Misc
| n when is_va_builtin n -> Misc
| n when is_frama_c_builtin n -> Builtin
(* Anything else *)
diff --git a/src/plugins/wp/Cache.ml b/src/plugins/wp/Cache.ml
index 247f0324a9f2996e9e96ddef70a33970fbd3fd0d..2751c487e982dc0373f27943153d58bfb4e6cbdf 100644
--- a/src/plugins/wp/Cache.ml
+++ b/src/plugins/wp/Cache.ml
@@ -156,9 +156,8 @@ let steps_seized steps steplimit =
let promote ?timeout ?steplimit (res : VCS.result) =
match res.verdict with
- | VCS.NoResult | VCS.Computing _ -> VCS.no_result
- | VCS.Failed -> res
- | VCS.Invalid | VCS.Valid | VCS.Unknown ->
+ | VCS.NoResult | VCS.Computing _ | VCS.Failed -> VCS.no_result
+ | VCS.Valid | VCS.Unknown ->
if not (steps_fits res.prover_steps steplimit) then
{ res with verdict = Stepout }
else
diff --git a/src/plugins/wp/Changelog b/src/plugins/wp/Changelog
index e5014c708ca44c9f13901cc81eb4f44c82067707..20a0303acdc890807f8c4028ed40d3f9a5de1a55 100644
--- a/src/plugins/wp/Changelog
+++ b/src/plugins/wp/Changelog
@@ -24,6 +24,8 @@
Plugin WP <next-release>
###############################################################################
+- WP [2023-07-24] New option -wp-memlimit for provers
+- WP [2023-07-24] Fixed cache for interactive provers
- WP [2023-06-05] Tactic Compute (new, generalize Definition and Split)
- WP [2023-06-05] Tactic Absurd now also applies to proof goal
- WP [2023-06-05] Option -wp-prop extended to lemma and function names
@@ -36,6 +38,14 @@ Plugin WP <next-release>
- WP [2023-06-05] ACSL extension 'strategy' for proof strategies
- WP [2023-06-05] ACSL extension 'proof' for proof resolution hints
+###############################################################################
+Plugin WP 27.1 (Cobalt)
+###############################################################################
+
+###############################################################################
+Plugin WP 27.1 (Cobalt)
+###############################################################################
+
###############################################################################
Plugin WP 27.0 (Cobalt)
###############################################################################
diff --git a/src/plugins/wp/Pattern.ml b/src/plugins/wp/Pattern.ml
index 469258d7681c616991c174738131752f7d2b7337..34f986d086e1864730b5d4fa7557a4f74544278e 100644
--- a/src/plugins/wp/Pattern.ml
+++ b/src/plugins/wp/Pattern.ml
@@ -247,12 +247,12 @@ let rec pp fmt (a : ast) =
List.iter (Format.fprintf fmt " ;@ %a" pp) vs ;
Format.fprintf fmt " |]@]"
| Field(v,id) -> Format.fprintf fmt "%a.%s" pp v id
- | Call(id,[],true) -> Format.fprintf fmt "%s(..)" id
+ | Call(id,[],true) -> Format.fprintf fmt "%s((..))" id
| Call(id,[],false) -> Format.fprintf fmt "%s()" id
| Call(id,v::vs,trail) ->
Format.fprintf fmt "@[<hov 2>%s(%a" id pp v ;
List.iter (Format.fprintf fmt ",@ %a" pp) vs ;
- if trail then Format.fprintf fmt ",@ .." ;
+ if trail then Format.fprintf fmt ",@ (..)" ;
Format.fprintf fmt ")@]"
| Pany [] -> Format.pp_print_string fmt "\\never"
| Pany (v::vs) ->
diff --git a/src/plugins/wp/ProofEngine.ml b/src/plugins/wp/ProofEngine.ml
index 9c96cffeb933d00724f249fe6dcf618b91faa4f4..627bad9ac3cef71a83161f1d83abed82c87c1efb 100644
--- a/src/plugins/wp/ProofEngine.ml
+++ b/src/plugins/wp/ProofEngine.ml
@@ -163,16 +163,23 @@ let pending n =
let k = ref 0 in
walk (fun _ -> incr k) n ; !k
-let rec consolidate n =
+let is_prover_result (p,_) = p <> VCS.Tactical
+
+let prover_stats ~smoke goal =
+ Stats.results ~smoke @@
+ List.filter is_prover_result @@
+ Wpo.get_results goal
+
+let rec consolidate ~smoke n =
let s =
if Wpo.is_valid n.goal then
- Stats.results ~smoke:false (Wpo.get_results n.goal)
+ prover_stats ~smoke n.goal
else
match n.script with
- | Opened | Script _ -> Stats.empty
+ | Opened | Script _ -> prover_stats ~smoke n.goal
| Tactic(_,children) ->
let qed = Wpo.qed_time n.goal in
- let results = List.map (fun (_,n) -> consolidate n) children in
+ let results = List.map (fun (_,n) -> consolidate ~smoke n) children in
Stats.tactical ~qed results
in n.stats <- s ; s
@@ -180,20 +187,19 @@ let validate tree =
match tree.root with
| None -> ()
| Some root ->
- if not (Wpo.is_valid tree.main) then
- let stats = consolidate root in
+ let main = tree.main in
+ if not (Wpo.is_valid main) then
+ let stats = consolidate ~smoke:(Wpo.is_smoke_test main) root in
Wpo.set_result tree.main Tactical (Stats.script stats)
let consolidated wpo =
let smoke = Wpo.is_smoke_test wpo in
- let prs = Wpo.get_results wpo in
try
- if Wpo.is_smoke_test wpo || not (PROOFS.mem wpo) then raise Not_found ;
+ if smoke || not (PROOFS.mem wpo) then raise Not_found ;
match PROOFS.get wpo with
| { root = Some { stats ; script = Tactic _ } } -> stats
| _ -> raise Not_found
- with Not_found ->
- Stats.results ~smoke prs
+ with Not_found -> prover_stats ~smoke wpo
(* -------------------------------------------------------------------------- *)
(* --- Accessors --- *)
diff --git a/src/plugins/wp/ProofScript.ml b/src/plugins/wp/ProofScript.ml
index a654b1f42123ab5f1fd26f30cb158de1e4e75766..c8d5ede112bf3b6ba8c6d806b31b952f2d358f9d 100644
--- a/src/plugins/wp/ProofScript.ml
+++ b/src/plugins/wp/ProofScript.ml
@@ -336,7 +336,6 @@ let json_of_verdict = function
| VCS.Unknown -> `String "unknown"
| VCS.Timeout -> `String "timeout"
| VCS.Stepout -> `String "stepout"
- | VCS.Invalid -> `String "invalid"
| VCS.Failed -> `String "failed"
let verdict_of_json = function
@@ -344,7 +343,6 @@ let verdict_of_json = function
| `String "unknown" -> VCS.Unknown
| `String "timeout" -> VCS.Timeout
| `String "stepout" -> VCS.Stepout
- | `String "invalid" -> VCS.Invalid
| `String "failed" -> VCS.Failed
| _ -> VCS.NoResult
diff --git a/src/plugins/wp/ProofStrategy.ml b/src/plugins/wp/ProofStrategy.ml
index 4440b768d7be65fc0ac0278face838658303715e..89f52477debc6c2502dcfc24eb776637a148724e 100644
--- a/src/plugins/wp/ProofStrategy.ml
+++ b/src/plugins/wp/ProofStrategy.ml
@@ -546,7 +546,7 @@ let configure tactic sigma (a,v) =
let subgoal (children : (string loc * string loc) list)
(default : string loc option) (goal,node) =
let hint = List.find_map (fun (g,s) ->
- if Extlib.string_prefix g.value goal then Some s else None
+ if String.starts_with ~prefix:g.value goal then Some s else None
) children in
begin
match hint, default with
diff --git a/src/plugins/wp/ProverScript.ml b/src/plugins/wp/ProverScript.ml
index feb73306307eecf2e682563f7ed1735cbeefe5c5..9494a3040b29919b750afcb9537e76c55400400f 100644
--- a/src/plugins/wp/ProverScript.ml
+++ b/src/plugins/wp/ProverScript.ml
@@ -119,6 +119,7 @@ struct
width : int ;
auto : Strategy.heuristic list ; (* DEPRECATED *)
strategies : bool ;
+ mutable pending : int ; (* pending jobs *)
mutable signaled : bool ;
backtrack : int ;
mutable backtracking : backtracking option ;
@@ -139,20 +140,12 @@ struct
let progress env msg = env.progress (ProofEngine.main env.tree) msg
- let stuck env =
- if not env.signaled then
- begin
- ProofEngine.validate env.tree ;
- env.success (ProofEngine.main env.tree) None ;
- env.signaled <- true ;
- end
-
- let validate ?(finalize=false) env =
+ let validate env =
ProofEngine.validate env.tree ;
if not env.signaled then
let wpo = ProofEngine.main env.tree in
- let proved = Wpo.is_valid wpo in
- if proved || finalize then
+ let proved = Wpo.is_passed wpo in
+ if proved || env.pending = 0 then
begin
env.signaled <- true ;
List.iter
@@ -223,7 +216,7 @@ struct
~valid ~failed ~provers ~strategies
~depth ~width ~backtrack ~auto
~progress ~result ~success =
- { tree ; valid ; failed ; provers ;
+ { tree ; valid ; failed ; provers ; pending = 0 ;
depth ; width ; backtrack ; auto ; strategies ;
progress ; result ; success ;
backtracking = None ;
@@ -313,7 +306,7 @@ and autofork env ~depth fork =
forall (auto env ~depth) (List.map snd children)
end
else
- ( Env.validate env ; Task.return true )
+ Task.return true
(* -------------------------------------------------------------------------- *)
(* --- Proof Strategy Alternatives --- *)
@@ -430,9 +423,7 @@ let rec crawl env on_child node = function
| [] ->
let node = ProofEngine.anchor (Env.tree env) ?node () in
- automated env on_child node >>= fun ok ->
- if ok then Env.validate env else Env.stuck env ;
- Task.return ()
+ automated env on_child node
| Error(msg,json) :: alternatives ->
Wp_parameters.warning "@[<hov 2>Script Error: on goal %a@\n%S: %a@]@."
@@ -450,7 +441,7 @@ let rec crawl env on_child node = function
else Task.return false in
let continue ok =
if ok
- then (Env.validate env ; Task.return ())
+ then success
else crawl env on_child node alternatives
in
task >>= continue
@@ -460,11 +451,8 @@ let rec crawl env on_child node = function
begin
try
let residual = apply env node jtactic subscripts in
- if residual = [] then
- Env.validate env
- else
- List.iter (fun (_,n) -> on_child n) residual ;
- Task.return ()
+ List.iter (fun (_,n) -> on_child n) residual ;
+ Task.return true
with exn when Wp_parameters.protect exn ->
Wp_parameters.warning
"Script Error: on goal %a@\n\
@@ -493,14 +481,24 @@ let schedule job =
Task.spawn (ProverTask.server ()) (Task.thread (Task.todo job))
let rec process env node =
+ env.Env.pending <- succ env.Env.pending ;
schedule
begin fun () ->
Wp_parameters.debug ~dkey:dkey_pp_allgoals "%a" (pp_subgoal env) node ;
if ProofEngine.proved node then
- ( Env.validate env ; Task.return () )
+ begin
+ env.pending <- pred env.pending ;
+ Env.validate env ;
+ Task.return () ;
+ end
else
let script = Priority.sort (ProofEngine.bound node) in
- crawl env (process env) (Some node) script
+ crawl env (process env) (Some node) script >>=
+ begin fun _ ->
+ env.pending <- pred env.pending ;
+ Env.validate env ;
+ Task.return ()
+ end
end
let task
@@ -523,8 +521,10 @@ let task
~valid ~failed ~provers
~depth ~width ~backtrack ~auto ~strategies
~progress ~result ~success in
- crawl env (process env) None script >>?
- (fun _ -> ProofEngine.forward tree) ;
+ crawl env (process env) None script >>= fun _ ->
+ Env.validate env ;
+ ProofEngine.forward tree ;
+ Task.return ()
end
(* -------------------------------------------------------------------------- *)
@@ -579,9 +579,8 @@ let search
~progress ~result ~success in
schedule
begin fun () ->
- autosearch env ~depth:0 node >>=
- fun ok ->
- if ok then Env.validate ~finalize:true env else Env.stuck env ;
+ autosearch env ~depth:0 node >>= fun _ ->
+ Env.validate env ;
Task.return ()
end
end
@@ -602,8 +601,8 @@ let explore ?(depth=0) ?(strategy)
match strategy with
| None -> explore_hints env (process env)
| Some s -> explore_strategy env (fun _ -> ()) s
- in solver node >>= fun ok ->
- if ok then Env.validate ~finalize:true env else Env.stuck env ;
+ in solver node >>= fun _ ->
+ Env.validate env ;
Task.return ()
end
end
diff --git a/src/plugins/wp/ProverWhy3.ml b/src/plugins/wp/ProverWhy3.ml
index 7a9bd2fa1a7006a27e8e8c29afa5de3a778f420a..a0abe91f0feaf6a69d0bbd4aad5b328a30086e46 100644
--- a/src/plugins/wp/ProverWhy3.ml
+++ b/src/plugins/wp/ProverWhy3.ml
@@ -1185,13 +1185,13 @@ let ping_prover_call ~config p =
| ProverFinished _ when p.killed -> Task.(Return Canceled)
| ProverFinished pr ->
let r =
+ let time = max Rformat.epsilon pr.pr_time in
match pr.pr_answer with
- | Timeout -> VCS.timeout pr.pr_time
- | Valid -> VCS.result ~time:pr.pr_time ~steps:pr.pr_steps VCS.Valid
- | Invalid -> VCS.result ~time:pr.pr_time ~steps:pr.pr_steps VCS.Invalid
+ | Timeout -> VCS.timeout time
+ | Valid -> VCS.result ~time ~steps:pr.pr_steps VCS.Valid
| OutOfMemory -> VCS.failed "out of memory"
| StepLimitExceeded -> VCS.result ?steps:p.steps VCS.Stepout
- | Unknown _ -> VCS.unknown
+ | Unknown _ | Invalid -> VCS.unknown
| _ when p.interrupted -> VCS.timeout p.timeout
| Failure s -> VCS.failed s
| HighFailure ->
@@ -1244,22 +1244,30 @@ let digest_task wpo drv ?script prover task =
begin fun fmt ->
Format.fprintf fmt "(* WP Task for Prover %s *)@\n"
(Why3Provers.ident_why3 prover) ;
- let old = Option.map open_in script in
+ let old = Option.map
+ (fun fscript ->
+ let hash = Digest.file fscript |> Digest.to_hex in
+ Format.fprintf fmt "(* WP Script %s *)@\n" hash ;
+ open_in fscript
+ ) script in
let _ = Why3.Driver.print_task_prepared ?old drv fmt task in
Option.iter close_in old ;
end ;
Digest.file file |> Digest.to_hex
end
-let run_batch pconf driver ~config ?script ~timeout ~steplimit prover task =
+let run_batch pconf driver ~config ?script ~timeout ~steplimit ~memlimit
+ prover task =
let steps = match steplimit with Some 0 -> None | _ -> steplimit in
let limit =
let config = Why3.Whyconf.get_main @@ Why3Provers.config () in
- let memlimit = Why3.Whyconf.memlimit config in
- let def = Why3.Call_provers.empty_limit in
- { Why3.Call_provers.limit_time = Why3.Opt.get_def def.limit_time timeout;
- Why3.Call_provers.limit_steps = Why3.Opt.get_def def.limit_steps steps;
- Why3.Call_provers.limit_mem = memlimit;
+ let config_mem = Why3.Whyconf.memlimit config in
+ let config_time = Why3.Whyconf.timelimit config in
+ let config_steps = Why3.Call_provers.empty_limit.limit_steps in
+ Why3.Call_provers.{
+ limit_time = Why3.Opt.get_def config_time timeout;
+ limit_steps = Why3.Opt.get_def config_steps steps;
+ limit_mem = Why3.Opt.get_def config_mem memlimit;
} in
let with_steps = match steps, pconf.Why3.Whyconf.command_steps with
| None, _ -> false
@@ -1268,8 +1276,7 @@ let run_batch pconf driver ~config ?script ~timeout ~steplimit prover task =
Wp_parameters.warning ~once:true ~current:false
"%a does not support steps limit (ignored option)"
Why3.Whyconf.print_prover prover ;
- false
- in
+ false in
let steps = if with_steps then steps else None in
let command = Why3.Whyconf.get_complete_command pconf ~with_steps in
Wp_parameters.debug ~dkey "Prover command %S" command ;
@@ -1316,16 +1323,13 @@ let editor ~script ~merge ~config pconf driver task =
if merge then updatescript ~script driver task ;
let command = editor_command pconf in
Wp_parameters.debug ~dkey "Editor command %S" command ;
- let call =
- Why3.Call_provers.call_editor
- ~command ~config script
- in
- call_prover_task ~config ~timeout:None ~steps:None pconf.prover call
+ call_prover_task ~config ~timeout:None ~steps:None pconf.prover @@
+ Why3.Call_provers.call_editor ~command ~config script
end
-let compile ~script ~timeout ~config wpo pconf driver prover task =
+let compile ~script ~timeout ~memlimit ~config wpo pconf driver prover task =
let digest = digest_task wpo driver ~script in
- let runner = run_batch ~config pconf driver ~script in
+ let runner = run_batch ~config pconf driver ~script ~memlimit in
Cache.get_result ~digest ~runner ~timeout ~steplimit:None prover task
let prepare ~mode wpo driver task =
@@ -1345,7 +1349,9 @@ let prepare ~mode wpo driver task =
let interactive ~mode wpo pconf ~config driver prover task =
let time = Wp_parameters.InteractiveTimeout.get () in
+ let mem = Wp_parameters.Memlimit.get () in
let timeout = if time <= 0 then None else Some (float time) in
+ let memlimit = if mem <= 0 then None else Some mem in
match prepare ~mode wpo driver task with
| None ->
Wp_parameters.warning ~once:true ~current:false
@@ -1359,28 +1365,30 @@ let interactive ~mode wpo pconf ~config driver prover task =
Why3.Whyconf.print_prover prover script ;
match mode with
| VCS.Batch ->
- compile ~script ~timeout ~config wpo pconf driver prover task
+ compile ~script ~timeout ~memlimit ~config wpo pconf driver prover task
| VCS.Update ->
if merge then updatescript ~script driver task ;
- compile ~script ~timeout ~config wpo pconf driver prover task
+ compile ~script ~timeout ~memlimit ~config wpo pconf driver prover task
| VCS.Edit ->
let open Task in
editor ~script ~merge ~config pconf driver task >>= fun _ ->
- compile ~script ~timeout ~config wpo pconf driver prover task
+ compile ~script ~timeout ~memlimit ~config wpo pconf driver prover task
| VCS.Fix ->
let open Task in
- compile ~script ~timeout ~config wpo pconf driver prover task >>= fun r ->
+ compile ~script ~timeout ~memlimit ~config wpo pconf driver prover task
+ >>= fun r ->
if VCS.is_valid r then return r else
editor ~script ~merge ~config pconf driver task >>= fun _ ->
- compile ~script ~timeout ~config wpo pconf driver prover task
+ compile ~script ~timeout ~memlimit ~config wpo pconf driver prover task
| VCS.FixUpdate ->
let open Task in
if merge then updatescript ~script driver task ;
- compile ~script ~timeout ~config wpo pconf driver prover task >>= fun r ->
+ compile ~script ~timeout ~memlimit ~config wpo pconf driver prover task
+ >>= fun r ->
if VCS.is_valid r then return r else
let merge = false in
editor ~script ~merge ~config pconf driver task >>= fun _ ->
- compile ~script ~timeout ~config wpo pconf driver prover task
+ compile ~script ~timeout ~memlimit ~config wpo pconf driver prover task
(* -------------------------------------------------------------------------- *)
(* --- Prove WPO --- *)
@@ -1390,7 +1398,8 @@ let is_trivial (t : Why3.Task.task) =
let goal = Why3.Task.task_goal_fmla t in
Why3.Term.t_equal goal Why3.Term.t_true
-let build_proof_task ?(mode=VCS.Batch) ?timeout ?steplimit ~prover wpo () =
+let build_proof_task ?(mode=VCS.Batch) ?timeout ?steplimit ?memlimit
+ ~prover wpo () =
try
(* Always generate common task *)
let context = Wpo.get_context wpo in
@@ -1408,7 +1417,7 @@ let build_proof_task ?(mode=VCS.Batch) ?timeout ?steplimit ~prover wpo () =
else
Cache.get_result
~digest:(digest_task wpo drv)
- ~runner:(run_batch ~config pconf drv ?script:None)
+ ~runner:(run_batch ~config pconf ~memlimit drv ?script:None)
~timeout ~steplimit prover task
with exn ->
if Wp_parameters.has_dkey dkey_api then
@@ -1418,7 +1427,8 @@ let build_proof_task ?(mode=VCS.Batch) ?timeout ?steplimit ~prover wpo () =
else
Task.failed "[Why3 Error] %a" Why3.Exn_printer.exn_printer exn
-let prove ?mode ?timeout ?steplimit ~prover wpo =
- Task.later (build_proof_task ?mode ?timeout ?steplimit ~prover wpo) ()
+let prove ?mode ?timeout ?steplimit ?memlimit ~prover wpo =
+ Task.later
+ (build_proof_task ?mode ?timeout ?steplimit ?memlimit ~prover wpo) ()
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/ProverWhy3.mli b/src/plugins/wp/ProverWhy3.mli
index 24aac04061dc75bf6f294910899857c8f49e2e4f..30e0a740ce98807909982ad89ca684c9539b06f1 100644
--- a/src/plugins/wp/ProverWhy3.mli
+++ b/src/plugins/wp/ProverWhy3.mli
@@ -20,14 +20,18 @@
(* *)
(**************************************************************************)
+(** Equality used in the goal, simpler to prove than polymorphic equality *)
val add_specific_equality:
for_tau:(Lang.tau -> bool) ->
mk_new_eq:Lang.F.binop ->
unit
-(** Equality used in the goal, simpler to prove than polymorphic equality *)
-val prove : ?mode:VCS.mode -> ?timeout:float -> ?steplimit:int ->
- prover:Why3Provers.t -> Wpo.t -> VCS.result Task.task
(** Return NoResult if it is already proved by Qed *)
+val prove :
+ ?mode:VCS.mode ->
+ ?timeout:float ->
+ ?steplimit:int ->
+ ?memlimit:int ->
+ prover:Why3Provers.t -> Wpo.t -> VCS.result Task.task
(**************************************************************************)
diff --git a/src/plugins/wp/Stats.ml b/src/plugins/wp/Stats.ml
index 50449ec8a3b466e59467fa38fc3610b3f368ae4f..fcdee85cb048bfe531d6875a5b641a0dbea4301d 100644
--- a/src/plugins/wp/Stats.ml
+++ b/src/plugins/wp/Stats.ml
@@ -36,16 +36,16 @@ type pstats = {
}
type stats = {
- verdict : VCS.verdict ;
+ best : VCS.verdict ;
provers : (VCS.prover * pstats) list ;
tactics : int ;
proved : int ;
- trivial : int ;
timeout : int ;
unknown : int ;
noresult : int ;
failed : int ;
cached : int ;
+ cachemiss : int ;
}
(* -------------------------------------------------------------------------- *)
@@ -86,17 +86,19 @@ let ptime t valid =
{ tmin = t ; tval = t ; tmax = t ; time = t ; tnbr = 1.0 ;
success = if valid then 1.0 else 0.0 }
+let psolver r = ptime r.solver_time false
let pqed r = if VCS.is_valid r then ptime r.solver_time true else pzero
let presult r = if VCS.is_valid r then ptime r.prover_time true else pzero
-let psolver r = ptime r.solver_time false
-let psmoked = { pzero with success = 1.0 }
+let qsmoked r = if VCS.is_valid r then ptime r.solver_time false else ptime 0.0 true
+let psmoked r = if VCS.is_valid r then ptime r.prover_time false else ptime 0.0 true
+let vsmoked v = if VCS.is_proved ~smoke:true v then VCS.Valid else VCS.Failed
(* -------------------------------------------------------------------------- *)
(* --- Global Stats --- *)
(* -------------------------------------------------------------------------- *)
let empty = {
- verdict = NoResult;
+ best = NoResult;
provers = [];
tactics = 0;
proved = 0;
@@ -104,103 +106,40 @@ let empty = {
unknown = 0 ;
noresult = 0 ;
failed = 0 ;
- trivial = 0 ;
cached = 0 ;
+ cachemiss = 0 ;
}
-let choose_best a b =
- if VCS.leq (snd a) (snd b) then a else b
-
-let choose_worst a b =
- if VCS.leq (snd b) (snd a) then a else b
-
-let is_trivial (p,r) =
- p = Qed || VCS.is_trivial r
-
-let is_cached ((_,r) as pr) =
- r.VCS.cached || not (VCS.is_verdict r) || is_trivial pr
-
-type consolidated = {
- cs_verdict : VCS.verdict ;
- cs_cached : int ;
- cs_trivial : int ;
- cs_provers : (prover * pstats) list ;
-}
-
-let consolidated = function
- | [] ->
- { cs_verdict = NoResult ;
- cs_trivial = 0 ;
- cs_cached = 0 ;
- cs_provers = [] }
- | u::w as results ->
- let (p,r) as pr = List.fold_left choose_best u w in
- let trivial = is_trivial pr in
- let cached = not trivial && List.for_all is_cached results in
- let provers =
- if p = Qed then [Qed,pqed r]
- else pmerge [Qed,psolver r] [p,presult r]
- in
- {
- cs_verdict = r.VCS.verdict ;
- cs_trivial = (if trivial then 1 else 0) ;
- cs_cached = (if cached then 1 else 0) ;
- cs_provers = provers ;
- }
-
-let stats prs =
- let { cs_verdict = verdict ;
- cs_trivial = trivial ;
- cs_cached = cached ;
- cs_provers = provers ;
- } = consolidated prs in
- match verdict with
- | Valid ->
- { empty with verdict ; provers ; trivial ; cached ; proved = 1 }
- | Timeout | Stepout ->
- { empty with verdict ; provers ; trivial ; cached ; timeout = 1 }
- | Unknown ->
- { empty with verdict ; provers ; trivial ; cached ; unknown = 1 }
- | NoResult | Computing _ ->
- { empty with verdict ; provers ; trivial ; cached ; noresult = 1 }
- | Failed | Invalid ->
- { empty with verdict ; provers ; trivial ; cached ; failed = 1 }
-
-let results ~smoke prs =
- if not smoke then stats prs
- else
- let verdict, missing =
- List.partition (fun (_,r) -> VCS.is_verdict r) prs in
- let doomed, passed =
- List.partition (fun (_,r) -> VCS.is_valid r) verdict in
- if doomed <> [] then
- stats doomed
- else
- let trivial = List.fold_left
- (fun c (p,r) -> if p = Qed || VCS.is_trivial r then succ c else c)
- 0 passed in
- let cached = List.fold_left
- (fun c (_,r) -> if r.VCS.cached then succ c else c)
- 0 passed in
- let stucked = List.map (fun (p,_) -> p,psmoked) passed in
- let solver = List.fold_left
- (fun t (_,r) -> t +. r.solver_time)
- 0.0 passed in
- let provers = pmerge [Qed,ptime solver false] stucked in
- let verdict =
- if missing <> [] then NoResult else
- match passed with
- | [] -> NoResult
- | u::w -> (snd @@ List.fold_left choose_worst u w).verdict in
- let proved = List.length passed in
- let failed = List.length missing in
- { empty with verdict ; provers ; trivial ; cached ; proved ; failed }
+let cacheable p r = p <> Qed && not @@ VCS.is_trivial r
+let add_cached n (p,r) = if cacheable p r && r.cached then succ n else n
+let add_cachemiss n (p,r) = if cacheable p r && not r.cached then succ n else n
+
+let results ~smoke results =
+ let (p,r) = VCS.best results in
+ let verdict = if smoke then vsmoked r.verdict else r.verdict in
+ let is v = if verdict == v then 1 else 0 in
+ let proved = is Valid in
+ let timeout = is Timeout + is Stepout in
+ let failed = is Failed in
+ let unknown = is Unknown in
+ let noresult = 1 - proved - timeout - failed - unknown in
+ (* ENSURES: noresult <= 0 && subgoals result == 1 *)
+ { (* returns verdict of provers, not verdict for the (smoked) goal *)
+ best = r.verdict ; tactics = 0 ;
+ proved ; timeout ; unknown ; failed ; noresult ;
+ cached = List.fold_left add_cached 0 results ;
+ cachemiss = List.fold_left add_cachemiss 0 results ;
+ provers =
+ if p = Qed then [Qed,if smoke then qsmoked r else pqed r]
+ else
+ pmerge [Qed,psolver r] [p,if smoke then psmoked r else presult r] ;
+ }
let add a b =
if a == empty then b else
if b == empty then a else
{
- verdict = VCS.combine a.verdict b.verdict ;
+ best = VCS.conjunction a.best b.best ;
provers = pmerge a.provers b.provers ;
tactics = a.tactics + b.tactics ;
proved = a.proved + b.proved ;
@@ -208,31 +147,31 @@ let add a b =
unknown = a.unknown + b.unknown ;
noresult = a.noresult + b.noresult ;
failed = a.failed + b.failed ;
- trivial = a.trivial + b.trivial ;
cached = a.cached + b.cached ;
+ cachemiss = a.cachemiss + b.cachemiss ;
}
let tactical ~qed children =
- let valid = List.for_all (fun c -> c.verdict = Valid) children in
+ let valid = List.for_all (fun c -> c.best = Valid) children in
let qed_only = children = [] in
- let verdict = if valid then Valid else Unknown in
+ let best = if valid then Valid else Unknown in
let provers = [Qed,ptime qed qed_only] in
- List.fold_left add { empty with verdict ; provers ; tactics = 1 } children
+ List.fold_left add { empty with best ; provers ; tactics = 1 } children
let script stats =
- let cached = (stats.trivial + stats.cached = stats.proved) in
+ let cached = stats.cachemiss = 0 in
let solver = List.fold_left
(fun t (p,s) -> if p = Qed then t +. s.time else t) 0.0 stats.provers in
let time = List.fold_left
(fun t (p,s) -> if p <> Qed then t +. s.time else t) 0.0 stats.provers in
- VCS.result ~cached ~solver ~time stats.verdict
+ VCS.result ~cached ~solver ~time stats.best
(* -------------------------------------------------------------------------- *)
(* --- Utils --- *)
(* -------------------------------------------------------------------------- *)
-let proofs s = s.proved + s.timeout + s.unknown + s.noresult + s.failed
-let complete s = s.proved = proofs s
+let subgoals s = s.proved + s.timeout + s.unknown + s.noresult + s.failed
+let complete s = s.proved = subgoals s
let pp_pstats fmt p =
if p.tnbr > 0.0 &&
@@ -257,30 +196,21 @@ let pp_pstats fmt p =
Rformat.pp_time p.tmax
let pp_stats ~shell ~cache fmt s =
- let total = proofs s in
- let cacheable = total - s.trivial in
+ let total = subgoals s in
if s.tactics > 1 then
Format.fprintf fmt " (Tactics %d)" s.tactics
else if s.tactics = 1 then
Format.fprintf fmt " (Tactic)" ;
let updating = Cache.is_updating cache in
- let cache_miss =
- Cache.is_active cache && not updating && s.cached < cacheable in
- let qed_only =
- match s.provers with [Qed,_] -> s.proved = total | _ -> false in
- let print_cache =
- not qed_only && Cache.is_active cache &&
- (updating || 0 < s.trivial || 0 < s.cached)
- in
+ let qed_only = match s.provers with [Qed,_] -> true | _ -> false in
+ let print_cache = not qed_only && Cache.is_active cache in
List.iter
(fun (p,pr) ->
let success = truncate pr.success in
- let print_perfo =
- pr.time > Rformat.epsilon &&
- (not shell || cache_miss) in
let print_proofs = success > 0 && total > 1 in
- let print_qed = qed_only && s.verdict = Valid && s.proved = total in
- if p != Qed || print_qed || print_perfo || print_proofs
+ let print_perfo =
+ pr.time > Rformat.epsilon && (not shell || s.cachemiss > 0) in
+ if p != Qed || qed_only || print_perfo || print_proofs
then
begin
let title = VCS.title_of_prover ~version:false p in
@@ -292,15 +222,19 @@ let pp_stats ~shell ~cache fmt s =
Format.fprintf fmt ")"
end
) s.provers ;
- if shell && cache_miss then
- Format.fprintf fmt " (Cache miss %d)" (cacheable - s.cached)
+ if shell && s.cachemiss > 0 && not updating then
+ Format.fprintf fmt " (Cache miss %d)" s.cachemiss
else
if print_cache then
- if s.trivial = total then
- Format.fprintf fmt " (Trivial)"
+ let cacheable = s.cachemiss + s.cached in
+ if cacheable = 0 then
+ if s.best = Valid then
+ Format.pp_print_string fmt " (Trivial)"
+ else
+ Format.pp_print_string fmt " (No Cache)"
else
- if updating || s.cached = cacheable then
- Format.fprintf fmt " (Cached)"
+ if updating || s.cachemiss = 0 then
+ Format.pp_print_string fmt " (Cached)"
else
Format.fprintf fmt " (Cached %d/%d)" s.cached cacheable
diff --git a/src/plugins/wp/Stats.mli b/src/plugins/wp/Stats.mli
index 419fdfc1b813874c21024c0cb66caa6589189ec9..5ac456b19aec6300fdf00a9481bf986c2b5ca95a 100644
--- a/src/plugins/wp/Stats.mli
+++ b/src/plugins/wp/Stats.mli
@@ -38,16 +38,16 @@ type pstats = {
Remark: for each sub-goal, only the _best_ prover result is kept *)
type stats = {
- verdict : VCS.verdict ; (** global verdict *)
+ best : VCS.verdict ; (** provers best verdict (not verdict of the goal) *)
provers : (VCS.prover * pstats) list ; (** meaningfull provers *)
tactics : int ; (** number of tactics *)
proved : int ; (** number of proved sub-goals *)
- trivial : int ; (** number of proved sub-goals with Qed or No-prover time *)
- timeout : int ; (** number of resulting timeouts and stepouts *)
- unknown : int ; (** number of resulting unknown *)
- noresult : int ; (** number of no-result *)
- failed : int ; (** number of resulting failures *)
- cached : int ; (** number of cached (non-trivial) results *)
+ timeout : int ; (** number of timeouts and stepouts sub-goals *)
+ unknown : int ; (** number of unknown sub-goals *)
+ noresult : int ; (** number of no-result sub-goals *)
+ failed : int ; (** number of failed sub-goals *)
+ cached : int ; (** number of cached prover results *)
+ cachemiss : int ; (** number of non-cached prover results *)
}
val pp_pstats : Format.formatter -> pstats -> unit
@@ -65,7 +65,9 @@ val results : smoke:bool -> (VCS.prover * VCS.result) list -> stats
val tactical : qed:float -> stats list -> stats
val script : stats -> VCS.result
-val proofs : stats -> int
+val subgoals : stats -> int
+(* sum of proved + timeout + unit + noresult + failed *)
+
val complete : stats -> bool
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/wp/VCS.ml b/src/plugins/wp/VCS.ml
index e4b0d5f91ee8baa7568ceed61c3eb824b57ce482..2dbd9f76e881be94da9a4932e5215a3dbe0ad677 100644
--- a/src/plugins/wp/VCS.ml
+++ b/src/plugins/wp/VCS.ml
@@ -157,18 +157,22 @@ type config = {
valid : bool ;
timeout : float option ;
stepout : int option ;
+ memlimit : int option ;
}
let current () =
let t = Wp_parameters.Timeout.get () in
let s = Wp_parameters.Steps.get () in
+ let m = Wp_parameters.Memlimit.get () in
{
valid = false ;
timeout = if t > 0 then Some (float t) else None ;
stepout = if s > 0 then Some s else None ;
+ memlimit = if m > 0 then Some m else None ;
}
-let default = { valid = false ; timeout = None ; stepout = None }
+let default =
+ { valid = false ; timeout = None ; stepout = None ; memlimit = None }
let get_timeout ?kf ~smoke = function
| { timeout = None } ->
@@ -186,13 +190,16 @@ let get_stepout = function
| { stepout = None } -> Wp_parameters.Steps.get ()
| { stepout = Some t } -> t
+let get_memlimit = function
+ | { memlimit = None } -> Wp_parameters.Memlimit.get ()
+ | { memlimit = Some t } -> t
+
(* -------------------------------------------------------------------------- *)
(* --- Results --- *)
(* -------------------------------------------------------------------------- *)
type verdict =
| NoResult
- | Invalid
| Unknown
| Timeout
| Stepout
@@ -211,7 +218,7 @@ type result = {
}
let is_result = function
- | Valid | Unknown | Invalid | Timeout | Stepout | Failed -> true
+ | Valid | Unknown | Timeout | Stepout | Failed -> true
| NoResult | Computing _ -> false
let is_verdict r = is_result r.verdict
@@ -219,15 +226,10 @@ let is_valid = function { verdict = Valid } -> true | _ -> false
let is_trivial r = is_valid r && r.prover_time = 0.0
let is_not_valid r = is_verdict r && not (is_valid r)
let is_computing = function { verdict=Computing _ } -> true | _ -> false
-
-let smoked = function
- | (Failed | NoResult | Computing _) as r -> r
- | Valid -> Invalid
- | Invalid | Unknown | Timeout | Stepout -> Valid
-
-let verdict ~smoke r = if smoke then smoked r.verdict else r.verdict
-
-let is_proved ~smoke r = (verdict ~smoke r = Valid)
+let is_proved ~smoke = function
+ | NoResult | Computing _ | Failed -> false
+ | Valid -> not smoke
+ | Unknown | Timeout | Stepout -> smoke
let configure r =
let valid = (r.verdict = Valid) in
@@ -245,10 +247,14 @@ let configure r =
let margin = 1000 in
Some(max stepout margin)
else None in
+ let memlimit =
+ let m = Wp_parameters.Memlimit.get () in
+ if m > 0 then Some m else None in
{
valid ;
timeout ;
stepout ;
+ memlimit ;
}
let time_fits t =
@@ -280,7 +286,6 @@ let result ?(cached=false) ?(solver=0.0) ?(time=0.0) ?(steps=0) verdict =
let no_result = result NoResult
let valid = result Valid
-let invalid = result Invalid
let unknown = result Unknown
let timeout t = result ~time:t Timeout
let stepout n = result ~steps:n Stepout
@@ -320,7 +325,6 @@ let pp_perf_shell fmt r =
let name_of_verdict = function
| NoResult | Computing _ -> "none"
- | Invalid -> "invalid"
| Valid -> "valid"
| Failed -> "failed"
| Unknown -> "unknown"
@@ -331,7 +335,6 @@ let pp_result fmt r =
match r.verdict with
| NoResult -> Format.pp_print_string fmt "No Result"
| Computing _ -> Format.pp_print_string fmt "Computing"
- | Invalid -> Format.pp_print_string fmt "Invalid"
| Failed -> Format.fprintf fmt "Failed@ %s" r.prover_errmsg
| Valid -> Format.fprintf fmt "Valid%a" pp_perf_shell r
| Unknown -> Format.fprintf fmt "Unknown%a" pp_perf_shell r
@@ -341,7 +344,7 @@ let pp_result fmt r =
let is_qualified prover result =
match prover with
| Qed | Tactical -> true
- | Why3 _ -> result.cached || result.prover_time < Rformat.epsilon
+ | Why3 _ -> result.cached || result.prover_time <= Rformat.epsilon
let pp_cache_miss fmt st updating prover result =
if not updating
@@ -358,7 +361,6 @@ let pp_result_qualif ?(updating=true) prover result fmt =
match result.verdict with
| NoResult -> Format.pp_print_string fmt "No Result"
| Computing _ -> Format.pp_print_string fmt "Computing"
- | Invalid -> Format.pp_print_string fmt "Invalid"
| Failed -> Format.fprintf fmt "Failed@ %s" result.prover_errmsg
| Valid -> pp_cache_miss fmt "Valid" updating prover result
| Unknown -> pp_cache_miss fmt "Unsuccess" updating prover result
@@ -367,13 +369,22 @@ let pp_result_qualif ?(updating=true) prover result fmt =
else
pp_result fmt result
+(* highest is best *)
let vrank = function
- | NoResult | Computing _ -> 0
- | Failed -> 1
- | Unknown -> 2
- | Timeout | Stepout -> 3
- | Valid -> 4
- | Invalid -> 5
+ | Computing _ -> 0
+ | NoResult -> 1
+ | Failed -> 2
+ | Unknown -> 3
+ | Timeout -> 4
+ | Stepout -> 5
+ | Valid -> 6
+
+let conjunction a b =
+ match a,b with
+ | Valid,Valid -> Valid
+ | Valid, r -> r
+ | r , Valid -> r
+ | _ -> if vrank b > vrank a then b else a
let compare p q =
let r = vrank q.verdict - vrank p.verdict in
@@ -384,32 +395,5 @@ let compare p q =
if t <> 0 then t else
Stdlib.compare p.solver_time q.solver_time
-let combine v1 v2 =
- match v1 , v2 with
- | Valid , Valid -> Valid
- | Failed , _ | _ , Failed -> Failed
- | Invalid , _ | _ , Invalid -> Invalid
- | Timeout , _ | _ , Timeout -> Timeout
- | Stepout , _ | _ , Stepout -> Stepout
- | _ -> Unknown
-
-let merge r1 r2 =
- let err = if r1.prover_errmsg <> "" then r1 else r2 in
- {
- verdict = combine r1.verdict r2.verdict ;
- cached = r1.cached && r2.cached ;
- solver_time = max r1.solver_time r2.solver_time ;
- prover_time = max r1.prover_time r2.prover_time ;
- prover_steps = max r1.prover_steps r2.prover_steps ;
- prover_errpos = err.prover_errpos ;
- prover_errmsg = err.prover_errmsg ;
- }
-
-let leq r1 r2 =
- match is_valid r1 , is_valid r2 with
- | true , false -> true
- | false , true -> false
- | _ -> compare r1 r2 <= 0
-
-let choose r1 r2 = if leq r1 r2 then r1 else r2
-let best = List.fold_left choose no_result
+let bestp pr1 pr2 = if compare (snd pr1) (snd pr2) <= 0 then pr1 else pr2
+let best = List.fold_left bestp (Qed,no_result)
diff --git a/src/plugins/wp/VCS.mli b/src/plugins/wp/VCS.mli
index f5ecae0ad98af6fd9801480d86414028ac29c025..c269188e552009f6c6c8e82a80e1bc37d5644cac 100644
--- a/src/plugins/wp/VCS.mli
+++ b/src/plugins/wp/VCS.mli
@@ -67,6 +67,7 @@ type config = {
valid : bool ;
timeout : float option ;
stepout : int option ;
+ memlimit : int option ;
}
val current : unit -> config (** Current parameters *)
@@ -76,13 +77,16 @@ val default : config (** all None *)
val get_timeout : ?kf:Kernel_function.t -> smoke:bool -> config -> float
(** 0.0 means no-timeout *)
-val get_stepout : config -> int (** 0 means no-stepout *)
+val get_stepout : config -> int
+(** 0 means no-stepout *)
+
+val get_memlimit : config -> int
+(** 0 means no-memlimit *)
(** {2 Results} *)
type verdict =
| NoResult
- | Invalid
| Unknown
| Timeout
| Stepout
@@ -102,7 +106,6 @@ type result = {
val no_result : result
val valid : result
-val invalid : result
val unknown : result
val stepout : int -> result
val timeout : float -> result
@@ -120,10 +123,7 @@ val is_valid: result -> bool
val is_trivial: result -> bool
val is_not_valid: result -> bool
val is_computing: result -> bool
-val is_proved: smoke:bool -> result -> bool
-
-val smoked : verdict -> verdict
-val verdict: smoke:bool -> result -> verdict
+val is_proved: smoke:bool -> verdict -> bool
val configure : result -> config
val autofit : result -> bool (** Result that fits the default configuration *)
@@ -134,12 +134,8 @@ val pp_result : Format.formatter -> result -> unit
val pp_result_qualif : ?updating:bool -> prover -> result ->
Format.formatter -> unit
-val compare : result -> result -> int (* best is minimal *)
-
-val combine : verdict -> verdict -> verdict
-val merge : result -> result -> result
-val leq : result -> result -> bool
-val choose : result -> result -> result
-val best : result list -> result
+val conjunction : verdict -> verdict -> verdict (* for tactic children *)
+val compare : result -> result -> int (* minimal is best *)
+val best : (prover * result) list -> prover * result
val dkey_shell: Wp_parameters.category
diff --git a/src/plugins/wp/doc/manual/wp_plugin.tex b/src/plugins/wp/doc/manual/wp_plugin.tex
index 4f31910e4a20419e5b56ef1609ab009ea5b3bcb9..f5e86525c3e6defd2266f992ac0f4732a849b30e 100644
--- a/src/plugins/wp/doc/manual/wp_plugin.tex
+++ b/src/plugins/wp/doc/manual/wp_plugin.tex
@@ -1366,8 +1366,10 @@ See \texttt{-wp-interactive <mode>} option for details.
No truncation is performed when the value equals zero. (default is: 60)
\item[\tt -wp-(no)-proof-trace] asks for provers to output extra information
on proved goals when available (default is: \texttt{no}).
-\item[\tt -wp-timeout <n>] sets the timeout (in seconds) for the calls
+\item[\tt -wp-timeout <t>] sets the timeout (in seconds) for the calls
to the decision prover (defaults to 2 seconds).
+\item[\tt -wp-memlimit <m>] sets the memory-limit (in Mb) for the calls
+ to the decision prover (defaults to 1000 Mb).
\item[\tt -wp-fct-timeout <f1:t1,f2:t2,...>] customize the timeout for each
specified function (\texttt{t1} for \texttt{f1}, \texttt{t2} for \texttt{f2},
etc).
diff --git a/src/plugins/wp/gui/GuiList.ml b/src/plugins/wp/gui/GuiList.ml
index 9e83c9070caedd93994eff7af62475499a351db6..149c4edbef0dc558565a89822d19d9d30741ea77 100644
--- a/src/plugins/wp/gui/GuiList.ml
+++ b/src/plugins/wp/gui/GuiList.ml
@@ -51,13 +51,12 @@ let render_prover_result p =
let icn_cut = icn_stock "gtk-cut" in
let icn_running = icn_stock "gtk-execute" in
let open VCS in
- let icon_of_verdict = function
+ let icon_of_verdict ~smoke = function
| NoResult -> icn_none
- | Valid -> icn_valid
- | Invalid -> icn_invalid
- | Unknown -> icn_unknown
+ | Valid -> if smoke then icn_invalid else icn_valid
+ | Unknown -> if smoke then icn_valid else icn_unknown
+ | Timeout | Stepout -> if smoke then icn_valid else icn_cut
| Failed -> icn_failed
- | Timeout | Stepout -> icn_cut
| Computing _ -> icn_running
in fun w ->
match Wpo.get_result w p , p with
@@ -71,8 +70,7 @@ let render_prover_result p =
| `Saved -> icn_stock "gtk-file"
end
| result , _ ->
- let smoke = Wpo.is_smoke_test w in
- icon_of_verdict (VCS.verdict ~smoke result)
+ icon_of_verdict ~smoke:(Wpo.is_smoke_test w) result.verdict
class pane (gprovers:GuiConfig.provers) =
let model = new model in
diff --git a/src/plugins/wp/gui/GuiProver.ml b/src/plugins/wp/gui/GuiProver.ml
index 7f02b9f6fa7f86d59e6cc41cfde465b8d68df89b..523508a224cf9e6be1e6674fdb70080c3e76e847 100644
--- a/src/plugins/wp/gui/GuiProver.ml
+++ b/src/plugins/wp/gui/GuiProver.ml
@@ -87,10 +87,12 @@ class prover ~(console:Wtext.text) ~prover =
method private run wpo =
begin
let spinner = function None -> None | Some s -> Some s#get in
+ let m = Wp_parameters.Memlimit.get () in
let config = {
VCS.valid = false ;
VCS.timeout = Option.map float @@ spinner timeout ;
VCS.stepout = spinner stepout ;
+ VCS.memlimit = if m > 0 then Some m else None ;
} in
let result wpo _prv _res = self#update wpo in
let task = Prover.prove ~config ~result wpo prover in
@@ -132,7 +134,7 @@ class prover ~(console:Wtext.text) ~prover =
self#set_action ~tooltip:"Run Prover" ~icon:`MEDIA_PLAY ~callback () ;
Pretty_utils.ksfprintf self#set_label "%a (%a)" VCS.pp_prover prover
Rformat.pp_time res.VCS.prover_time ;
- | VCS.Invalid | VCS.Unknown | VCS.Timeout | VCS.Stepout ->
+ | VCS.Unknown | VCS.Timeout | VCS.Stepout ->
let callback () = self#run wpo in
self#set_status ko_status ;
self#set_action ~tooltip:"Run Prover" ~icon:`MEDIA_PLAY ~callback () ;
diff --git a/src/plugins/wp/prover.ml b/src/plugins/wp/prover.ml
index 20a71c6c7a5f3c5e091a1749e6bb9a7844c73ade..e4772baa126291170bcf014e906fc17c7da28fc9 100644
--- a/src/plugins/wp/prover.ml
+++ b/src/plugins/wp/prover.ml
@@ -42,6 +42,7 @@ let dispatch ?(config=VCS.default) mode prover wpo =
ProverWhy3.prove
~timeout:(VCS.get_timeout ?kf ~smoke config)
~steplimit:(VCS.get_stepout config)
+ ~memlimit:(VCS.get_memlimit config)
~mode ~prover wpo
end
diff --git a/src/plugins/wp/register.ml b/src/plugins/wp/register.ml
index 3b5f932999ac3233b3e619b243c2da003ecfe92b..6938108da2ec1957cb2c5060e2b3818e4e7f5c38 100644
--- a/src/plugins/wp/register.ml
+++ b/src/plugins/wp/register.ml
@@ -187,16 +187,19 @@ module GOALS = Wpo.S.Set
let scheduled = ref 0
let exercised = ref 0
let session = ref GOALS.empty
-let global_stats = ref Stats.empty
-let script_stats = ref Stats.empty
+let prover_stats = ref Stats.empty
+let tactic_stats = ref Stats.empty
+let smoked_passed = ref 0
+let smoked_failed = ref 0
+let add_stats r s = r := Stats.add !r s
let clear_scheduled () =
begin
scheduled := 0 ;
exercised := 0 ;
session := GOALS.empty ;
- global_stats := Stats.empty ;
- script_stats := Stats.empty ;
+ prover_stats := Stats.empty ;
+ tactic_stats := Stats.empty ;
CfgInfos.trivial_terminates := 0 ;
WpReached.unreachable_proved := 0 ;
WpReached.unreachable_failed := 0 ;
@@ -304,8 +307,8 @@ let stats_to_json g (s : Stats.stats) : Json.t =
"function", `String (Kernel_function.get_name kf);
"behavior", `String bhv ;
] in
- let proofs = Stats.proofs s in
- let subgoals = if proofs > 1 then ["subgoals", `Int proofs] else [] in
+ let subgoals = Stats.subgoals s in
+ let subgoals = if subgoals > 1 then ["subgoals", `Int subgoals] else [] in
`Assoc
([
"goal", `String g.po_gid ;
@@ -315,7 +318,7 @@ let stats_to_json g (s : Stats.stats) : Json.t =
] @ index @ [
"smoke", `Bool smoke ;
"passed", `Bool (Wpo.is_passed g) ;
- "verdict", `String (VCS.name_of_verdict s.verdict) ;
+ "verdict", `String (VCS.name_of_verdict s.best) ;
] @ script @ [
"provers", `List (List.map pstats_to_json s.provers) ;
] @ subgoals @
@@ -351,21 +354,19 @@ let do_wpo_result goal prover res =
let do_report_stats ~shell ~cache ~smoke goal (stats : Stats.stats) =
let status =
if smoke then
- match stats.verdict with
+ match stats.best with
| Valid -> "[Failed] (Doomed)"
- | Failed -> "[Unknown] (Failure)"
+ | Failed -> "[Failure] (Solver Error)"
| NoResult | Computing _ -> "[Unknown] (Incomplete)"
| (Unknown | Timeout | Stepout) when shell -> "[Passed] (Unsuccess)"
| Unknown -> "[Passed] (Unknown)"
| Timeout -> "[Passed] (Timeout)"
| Stepout -> "[Passed] (Stepout)"
- | Invalid -> "[Passed] (Invalid)"
else
- match stats.verdict with
+ match stats.best with
| NoResult when shell -> "[CacheMiss]"
| NoResult | Computing _ -> ""
| Valid -> "[Valid]"
- | Invalid -> "[Invalid]"
| Failed -> "[Failure]"
| (Unknown | Timeout | Stepout) when shell -> "[Unsuccess]"
| Unknown -> "[Unknown]"
@@ -386,13 +387,16 @@ let do_wpo_success ~shell ~cache goal success =
else
let gui = Frama_c_very_first.Gui_init.is_gui in
let smoke = Wpo.is_smoke_test goal in
- let gstats = Stats.results ~smoke @@ Wpo.get_results goal in
+ let pstats = Stats.results ~smoke @@ Wpo.get_results goal in
let cstats = ProofEngine.consolidated goal in
let success = Wpo.is_passed goal in
begin
- global_stats := Stats.add !global_stats gstats ;
- if cstats.tactics > 0 then
- script_stats := Stats.add !script_stats cstats ;
+ add_stats prover_stats pstats ;
+ if smoke then
+ (if Wpo.is_passed goal
+ then incr smoked_passed
+ else incr smoked_failed) ;
+ if cstats.tactics > 0 then add_stats tactic_stats cstats ;
if gui || shell || not success then
do_report_stats ~shell ~cache goal ~smoke cstats ;
if smoke then
@@ -416,7 +420,7 @@ let do_report_scheduled () =
!CfgInfos.trivial_terminates in
if total > 0 then
begin
- let gstats = !global_stats in
+ let proofs = !prover_stats in
let unreachable = !WpReached.unreachable_proved in
let terminating = !CfgInfos.trivial_terminates in
let passed = GOALS.fold
@@ -439,22 +443,28 @@ let do_report_scheduled () =
if success > 0 || (not shell && p = Qed) then
add_line name success (fun fmt ->
if p = Tactical then
- Stats.pp_stats ~shell ~cache fmt !script_stats
+ Stats.pp_stats ~shell ~cache fmt !tactic_stats
else
if not shell then Stats.pp_pstats fmt s
)
- ) gstats.provers ;
- if gstats.failed > 0 then add_line "Failed" gstats.failed none ;
+ ) proofs.provers ;
+ let failed = proofs.failed in
+ if failed > 0 then add_line "Failed" failed none ;
if shell then
begin
- let n = gstats.timeout + gstats.unknown in
+ let n = Stats.subgoals proofs - proofs.proved - proofs.failed in
if n > 0 then add_line "Unsuccess" n none
end
else
begin
- if gstats.timeout > 0 then add_line "Timeout" gstats.timeout none ;
- if gstats.unknown > 0 then add_line "Unknown" gstats.unknown none ;
+ if proofs.timeout > 0 then add_line "Timeout" proofs.timeout none ;
+ if proofs.unknown > 0 then add_line "Unknown" proofs.unknown none ;
end ;
+ let smoked = !smoked_failed + !smoked_passed in
+ if smoked > 0 then
+ add_line "Smoke Tests" !smoked_passed
+ (fun fmt -> Format.fprintf fmt " / %d" smoked) ;
+ if proofs.noresult > 0 then add_line "Missing" proofs.noresult none ;
let iter f = List.iter f (List.rev !lines) in
let title (p,_,_) = p in
let pp_title fmt p = Format.fprintf fmt "%s:" p in
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/bsearch.res.oracle b/src/plugins/wp/tests/wp_gallery/oracle_qualif/bsearch.res.oracle
index c75c338b4d431d99a7dd3cca35a905f104857fc7..941e0fbf7df48062fd13ce83e8a81717347d1701 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/bsearch.res.oracle
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/bsearch.res.oracle
@@ -34,6 +34,7 @@
[wp] Proved goals: 28 / 28
Qed: 8
Alt-Ergo: 20
+ Smoke Tests: 7 / 7
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
binary_search 8 20 28 100%
diff --git a/src/plugins/wp/tests/wp_gallery/oracle_qualif/euclid.res.oracle b/src/plugins/wp/tests/wp_gallery/oracle_qualif/euclid.res.oracle
index 878ff5856b1bbae91f2c31b595fc50021f882abd..ff7e6a81f3c651110c4bab17e0dc86e31ae892f9 100644
--- a/src/plugins/wp/tests/wp_gallery/oracle_qualif/euclid.res.oracle
+++ b/src/plugins/wp/tests/wp_gallery/oracle_qualif/euclid.res.oracle
@@ -22,6 +22,7 @@
[wp] Proved goals: 16 / 16
Qed: 7
Alt-Ergo: 9
+ Smoke Tests: 5 / 5
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
euclid_gcd 7 9 16 100%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed.res.oracle
index be42e31957648f4ab6d0fb3a4a0075e72a445a72..fcd999d276581a5f2c7b1c45600b70ed4cdb32df 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed.res.oracle
@@ -13,8 +13,10 @@
[wp] doomed.i:41: Warning: Failed smoke-test
[wp] [Valid] typed_buzz_ensures (Qed)
[wp] Proved goals: 5 / 7
- Qed: 4
+ Qed: 2
Alt-Ergo: 3
+ Failed: 2
+ Smoke Tests: 3 / 5
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
foo - 2 3 66.7%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_axioms.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_axioms.res.oracle
index 156fa5567f5d31460248604a16c128e2badc92f4..290311caf6a246d280f80d61f91c846b910b186f 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_axioms.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_axioms.res.oracle
@@ -18,7 +18,9 @@
[wp] [Valid] typed_foo_loop_assigns (Qed)
[wp] Proved goals: 7 / 10
Qed: 1
- Alt-Ergo: 9
+ Alt-Ergo: 6
+ Failed: 3
+ Smoke Tests: 0 / 3
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
foo 1 6 10 70.0%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_call.1.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_call.1.res.oracle
index 053984aed19d132e0de7d0e56d4a924f2b3db924..c344cd19769a2e2de57477ace6992ef7b915cef8 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_call.1.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_call.1.res.oracle
@@ -41,8 +41,10 @@
[wp] [Failed] (Doomed) typed_f5_ko_wp_smoke_dead_code_s36 (Qed)
[wp] [Valid] typed_f5_ko_ensures (Qed)
[wp] Proved goals: 28 / 33
- Qed: 15
+ Qed: 10
Alt-Ergo: 18
+ Failed: 5
+ Smoke Tests: 18 / 23
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
f1_ok 2 3 5 100%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_call.2.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_call.2.res.oracle
index b14c7877833655b73d792637d3590c03ac47c185..82a6a29f48987b82d7a175d483ebccc05c62a287 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_call.2.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_call.2.res.oracle
@@ -44,8 +44,10 @@
[wp] [Failed] (Doomed) typed_f5_ko_wp_smoke_dead_code_s36 (Qed)
[wp] [Valid] typed_f5_ko_ensures (Qed)
[wp] Proved goals: 31 / 36
- Qed: 18
+ Qed: 13
Alt-Ergo: 18
+ Failed: 5
+ Smoke Tests: 18 / 23
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
f1_ok 3 3 6 100%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_dead.0.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_dead.0.res.oracle
index b4ed26cadbc501c4601eecb4d1529d42a701120c..e4957a6be52db8c758e650b6af2fb4a9eaf50d83 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_dead.0.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_dead.0.res.oracle
@@ -52,8 +52,10 @@
[wp] [Valid] typed_f5_ko_assigns_part3 (Qed)
[wp] [Valid] typed_f5_ko_assigns_part4 (Qed)
[wp] Proved goals: 44 / 46
- Qed: 25
+ Qed: 23
Alt-Ergo: 21
+ Failed: 2
+ Smoke Tests: 21 / 23
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
f1_ok 2 3 5 100%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_dead.1.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_dead.1.res.oracle
index 7af31c3fade31c46da6450fb0c3854db349c6566..f48bd8b14437be9a2441cb19599e2fd434c46e0e 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_dead.1.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_dead.1.res.oracle
@@ -54,8 +54,10 @@
[wp] [Valid] typed_f5_ko_assigns_part3 (Qed)
[wp] [Valid] typed_f5_ko_assigns_part4 (Qed)
[wp] Proved goals: 46 / 48
- Qed: 27
+ Qed: 25
Alt-Ergo: 21
+ Failed: 2
+ Smoke Tests: 21 / 23
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
f1_ok 3 3 6 100%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_localinit.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_localinit.res.oracle
index 95c235146e535dac095a694750bb20b685f91747..51dbf06fb40837805d513c33297bee6e0312dd0c 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_localinit.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_localinit.res.oracle
@@ -9,9 +9,10 @@
[wp] [Unsuccess] typed_access_assert_rte_mem_access (Alt-Ergo) (Cached)
[wp] [Unsuccess] typed_access_assert_rte_mem_access_2 (Alt-Ergo) (Cached)
[wp] Proved goals: 1 / 4
- Qed: 1
Alt-Ergo: 1
+ Failed: 1
Unsuccess: 2
+ Smoke Tests: 1 / 2
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
access - 1 4 25.0%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_loop.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_loop.res.oracle
index 795cba15889bf823b0ccc090e1b759a6b53a9774..afce87cbbb7c3df4b907d562606344e04d95761d 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_loop.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_loop.res.oracle
@@ -15,8 +15,10 @@
[wp] [Unsuccess] typed_foo_loop_invariant_B_established (Alt-Ergo) (Cached)
[wp] [Valid] typed_foo_loop_assigns (Qed)
[wp] Proved goals: 3 / 8
- Qed: 6
+ Qed: 3
+ Failed: 3
Unsuccess: 2
+ Smoke Tests: 0 / 3
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
foo 3 - 8 37.5%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_pre.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_pre.res.oracle
index 01424e5495b63ed3f47182926e6abc9de38dcf3b..491593a51571da6e404faf69d5b465d1706be26e 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_pre.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_pre.res.oracle
@@ -24,8 +24,9 @@
[wp] doomed_pre.i:56: Warning: Failed smoke-test
[wp] [Failed] (Doomed) typed_reqs_massumes_wp_smoke_B2_assumes (Qed)
[wp] Proved goals: 5 / 13
- Qed: 8
Alt-Ergo: 5
+ Failed: 8
+ Smoke Tests: 5 / 13
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
requires - - 1 0.0%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_report_ko.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_report_ko.res.oracle
index 69ed4be30c1d63140a778bcd5da04bda2d80330f..45d3c52ddf2f23300e713d6e55826e3d155cf856 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_report_ko.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_report_ko.res.oracle
@@ -18,7 +18,9 @@
[wp] [Valid] typed_foo_loop_assigns (Qed)
[wp] Proved goals: 7 / 10
Qed: 1
- Alt-Ergo: 9
+ Alt-Ergo: 6
+ Failed: 3
+ Smoke Tests: 0 / 3
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
foo 1 6 10 70.0%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_report_ok.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_report_ok.res.oracle
index 55cd06942066ed5382e7c9f767113921847c7bde..fff595a824c4aed16d8083f8491c4290bc8921b2 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_report_ok.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_report_ok.res.oracle
@@ -16,6 +16,7 @@
[wp] Proved goals: 10 / 10
Qed: 1
Alt-Ergo: 9
+ Smoke Tests: 3 / 3
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
foo 1 9 10 100%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_unreach.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_unreach.res.oracle
index 7038457d7b29e1d35ba7a36a96c87f1a8f84d644..f951ad709d1a1be7915a9a97706998a25c4436a3 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_unreach.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_unreach.res.oracle
@@ -15,6 +15,7 @@
[wp] Proved goals: 6 / 9
Qed: 3
Alt-Ergo: 3
+ Smoke Tests: 3 / 3
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
job 3 3 6 100%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_unroll.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_unroll.res.oracle
index cf04c0de469c4e65ceaca1d1f3491322be7829e4..122ab2295f2ed77a9d5c5c3df2166599f4f3d240 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_unroll.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/doomed_unroll.res.oracle
@@ -13,6 +13,7 @@
[wp] Proved goals: 5 / 5
Qed: 2
Alt-Ergo: 3
+ Smoke Tests: 3 / 3
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
foo 2 3 5 100%
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/no_step_limit.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/no_step_limit.res.oracle
index 0ad955337d7de65fff2945690804cd5a4d4f4b11..ff42726ec4f0ae761151968716b043fb0bcd6799 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/no_step_limit.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/no_step_limit.res.oracle
@@ -3,6 +3,6 @@
[wp] Running WP plugin...
[wp] 1 goal scheduled
[wp] Warning: no-steps does not support steps limit (ignored option)
-[wp] [Unsuccess] typed_lemma_truc (no-steps)
+[wp] [Unsuccess] typed_lemma_truc (no-steps) (Cache miss 1)
[wp] Proved goals: 0 / 1
Unsuccess: 1
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/nosession.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/nosession.res.oracle
index a4605ebc81ec10c48b22f8751fef0f9118f86578..6f1edb60029948afc5586455b6b86589d4f094d8 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/nosession.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/nosession.res.oracle
@@ -3,5 +3,7 @@
[wp] Running WP plugin...
[wp] Warning: Missing RTE guards
[wp] 1 goal scheduled
-[wp] [CacheMiss] typed_f_ensures (Cache miss 1)
+[wp] [CacheMiss] typed_f_ensures (Qed)
[wp] Proved goals: 0 / 1
+ Unsuccess: 1
+ Missing: 1
diff --git a/src/plugins/wp/tests/wp_plugin/oracle_qualif/unsigned.res.oracle b/src/plugins/wp/tests/wp_plugin/oracle_qualif/unsigned.res.oracle
index 45759f9d1ab8a1bda0d781e5305b6f4370d4c6bf..234a6e8800cbb1e17294a80ef6c682dabc16a0f0 100644
--- a/src/plugins/wp/tests/wp_plugin/oracle_qualif/unsigned.res.oracle
+++ b/src/plugins/wp/tests/wp_plugin/oracle_qualif/unsigned.res.oracle
@@ -2,7 +2,7 @@
[kernel] Parsing unsigned.i (no preprocessing)
[wp] Running WP plugin...
[wp] 1 goal scheduled
-[wp] [Unsuccess] typed_lemma_U32 (Tactic)
+[wp] [Unsuccess] typed_lemma_U32 (Tactic) (Qed 1/2)
[wp] Proved goals: 0 / 1
Unsuccess: 1
------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_tip/oracle/clear.res.oracle b/src/plugins/wp/tests/wp_tip/oracle/clear.res.oracle
index c5e19ea143c1c542d7e23d7b2e4ad7b88e67a06c..e390eec778646a544661b29830fa67d746e39c68 100644
--- a/src/plugins/wp/tests/wp_tip/oracle/clear.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle/clear.res.oracle
@@ -105,7 +105,7 @@
Prove: P_S(42).
------------------------------------------------------------
-[wp] [Unsuccess] typed_clear_in_step_check (Tactics 3)
+[wp] [Unsuccess] typed_clear_in_step_check (Tactics 3) (Qed)
[wp:script:allgoals]
typed_clear_ensures subgoal:
@@ -143,6 +143,6 @@
Prove: P_S(a + b).
------------------------------------------------------------
-[wp] [Unsuccess] typed_clear_ensures (Tactics 7)
+[wp] [Unsuccess] typed_clear_ensures (Tactics 7) (Qed)
[wp] Proved goals: 0 / 2
Unsuccess: 2
diff --git a/src/plugins/wp/tests/wp_tip/oracle/induction_typing.res.oracle b/src/plugins/wp/tests/wp_tip/oracle/induction_typing.res.oracle
index 525e7f8c16415f3f4014af852863c6498dd227a4..01698843ed0f6cec185677e6a2c23661639ff4fb 100644
--- a/src/plugins/wp/tests/wp_tip/oracle/induction_typing.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle/induction_typing.res.oracle
@@ -54,7 +54,6 @@
Prove: false.
------------------------------------------------------------
-[wp] [Unsuccess] typed_function_loop_invariant_X_preserved (Tactic)
[wp:script:allgoals]
typed_function_loop_invariant_X_preserved subgoal:
@@ -115,6 +114,7 @@
Prove: ([ 1 ] *^ n) = a_1.
------------------------------------------------------------
+[wp] [Unsuccess] typed_function_loop_invariant_X_preserved (Tactic) (Qed)
[wp] Proved goals: 1 / 2
Qed: 1
Unsuccess: 1
diff --git a/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.1.res.log b/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.1.res.log
new file mode 100644
index 0000000000000000000000000000000000000000..156dcb6f4b6886e5bc4a007150313b367c1928f3
--- /dev/null
+++ b/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.1.res.log
@@ -0,0 +1 @@
+[kernel] Parsing pp-trailing.c (with preprocessing)
diff --git a/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.2.res.log b/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.2.res.log
new file mode 100644
index 0000000000000000000000000000000000000000..6194cd7f4086802ddd27c811f3b007b4151a7b28
--- /dev/null
+++ b/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.2.res.log
@@ -0,0 +1 @@
+[kernel] Parsing pp-trailing.c.reparse.c (with preprocessing)
diff --git a/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.out.c b/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.out.c
new file mode 100644
index 0000000000000000000000000000000000000000..8e61dec3534fb7d5dedb5776b2504ea90a2a225b
--- /dev/null
+++ b/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.out.c
@@ -0,0 +1,11 @@
+/* Generated by Frama-C */
+/*@ strategy Prover: \prover("alt-ergo",0.1); */
+/*@
+strategy Lazy:
+ Prover,
+ \tactic("Wp.overflow",
+ \pattern(\target:\any(P(_, (..)), Q((..)))),
+ \select(\target)
+ );
+*/
+
diff --git a/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.reparse.c b/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.reparse.c
new file mode 100644
index 0000000000000000000000000000000000000000..8e61dec3534fb7d5dedb5776b2504ea90a2a225b
--- /dev/null
+++ b/src/plugins/wp/tests/wp_tip/oracle/pp-trailing.c.reparse.c
@@ -0,0 +1,11 @@
+/* Generated by Frama-C */
+/*@ strategy Prover: \prover("alt-ergo",0.1); */
+/*@
+strategy Lazy:
+ Prover,
+ \tactic("Wp.overflow",
+ \pattern(\target:\any(P(_, (..)), Q((..)))),
+ \select(\target)
+ );
+*/
+
diff --git a/src/plugins/wp/tests/wp_tip/oracle/split.res.oracle b/src/plugins/wp/tests/wp_tip/oracle/split.res.oracle
index 842c6408c914ac78209bc90a8d173d486ca2a15f..25c7911f7d10c4ddc1cc2094ff0cc4963e52066a 100644
--- a/src/plugins/wp/tests/wp_tip/oracle/split.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle/split.res.oracle
@@ -201,7 +201,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_branch_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_branch_ensures subgoal:
@@ -216,6 +215,7 @@
Prove: P_S.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_branch_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_step_or_ensures subgoal:
@@ -224,7 +224,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_or_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_or_ensures subgoal:
@@ -241,6 +240,7 @@
Prove: P_S.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_or_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_step_and_ensures subgoal:
@@ -256,7 +256,7 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_and_ensures (Tactic)
+[wp] [Unsuccess] typed_test_step_and_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_step_peq_ensures subgoal:
@@ -265,7 +265,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_peq_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_peq_ensures subgoal:
@@ -274,6 +273,7 @@
Prove: P_S.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_peq_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_step_pneq_ensures subgoal:
@@ -282,7 +282,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_pneq_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_pneq_ensures subgoal:
@@ -291,6 +290,7 @@
Prove: P_S.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_pneq_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_step_neq_ensures subgoal:
@@ -299,7 +299,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_neq_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_neq_ensures subgoal:
@@ -316,6 +315,7 @@
Prove: P_S.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_neq_ensures (Tactic) (Qed 1/3)
[wp:script:allgoals]
typed_test_step_leq_ensures subgoal:
@@ -324,7 +324,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_leq_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_leq_ensures subgoal:
@@ -340,6 +339,7 @@
Prover Qed returns Valid
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_leq_ensures (Tactic) (Qed 1/3)
[wp:script:allgoals]
typed_test_step_lt_ensures subgoal:
@@ -354,7 +354,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_lt_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_lt_ensures subgoal:
@@ -370,6 +369,7 @@
Prover Qed returns Valid
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_lt_ensures (Tactic) (Qed 1/3)
[wp:script:allgoals]
typed_test_step_if_ensures subgoal:
@@ -379,7 +379,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_if_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_if_ensures subgoal:
@@ -392,6 +391,7 @@
Prove: P_S.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_if_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_step_fa_if_ensures subgoal:
@@ -405,7 +405,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_fa_if_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_fa_if_ensures subgoal:
@@ -419,6 +418,7 @@
Prove: P_S.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_fa_if_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_step_fa_or_ensures subgoal:
@@ -427,7 +427,6 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_fa_or_ensures (Tactic)
[wp:script:allgoals]
typed_test_step_fa_or_ensures subgoal:
@@ -436,6 +435,7 @@
Prove: P_S.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_step_fa_or_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_step_fa_and_ensures subgoal:
@@ -448,7 +448,7 @@
Prove: P_S.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_step_fa_and_ensures (Tactic)
+[wp] [Unsuccess] typed_test_step_fa_and_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_inside_leq_ensures subgoal:
@@ -463,7 +463,6 @@
Prove: P_Q.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_inside_leq_ensures (Tactic)
[wp:script:allgoals]
typed_test_inside_leq_ensures subgoal:
@@ -480,6 +479,7 @@
Prover Qed returns Valid
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_inside_leq_ensures (Tactic) (Qed 1/3)
[wp:script:allgoals]
typed_test_inside_lt_ensures subgoal:
@@ -494,7 +494,6 @@
Prove: P_Q.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_inside_lt_ensures (Tactic)
[wp:script:allgoals]
typed_test_inside_lt_ensures subgoal:
@@ -511,6 +510,7 @@
Prover Qed returns Valid
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_inside_lt_ensures (Tactic) (Qed 1/3)
[wp:script:allgoals]
typed_test_inside_neq_ensures subgoal:
@@ -525,7 +525,6 @@
Prove: P_Q.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_inside_neq_ensures (Tactic)
[wp:script:allgoals]
typed_test_inside_neq_ensures subgoal:
@@ -548,6 +547,7 @@
Prove: P_Q.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_inside_neq_ensures (Tactic) (Qed 1/3)
[wp:script:allgoals]
typed_test_goal_and_ensures subgoal:
@@ -556,7 +556,6 @@
Prove: P_P.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_goal_and_ensures (Tactic)
[wp:script:allgoals]
typed_test_goal_and_ensures subgoal:
@@ -573,6 +572,7 @@
Prove: P_R.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_goal_and_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_goal_eq_ensures subgoal:
@@ -581,7 +581,6 @@
Prove: (L_LP=true).
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_goal_eq_ensures (Tactic)
[wp:script:allgoals]
typed_test_goal_eq_ensures subgoal:
@@ -590,6 +589,7 @@
Prove: (L_LQ=true).
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_goal_eq_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_goal_neq_ensures subgoal:
@@ -598,7 +598,6 @@
Prove: (L_LP=false).
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_goal_neq_ensures (Tactic)
[wp:script:allgoals]
typed_test_goal_neq_ensures subgoal:
@@ -607,6 +606,7 @@
Prove: (L_LQ=false).
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_goal_neq_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_goal_if_ensures subgoal:
@@ -620,7 +620,6 @@
Prove: P_P.
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_goal_if_ensures (Tactic)
[wp:script:allgoals]
typed_test_goal_if_ensures subgoal:
@@ -634,6 +633,7 @@
Prove: P_Q.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_goal_if_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_goal_ex_and_ensures subgoal:
@@ -642,7 +642,6 @@
Prove: exists i : Z. P_Pi(i) /\ P_Qi(i).
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_goal_ex_and_ensures (Tactic)
[wp:script:allgoals]
typed_test_goal_ex_and_ensures subgoal:
@@ -651,6 +650,7 @@
Prove: P_P /\ P_Q.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_goal_ex_and_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_goal_ex_or_ensures subgoal:
@@ -659,7 +659,7 @@
Prove: P_P \/ P_Q \/ (exists i : Z. P_Pi(i)) \/ (exists i : Z. P_Qi(i)).
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_goal_ex_or_ensures (Tactic)
+[wp] [Unsuccess] typed_test_goal_ex_or_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_goal_ex_if_ensures subgoal:
@@ -674,7 +674,6 @@
Prove: exists i : Z. P_Pi(i) /\ P_Qi(i).
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_goal_ex_if_ensures (Tactic)
[wp:script:allgoals]
typed_test_goal_ex_if_ensures subgoal:
@@ -689,6 +688,7 @@
Prove: P_P /\ P_Q.
------------------------------------------------------------
+[wp] [Unsuccess] typed_test_goal_ex_if_ensures (Tactic) (Qed)
[wp:script:allgoals]
typed_test_goal_ex_imply_ensures subgoal:
@@ -702,6 +702,6 @@
Prove: exists i : Z. P_Qi(i).
------------------------------------------------------------
-[wp] [Unsuccess] typed_test_goal_ex_imply_ensures (Tactic)
+[wp] [Unsuccess] typed_test_goal_ex_imply_ensures (Tactic) (Qed)
[wp] Proved goals: 0 / 23
Unsuccess: 23
diff --git a/src/plugins/wp/tests/wp_tip/oracle_qualif/induction.1.res.oracle b/src/plugins/wp/tests/wp_tip/oracle_qualif/induction.1.res.oracle
index 9df7047dfa86198c150f1617988e6fe8e1f2d53b..84e63024f8e5e0dda5c2b1df5100270966bbde08 100644
--- a/src/plugins/wp/tests/wp_tip/oracle_qualif/induction.1.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle_qualif/induction.1.res.oracle
@@ -2,7 +2,7 @@
[kernel] Parsing induction.i (no preprocessing)
[wp] Running WP plugin...
[wp] 1 goal scheduled
-[wp] [Unsuccess] typed_lemma_ByInd (Tactic)
+[wp] [Unsuccess] typed_lemma_ByInd (Tactic) (Alt-Ergo) (Cached)
[wp] Proved goals: 0 / 1
Unsuccess: 1
------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_tip/oracle_qualif/induction.2.res.oracle b/src/plugins/wp/tests/wp_tip/oracle_qualif/induction.2.res.oracle
index 9df7047dfa86198c150f1617988e6fe8e1f2d53b..84e63024f8e5e0dda5c2b1df5100270966bbde08 100644
--- a/src/plugins/wp/tests/wp_tip/oracle_qualif/induction.2.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle_qualif/induction.2.res.oracle
@@ -2,7 +2,7 @@
[kernel] Parsing induction.i (no preprocessing)
[wp] Running WP plugin...
[wp] 1 goal scheduled
-[wp] [Unsuccess] typed_lemma_ByInd (Tactic)
+[wp] [Unsuccess] typed_lemma_ByInd (Tactic) (Alt-Ergo) (Cached)
[wp] Proved goals: 0 / 1
Unsuccess: 1
------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.0.res.oracle b/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.0.res.oracle
index 0bcfae5a92959b95342e01fa937cd88c40831ebe..77beeea6b7706f738f9963ad858c25b49ea5e7e9 100644
--- a/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.0.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.0.res.oracle
@@ -20,6 +20,7 @@ Assume {
}
Prove: P_P(to_sint32(t + to_uint32(z + to_uint32(x + y)))).
Prover Alt-Ergo returns Unsuccess
+Prover Script returns Unsuccess
------------------------------------------------------------
------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.1.res.oracle b/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.1.res.oracle
index a439255effce75c9e03ad1957717ddcc7e77cf90..c4fd1d0306e7bf62a3085ec1bf633506058ba7ee 100644
--- a/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.1.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.1.res.oracle
@@ -4,7 +4,7 @@
[wp] Warning: Missing RTE guards
[wp] 2 goals scheduled
[wp] [Valid] typed_target_assigns (Qed)
-[wp] [Unsuccess] typed_target_ensures (Tactics 13)
+[wp] [Unsuccess] typed_target_ensures (Tactics 13) (Alt-Ergo 26/27) (Cached)
[wp] Proved goals: 1 / 2
Qed: 1
Unsuccess: 1
diff --git a/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.2.res.oracle b/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.2.res.oracle
index ca5793fb1a1ba8e7da0c82f34edb192a2236e25c..e5f1d01e1afab6dd588a131d94f86779308be980 100644
--- a/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.2.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.2.res.oracle
@@ -4,7 +4,7 @@
[wp] Warning: Missing RTE guards
[wp] 2 goals scheduled
[wp] [Valid] typed_target_assigns (Qed)
-[wp] [Unsuccess] typed_target_ensures (Tactics 3) (Alt-Ergo 4/4) (Cached)
+[wp] [Unsuccess] typed_target_ensures (Tactics 3) (Alt-Ergo 6/7) (Cached)
[wp] Proved goals: 1 / 2
Qed: 1
Unsuccess: 1
diff --git a/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.3.res.oracle b/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.3.res.oracle
index ad30c792620a6ac36164a3de5f3a7eb8bcfff589..5ab1dd34d9154742138734256a234993ed4f182a 100644
--- a/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.3.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle_qualif/strategy.3.res.oracle
@@ -4,7 +4,7 @@
[wp] Warning: Missing RTE guards
[wp] 2 goals scheduled
[wp] [Valid] typed_target_assigns (Qed)
-[wp] [Unsuccess] typed_target_ensures (Tactics 3) (Alt-Ergo 4/4) (Cached)
+[wp] [Unsuccess] typed_target_ensures (Tactics 3) (Alt-Ergo 6/7) (Cached)
[wp] Proved goals: 1 / 2
Qed: 1
Unsuccess: 1
diff --git a/src/plugins/wp/tests/wp_tip/oracle_qualif/tac_split_quantifiers.res.oracle b/src/plugins/wp/tests/wp_tip/oracle_qualif/tac_split_quantifiers.res.oracle
index 78efb6216be0db759028dca1a8ff6025ae5a407d..70c32d4d2f10dd32526aa4834b87c775f614921f 100644
--- a/src/plugins/wp/tests/wp_tip/oracle_qualif/tac_split_quantifiers.res.oracle
+++ b/src/plugins/wp/tests/wp_tip/oracle_qualif/tac_split_quantifiers.res.oracle
@@ -3,11 +3,11 @@
[wp] Running WP plugin...
[wp] Warning: Missing RTE guards
[wp] 5 goals scheduled
-[wp] [Unsuccess] typed_split_ensures_Goal_Exist_Or (Tactic)
-[wp] [Unsuccess] typed_split_ensures_Goal_Exist_And (Tactic)
-[wp] [Unsuccess] typed_split_ensures_Goal_Exist_And_bis (Tactic)
-[wp] [Unsuccess] typed_split_ensures_Hyp_Forall_And (Tactic)
-[wp] [Unsuccess] typed_split_ensures_Hyp_Forall_Or_bis (Tactic)
+[wp] [Unsuccess] typed_split_ensures_Goal_Exist_Or (Tactic) (Qed)
+[wp] [Unsuccess] typed_split_ensures_Goal_Exist_And (Tactic) (Qed)
+[wp] [Unsuccess] typed_split_ensures_Goal_Exist_And_bis (Tactic) (Qed)
+[wp] [Unsuccess] typed_split_ensures_Hyp_Forall_And (Tactic) (Qed)
+[wp] [Unsuccess] typed_split_ensures_Hyp_Forall_Or_bis (Tactic) (Qed)
[wp] Proved goals: 0 / 5
Unsuccess: 5
------------------------------------------------------------
diff --git a/src/plugins/wp/tests/wp_tip/pp-trailing.c b/src/plugins/wp/tests/wp_tip/pp-trailing.c
new file mode 100644
index 0000000000000000000000000000000000000000..187b6f10ddb332e4669b823fb103990d18c83a03
--- /dev/null
+++ b/src/plugins/wp/tests/wp_tip/pp-trailing.c
@@ -0,0 +1,17 @@
+/* run.config
+ NOFRAMAC:
+ EXECNOW: LOG @PTEST_FILE@.reparse.c LOG @PTEST_FILE@.1.res.log @frama-c-cmd@ -load-plugin wp @PTEST_FILE@ -print -ocode @PTEST_FILE@.reparse.c > @PTEST_FILE@.1.res.log
+ EXECNOW: LOG @PTEST_FILE@.out.c LOG @PTEST_FILE@.2.res.log @frama-c-cmd@ -load-plugin wp %{dep:@PTEST_FILE@.reparse.c} -print -ocode @PTEST_FILE@.out.c > @PTEST_FILE@.2.res.log
+*/
+/* run.config_qualif
+ DONTRUN:
+*/
+
+/*@
+ strategy Prover: \prover("alt-ergo",0.1);
+ strategy Lazy:
+ Prover,
+ \tactic("Wp.overflow"
+ ,\pattern(\any(P(_, (..)),Q((..))))
+ );
+*/
diff --git a/src/plugins/wp/tests/wp_typed/oracle_qualif/user_init.1.res.oracle b/src/plugins/wp/tests/wp_typed/oracle_qualif/user_init.1.res.oracle
index 76c6bfc124616648c6b1276948108368101252ff..fa239e8d54760299ba6a0d99a842717b512d7f9e 100644
--- a/src/plugins/wp/tests/wp_typed/oracle_qualif/user_init.1.res.oracle
+++ b/src/plugins/wp/tests/wp_typed/oracle_qualif/user_init.1.res.oracle
@@ -29,536 +29,6 @@
[wp] Proved goals: 23 / 23
Qed: 11
Script: 12 (Tactics 24) (Qed 174/186) (Alt-Ergo 12/186) (Cached)
-[wp] Proof script for typed_init_t2_bis_v2_assigns_normal_part2:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_138) /\\ (i_1<=i_139) /\\ (0<=i_0) /\\ (i_138<=i_0) /\\ (i_139<=i_1)\n/\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 0.3801,
- "steps": 1028 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_138",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Proof script for typed_init_t2_bis_v2_assigns_exit_part2:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_138) /\\ (i_1<=i_139) /\\ (0<=i_0) /\\ (i_138<=i_0) /\\ (i_139<=i_1)\n/\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 0.3801,
- "steps": 1028 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_138",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Proof script for typed_init_t2_bis_v2_loop_assigns_part3:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_2:int.\n(i_0<=i_1) /\\ (i_2<=i_3) /\\ (0<=i_0) /\\ (i_1<=i_0) /\\ (i_3<=i_2) /\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 19 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_3",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 10": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 11": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 12": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 13": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 14": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 15": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 16": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 17": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 18": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 19": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 19": [ { "prover": "qed",
- "verdict": "valid" } ] } } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 7.1853,
- "steps": 25331 } ] } } ]
-[wp] Proof script for typed_init_t2_bis_v2_loop_assigns_part2:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_9) /\\ (i_1<=i_10) /\\ (0<=i_0) /\\ (i_9<=i_0) /\\ (i_10<=i_1)\n/\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 7.5676,
- "steps": 26376 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_9",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Proof script for typed_init_t2_v3_assigns_part2:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_149) /\\ (i_1<=i_150) /\\ (0<=i_0) /\\ (i_149<=i_0) /\\ (i_150<=i_1)\n/\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 0.0835,
- "steps": 193 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 1.8111,
- "steps": 5702 } ] } } ]
-[wp] Proof script for typed_init_t2_v3_loop_assigns_part3:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_4) /\\ (i_1<=i_6) /\\ (0<=i_0) /\\ (i_4<=i_0) /\\ (i_6<=i_1) /\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 19 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_6",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 10": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 11": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 12": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 13": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 14": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 15": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 16": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 17": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 18": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 19": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 19": [ { "prover": "qed",
- "verdict": "valid" } ] } } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_4",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Proof script for typed_init_t2_v3_loop_assigns_part2:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_13) /\\ (i_1<=i_14) /\\ (0<=i_0) /\\ (i_13<=i_0) /\\ (i_14<=i_1)\n/\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 1.3179,
- "steps": 3085 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_13",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Proof script for typed_init_t2_v2_assigns_part2:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_158) /\\ (i_1<=i_159) /\\ (0<=i_0) /\\ (i_158<=i_0) /\\ (i_159<=i_1)\n/\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 0.0835,
- "steps": 193 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 1.8111,
- "steps": 5702 } ] } } ]
-[wp] Proof script for typed_init_t2_v2_loop_assigns_2_part3:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_2:int.\n(i_0<=i_1) /\\ (0<=i_0) /\\ (i_1<=i_0) /\\ (j_1<=i_2) /\\ (i_2<=j_1) /\\ (i_0<=9)",
- "pattern": "\\E$i0$i$j$j9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 19 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "j_1",
- "pattern": "$j" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 10": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 11": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 12": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 13": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 14": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 15": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 16": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 17": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 18": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 19": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 19": [ { "prover": "qed",
- "verdict": "valid" } ] } } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_1",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Proof script for typed_init_t2_v2_loop_assigns_2_part2:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_13) /\\ (i_1<=i_14) /\\ (0<=i_0) /\\ (i_13<=i_0) /\\ (i_14<=i_1)\n/\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 1.9461,
- "steps": 3681 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_13",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Proof script for typed_init_t2_v2_loop_assigns_part3:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_8) /\\ (i_1<=i_9) /\\ (0<=i_0) /\\ (i_8<=i_0) /\\ (i_9<=i_1) /\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 1.2688,
- "steps": 2727 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_8",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Proof script for typed_init_t2_v2_loop_assigns_part2:
- [ { "header": "Split", "tactic": "Wp.split", "params": {},
- "select": { "select": "clause-goal",
- "target": "exists i_0,i_1:int.\n(i_0<=i_21) /\\ (i_1<=i_22) /\\ (0<=i_0) /\\ (i_21<=i_0) /\\ (i_22<=i_1)\n/\\ (i_0<=9)",
- "pattern": "\\E$i$i0$i$i9" },
- "children": { "Goal 1/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "valid", "time": 1.2688,
- "steps": 2727 } ],
- "Goal 2/2": [ { "prover": "Alt-Ergo:2.4.2",
- "verdict": "timeout", "time": 10. },
- { "header": "Range", "tactic": "Wp.range",
- "params": { "inf": 0, "sup": 9 },
- "select": { "select": "inside-goal",
- "occur": 0, "target": "i_21",
- "pattern": "$i" },
- "children": { "Lower 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 0": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 1": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 2": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 3": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 4": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 5": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 6": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 7": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 8": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Value 9": [ { "prover": "qed",
- "verdict": "valid" } ],
- "Upper 9": [ { "prover": "qed",
- "verdict": "valid" } ] } } ] } } ]
-[wp] Updated session
- - 12 new valid scripts
------------------------------------------------------------
Functions WP Alt-Ergo Total Success
init_t2_v2 3 - 8 100%
diff --git a/src/plugins/wp/tests/wp_typed/user_init.i b/src/plugins/wp/tests/wp_typed/user_init.i
index fec0099075211dc4d3902773c8ac1d6be01ed968..e97cb9d983b285168cb482f2bddfe89c974e480b 100644
--- a/src/plugins/wp/tests/wp_typed/user_init.i
+++ b/src/plugins/wp/tests/wp_typed/user_init.i
@@ -1,7 +1,7 @@
/* run.config_qualif
OPT: -wp-prop=-lack,-tactic
- OPT: -wp-prop=tactic -wp-auto=wp:split,wp:range -wp-prover=tip,alt-ergo -wp-script-on-stdout
+ OPT: -wp-prop=tactic -wp-auto=wp:split,wp:range -wp-prover=tip,alt-ergo -wp-script dry
OPT: -wp-prop=lack
*/
/*@ requires \valid(a+(0..n-1)) ;
diff --git a/src/plugins/wp/tests/wp_usage/valinit.i b/src/plugins/wp/tests/wp_usage/valinit.i
index 55ceb6bffe652ad1494c3a27867601e2ad97d3d4..35a4884a6e6ef220c0078c1dd7e96937d3a8c7b5 100644
--- a/src/plugins/wp/tests/wp_usage/valinit.i
+++ b/src/plugins/wp/tests/wp_usage/valinit.i
@@ -6,19 +6,24 @@
DONTRUN:
*/
-int x0, y0, z0, *p0;
+int x0, y0;
+const int z0 = 0;
+int *p0;
int x1=1, y1=1, z1=z0, *q0=(int*)0, *q1=&y0, *p1=&y1;
struct s { int c; int* cp; } ;
-int a0, a1;
-struct s s0, v0, w0;
-struct s s1=s0;
+int a0;
+const int a1 = 1;
+struct s s0={0,(int*)0};
+struct s v0;
+struct s w0={0,(int*)0};
+struct s s1={0,(int*)0};
struct s s2={1,(int*)0};
struct s s3={1,&a0};
struct s s4={a1,(int*)0};
struct s s5={1,&v0.c};
-struct s s6={w0.c,(int*)0};
+struct s s6={0,(int*)0};
void f(void) {
diff --git a/src/plugins/wp/wpReport.ml b/src/plugins/wp/wpReport.ml
index 4c95715e8b6b34a4b79d6aa8b26cc2faeb485a42..6e09d4fd1abffe8d66189ccb66c798435b6dca43 100644
--- a/src/plugins/wp/wpReport.ml
+++ b/src/plugins/wp/wpReport.ml
@@ -94,11 +94,13 @@ let result ~status ~smoke (r:VCS.result) =
match status with
| `Passed when smoke -> VALID
| _ ->
- match VCS.verdict ~smoke r with
+ match r.VCS.verdict with
| VCS.NoResult | VCS.Computing _ -> NORESULT
| VCS.Failed -> INCONCLUSIVE
- | VCS.Invalid | VCS.Unknown | VCS.Timeout | VCS.Stepout -> UNSUCCESS
- | VCS.Valid -> VALID
+ | VCS.Unknown | VCS.Timeout | VCS.Stepout ->
+ if smoke then VALID else UNSUCCESS
+ | VCS.Valid ->
+ if smoke then UNSUCCESS else VALID
let best_result a b = match a,b with
| NORESULT,c | c,NORESULT -> c
diff --git a/src/plugins/wp/wp_parameters.ml b/src/plugins/wp/wp_parameters.ml
index 7a37701948b3aed89218fd9b2d1433c3b81b6453..4be71f7e9d3e467416e61e154d48f9fa9042b5ee 100644
--- a/src/plugins/wp/wp_parameters.ml
+++ b/src/plugins/wp/wp_parameters.ml
@@ -881,12 +881,23 @@ module Timeout =
Int(struct
let option_name = "-wp-timeout"
let default = 2
- let arg_name = "n"
+ let arg_name = "t"
let help =
Printf.sprintf
"Set the timeout (in seconds) for provers (default: %d)." default
end)
+let () = Parameter_customize.set_group wp_prover
+module Memlimit =
+ Int(struct
+ let option_name = "-wp-memlimit"
+ let default = 1000
+ let arg_name = "m"
+ let help =
+ Printf.sprintf
+ "Set the memory limit (in Mb) for provers (default: %d)." default
+ end)
+
let () = Parameter_customize.set_group wp_prover
module FctTimeout =
Kernel_function_map
@@ -926,7 +937,7 @@ module InteractiveTimeout =
Int(struct
let option_name = "-wp-interactive-timeout"
let default = 30
- let arg_name = "n"
+ let arg_name = "time"
let help =
Printf.sprintf
"Set the timeout (in seconds) for checking scripts\n\
diff --git a/src/plugins/wp/wp_parameters.mli b/src/plugins/wp/wp_parameters.mli
index 53d15e5b02311f7fd22328e247729ded1359ba4b..8cca2d167762586461addd7198272205b46a36a4 100644
--- a/src/plugins/wp/wp_parameters.mli
+++ b/src/plugins/wp/wp_parameters.mli
@@ -130,6 +130,7 @@ module CacheDir: Parameter_sig.String
module CachePrint: Parameter_sig.Bool
module Drivers: Parameter_sig.String_list
module Timeout: Parameter_sig.Int
+module Memlimit: Parameter_sig.Int
module FctTimeout:
Parameter_sig.Map
with type key = Cil_types.kernel_function
diff --git a/src/plugins/wp/wpo.ml b/src/plugins/wp/wpo.ml
index f8e1321feabd05400a7f3e2702e21c512798a50e..05f5828606b60339cffbcf718789f697315f9536 100644
--- a/src/plugins/wp/wpo.ml
+++ b/src/plugins/wp/wpo.ml
@@ -100,9 +100,11 @@ struct
let file_logout ~pid ~model ~prover =
let id = WpPropId.get_propid pid in
file ~id ~model ~prover ~ext:"out" ()
+
let file_logerr ~pid ~model ~prover =
let id = WpPropId.get_propid pid in
file ~id ~model ~prover ~ext:"err" ()
+
let file_goal ~pid ~model ~prover =
let ext = match prover with
| Qed -> "qed"
@@ -496,7 +498,7 @@ module ResultType =
let name = "Wpo.result"
let reprs =
List.map VCS.result
- [ Valid ; Invalid ; Unknown ; Timeout ; Failed ]
+ [ Valid ; Unknown ; Timeout ; Failed ]
end)
(* to get a "reasonable" API doc *)
let () = Type.set_ml_name ResultType.ty (Some "Wpo.result")
diff --git a/tests/builtins/alloc_weak.c b/tests/builtins/alloc_weak.c
index fc5a664baf79d874e1dec8475a57939c8d7c44b6..020c7e0458ddb3f3eba51190bd22c29db0e296ba 100644
--- a/tests/builtins/alloc_weak.c
+++ b/tests/builtins/alloc_weak.c
@@ -68,8 +68,30 @@ void main3() {
eq = 0;
}
+void convergence_issue(void) {
+ int size = 1;
+ int *p = calloc(size, sizeof(int));
+ while (size < 64000) {
+ /* The widened value of [size] is reduced at each loop iteration by the
+ previous allocation size of [p] through a memory access alarm.
+ [size] is then used as the next allocation size of [p], so the validity
+ of the allocated base is increased by 1 at each iteration, which
+ should not prevent convergence. */
+ int tmp = *(p+size-1);
+ size++;
+ p = calloc(size, sizeof(int));
+ }
+ int *q = p + 20000;
+ int r = *q;
+ if (v) {
+ q = p + 200000;
+ r = *q; // This dereference should always emit an alarm.
+ }
+}
+
void main() {
main1();
main2();
main3();
+ convergence_issue();
}
diff --git a/tests/builtins/oracle/alloc_weak.res.oracle b/tests/builtins/oracle/alloc_weak.res.oracle
index f38325d385ce30bb9abc3f2cd2bd42a6c0c70f0b..1fcbded171d282c21b241f6785bbfb9003e51207 100644
--- a/tests/builtins/oracle/alloc_weak.res.oracle
+++ b/tests/builtins/oracle/alloc_weak.res.oracle
@@ -7,7 +7,7 @@
[eva:initial-state] Values of globals at initialization
v ∈ [--..--]
[eva] computing for function main1 <- main.
- Called from alloc_weak.c:72.
+ Called from alloc_weak.c:93.
[eva] alloc_weak.c:23: Call to builtin malloc
[eva] alloc_weak.c:23: allocating variable __malloc_main1_l23
[eva] alloc_weak.c:23: Call to builtin malloc
@@ -36,7 +36,7 @@
[eva] Recording results for main1
[eva] Done for function main1
[eva] computing for function main2 <- main.
- Called from alloc_weak.c:73.
+ Called from alloc_weak.c:94.
[eva] alloc_weak.c:37: Call to builtin malloc
[eva] alloc_weak.c:37: allocating variable __malloc_main2_l37
[eva:alarm] alloc_weak.c:37: Warning:
@@ -54,7 +54,7 @@
[eva] Recording results for main2
[eva] Done for function main2
[eva] computing for function main3 <- main.
- Called from alloc_weak.c:74.
+ Called from alloc_weak.c:95.
[eva] alloc_weak.c:51: Call to builtin malloc
[eva] alloc_weak.c:51: allocating variable __malloc_main3_l51
[eva] alloc_weak.c:50: starting to merge loop iterations
@@ -72,9 +72,55 @@
pointer comparison. assert \pointer_comparable((void *)q, (void *)r);
[eva] Recording results for main3
[eva] Done for function main3
+[eva] computing for function convergence_issue <- main.
+ Called from alloc_weak.c:96.
+[eva] alloc_weak.c:73: Call to builtin calloc
+[eva] alloc_weak.c:73: allocating variable __calloc_convergence_issue_l73
+[eva] alloc_weak.c:82: Call to builtin calloc
+[eva] alloc_weak.c:82: allocating variable __calloc_convergence_issue_l82
+[eva] alloc_weak.c:74: starting to merge loop iterations
+[eva:alarm] alloc_weak.c:80: Warning:
+ out of bounds read. assert \valid_read((p + size) - 1);
+[eva] alloc_weak.c:82: Call to builtin calloc
+[eva:malloc:weak] alloc_weak.c:82:
+ marking variable `__calloc_convergence_issue_l82' as weak
+[eva:malloc] alloc_weak.c:82:
+ resizing variable `__calloc_w_convergence_issue_l82' (0..63) to fit 0..63/95
+[eva] alloc_weak.c:82: Call to builtin calloc
+[eva:malloc] alloc_weak.c:82:
+ resizing variable `__calloc_w_convergence_issue_l82'
+ (0..63/95) to fit 0..63/127
+[eva] alloc_weak.c:82: Call to builtin calloc
+[eva:malloc] alloc_weak.c:82:
+ resizing variable `__calloc_w_convergence_issue_l82'
+ (0..63/127) to fit 0..63/159
+[eva] alloc_weak.c:82: Call to builtin calloc
+[eva:malloc] alloc_weak.c:82:
+ resizing variable `__calloc_w_convergence_issue_l82'
+ (0..63/159) to fit 0..63/191
+[eva] alloc_weak.c:82: Call to builtin calloc
+[eva:malloc] alloc_weak.c:82:
+ resizing variable `__calloc_w_convergence_issue_l82'
+ (0..63/34359738367) to fit 0..63/2047999
+[eva] alloc_weak.c:82: Call to builtin calloc
+[eva:malloc] alloc_weak.c:82:
+ resizing variable `__calloc_w_convergence_issue_l82'
+ (0..63/34359738367) to fit 0..63/2047999
+[eva:alarm] alloc_weak.c:85: Warning: out of bounds read. assert \valid_read(q);
+[eva:alarm] alloc_weak.c:88: Warning: out of bounds read. assert \valid_read(q);
+[eva] Recording results for convergence_issue
+[eva] Done for function convergence_issue
[eva] Recording results for main
[eva] done for function main
[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function convergence_issue:
+ __fc_heap_status ∈ [--..--]
+ size ∈ {64000}
+ p ∈
+ {{ &__calloc_convergence_issue_l73 ;
+ &__calloc_w_convergence_issue_l82[0] }}
+ q ∈ {{ &__calloc_w_convergence_issue_l82[20000] }}
+ r ∈ {0}
[eva:final-states] Values at end of function main2:
__fc_heap_status ∈ [--..--]
t[0] ∈ {0}
@@ -903,6 +949,10 @@
[eva:final-states] Values at end of function main:
__fc_heap_status ∈ [--..--]
__malloc_w_main1_l23[0..31] ∈ [--..--] or UNINITIALIZED
+[from] Computing for function convergence_issue
+[from] Computing for function calloc <-convergence_issue
+[from] Done for function calloc
+[from] Done for function convergence_issue
[from] Computing for function main2
[from] Computing for function malloc <-main2
[from] Done for function malloc
@@ -919,6 +969,11 @@
[from] Done for function main
[from] ====== DEPENDENCIES COMPUTED ======
These dependencies hold at termination for the executions that terminate:
+[from] Function calloc:
+ __fc_heap_status FROM __fc_heap_status; nmemb; size (and SELF)
+ \result FROM __fc_heap_status; nmemb; size
+[from] Function convergence_issue:
+ __fc_heap_status FROM __fc_heap_status (and SELF)
[from] Function malloc:
__fc_heap_status FROM __fc_heap_status; size (and SELF)
\result FROM __fc_heap_status; size
@@ -939,6 +994,11 @@
__fc_heap_status FROM __fc_heap_status (and SELF)
__malloc_w_main1_l23[0..31] FROM __fc_heap_status (and SELF)
[from] ====== END OF DEPENDENCIES ======
+[inout] Out (internal) for function convergence_issue:
+ __fc_heap_status; size; p; tmp_0; q; r
+[inout] Inputs for function convergence_issue:
+ __fc_heap_status; v; __calloc_convergence_issue_l73;
+ __calloc_w_convergence_issue_l82{[0..63998]; [200000]}
[inout] Out (internal) for function main2:
__fc_heap_status; t[0..799]; i; tmp
[inout] Inputs for function main2:
@@ -958,4 +1018,6 @@
[inout] Out (internal) for function main:
__fc_heap_status; __malloc_w_main1_l23[0..31]
[inout] Inputs for function main:
- __fc_heap_status; __malloc_w_main1_l23[0..31]
+ __fc_heap_status; v; __malloc_w_main1_l23[0..31];
+ __calloc_convergence_issue_l73;
+ __calloc_w_convergence_issue_l82{[0..63998]; [200000]}
diff --git a/tests/builtins/oracle/calloc.0.res.oracle b/tests/builtins/oracle/calloc.0.res.oracle
index 624317db33a6e4832109ecfe41dac48485c58ed8..810c06e4d77a5f803e9070f9357d5b5964b972c3 100644
--- a/tests/builtins/oracle/calloc.0.res.oracle
+++ b/tests/builtins/oracle/calloc.0.res.oracle
@@ -40,11 +40,11 @@
[eva:final-states] Values at end of function main:
__fc_heap_status ∈ [--..--]
p1 ∈ [--..--]
- p2 ∈ [--..--]
- p3 ∈ [--..--]
- p4 ∈ [--..--]
- p5 ∈ [--..--]
- p9001 ∈ {0}
+ p2 ∈ [--..--] or UNINITIALIZED
+ p3 ∈ [--..--] or UNINITIALIZED
+ p4 ∈ [--..--] or UNINITIALIZED
+ p5 ∈ [--..--] or UNINITIALIZED
+ p9001 ∈ {0} or UNINITIALIZED
__retres ∈ {0; 1}
[from] Computing for function main
[from] Computing for function calloc <-main
diff --git a/tests/builtins/oracle/free.res.oracle b/tests/builtins/oracle/free.res.oracle
index 4f5cb6ae56f07cb9ca6b0984d705f3d7a0d5965f..080c1e9f72247363a280721aa3077c1789cd44c2 100644
--- a/tests/builtins/oracle/free.res.oracle
+++ b/tests/builtins/oracle/free.res.oracle
@@ -30,6 +30,9 @@
q ∈ {{ &__malloc_main1_l10[0] }}
r ∈ {{ &__malloc_main1_l8[0] ; &__malloc_main1_l10[0] }}
tmp_1 ∈ {{ &__malloc_main1_l8[0] ; &__malloc_main1_l10[0] }}
+ u ∈ UNINITIALIZED
+ t ∈ UNINITIALIZED
+ s ∈ UNINITIALIZED
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
__malloc_main1_l8[0] ∈ UNINITIALIZED
diff --git a/tests/builtins/oracle/realloc.res.oracle b/tests/builtins/oracle/realloc.res.oracle
index df107558a522d428e7c910802a4affbe07f80eb3..c2e751d30bbc889be7a576a4a1a0ea288c4c91a4 100644
--- a/tests/builtins/oracle/realloc.res.oracle
+++ b/tests/builtins/oracle/realloc.res.oracle
@@ -26,6 +26,7 @@
Frama_C_entropy_source ∈ [--..--]
p ∈ {{ &__malloc_main1_l12 }}
pp ∈ {{ &__malloc_main1_l12 }}
+ q ∈ UNINITIALIZED
v ∈ [--..--]
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
@@ -144,6 +145,7 @@
r ∈ {{ &__malloc_main3_l35[0] }}
p ∈ {{ &__malloc_main3_l32[0] ; &__malloc_main3_l35[0] }}
x ∈ {0; 1}
+ s ∈ UNINITIALIZED
v ∈ [--..--]
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
@@ -241,6 +243,8 @@
sizeq ∈ [0..10]
p ∈ {{ &__malloc_main4_l55[0] }}
q ∈ {{ &__malloc_main4_l56[0] }}
+ rp ∈ UNINITIALIZED
+ rq ∈ UNINITIALIZED
v ∈ [--..--]
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
@@ -356,6 +360,7 @@
p ∈ {{ &__malloc_main5_l76 }}
c ∈ {0; 1}
q ∈ {{ NULL ; &__malloc_main5_l76 }}
+ r ∈ UNINITIALIZED
v ∈ [--..--]
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
diff --git a/tests/builtins/oracle/realloc_multiple.0.res.oracle b/tests/builtins/oracle/realloc_multiple.0.res.oracle
index 5908db2b9e507a91de87ff057e31832be7b548e8..a45635beb983c3b71bc12573e69368c3668d105a 100644
--- a/tests/builtins/oracle/realloc_multiple.0.res.oracle
+++ b/tests/builtins/oracle/realloc_multiple.0.res.oracle
@@ -36,6 +36,7 @@
r ∈ {{ &__malloc_main1_l12[0] }}
p ∈ {{ &__malloc_main1_l9[0] ; &__malloc_main1_l12[0] }}
x ∈ {0; 1}
+ s ∈ UNINITIALIZED
v ∈ {1}
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
@@ -120,6 +121,7 @@
r ∈ {{ &__malloc_main2_l33[0] }}
p ∈ {{ NULL ; &__malloc_main2_l30[0] ; &__malloc_main2_l33[0] }}
x ∈ {0; 1; 2}
+ s ∈ UNINITIALIZED
v ∈ {2}
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
diff --git a/tests/builtins/oracle/realloc_multiple.1.res.oracle b/tests/builtins/oracle/realloc_multiple.1.res.oracle
index 052f0f273fa2a1f63c42e4ef5be7fa27b6c5d044..c9cedc5f77d6a92f51ed05c2e243b2e47c570e64 100644
--- a/tests/builtins/oracle/realloc_multiple.1.res.oracle
+++ b/tests/builtins/oracle/realloc_multiple.1.res.oracle
@@ -44,6 +44,7 @@
r ∈ {{ &__malloc_main1_l12[0] }}
p ∈ {{ &__malloc_main1_l9[0] ; &__malloc_main1_l12[0] }}
x ∈ {0; 1}
+ s ∈ UNINITIALIZED
v ∈ {1}
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
@@ -165,6 +166,7 @@
r ∈ {{ &__malloc_main2_l33[0] }}
p ∈ {{ NULL ; &__malloc_main2_l30[0] ; &__malloc_main2_l33[0] }}
x ∈ {0; 1; 2}
+ s ∈ UNINITIALIZED
v ∈ {2}
S_0___fc_env[0..1] ∈ [--..--]
S_1___fc_env[0..1] ∈ [--..--]
diff --git a/tests/builtins/oracle_equality/alloc_weak.res.oracle b/tests/builtins/oracle_equality/alloc_weak.res.oracle
index b4c9111452e03f530c8ecf2275b5072c8055c757..1e76e3d24088d209f4e6d5d676d096428794c874 100644
--- a/tests/builtins/oracle_equality/alloc_weak.res.oracle
+++ b/tests/builtins/oracle_equality/alloc_weak.res.oracle
@@ -1,7 +1,13 @@
34,35d33
< [eva:alarm] alloc_weak.c:30: Warning:
< accessing uninitialized left-value. assert \initialized(p);
-901c899
+119,121c117
+< p ∈
+< {{ &__calloc_convergence_issue_l73 ;
+< &__calloc_w_convergence_issue_l82[0] }}
+---
+> p ∈ {{ &__calloc_w_convergence_issue_l82[0] }}
+947c943
< r ∈ [--..--]
---
> r ∈ {42}
diff --git a/tests/builtins/oracle_gauges/realloc.res.oracle b/tests/builtins/oracle_gauges/realloc.res.oracle
index 7db5bb2855581132216cb4aff783b868c8fd005b..317aba47d1df8261a94c9a7e59085491fc885220 100644
--- a/tests/builtins/oracle_gauges/realloc.res.oracle
+++ b/tests/builtins/oracle_gauges/realloc.res.oracle
@@ -1,4 +1,4 @@
-627a628,964
+632a633,969
> [eva] realloc.c:152: Call to builtin realloc
> [eva:malloc] bases_to_realloc: {__realloc_w_main10_l152}
> [eva:malloc] realloc.c:152: weak free on bases: {__realloc_w_main10_l152}
@@ -336,7 +336,7 @@
> __realloc_w_main10_l152[0] ∈ {4}
> [1] ∈ UNINITIALIZED
> ==END OF DUMP==
-694a1032,1096
+699a1037,1101
> [eva] realloc.c:167: Call to builtin reallocarray
> [eva] realloc.c:167: Call to builtin reallocarray
> [eva] computing for function Frama_C_interval <- main11 <- main.
@@ -402,7 +402,7 @@
> [eva:malloc] bases_to_realloc: {}
> [eva:malloc] realloc.c:171: strong free on bases: {}
> [eva] realloc.c:172: Frama_C_show_each_p: {{ NULL ; &__realloc_w_main11_l171 }}
-762,763c1164,1166
+767,768c1169,1171
< p ∈ {{ NULL ; &__malloc_main11_l160 ; (int *)&__realloc_main11_l171 }}
< q ∈ {0} or UNINITIALIZED or ESCAPINGADDR
---
diff --git a/tests/builtins/oracle_symblocs/alloc_weak.res.oracle b/tests/builtins/oracle_symblocs/alloc_weak.res.oracle
index b4c9111452e03f530c8ecf2275b5072c8055c757..85115be80a4aa92d0e05dd0e5c8da87d19bace63 100644
--- a/tests/builtins/oracle_symblocs/alloc_weak.res.oracle
+++ b/tests/builtins/oracle_symblocs/alloc_weak.res.oracle
@@ -1,7 +1,7 @@
34,35d33
< [eva:alarm] alloc_weak.c:30: Warning:
< accessing uninitialized left-value. assert \initialized(p);
-901c899
+947c945
< r ∈ [--..--]
---
> r ∈ {42}
diff --git a/tests/cil/oracle/bts892.res.oracle b/tests/cil/oracle/bts892.res.oracle
index 9ec093e1f4930ae0df5e869fc9dc0a8572e98326..f9a9a310578a588b9be8231ceed0d87a1146977b 100644
--- a/tests/cil/oracle/bts892.res.oracle
+++ b/tests/cil/oracle/bts892.res.oracle
@@ -1,5 +1,7 @@
[kernel] Parsing bts892.i (no preprocessing)
[kernel] bts892.i:17: User Error:
Forbidden access to local variable i in static initializer
+[kernel] bts892.i:17: User Error:
+ Initializer element is not a compile-time constant
[kernel] User Error: stopping on file "bts892.i" that has errors.
[kernel] Frama-C aborted: invalid user input.
diff --git a/tests/cil/oracle/cpu_a.res.oracle b/tests/cil/oracle/cpu_a.res.oracle
index 6623ed53971969354ea97602ac3e635ed9f2e213..b1e7b6ca0a1c634dbcdf616a65afa015feeb6f5d 100644
--- a/tests/cil/oracle/cpu_a.res.oracle
+++ b/tests/cil/oracle/cpu_a.res.oracle
@@ -1,5 +1,9 @@
[kernel] Parsing cpu_a.c (with preprocessing)
[kernel] Parsing cpu_b.c (with preprocessing)
+[kernel:typing:int-conversion] cpu_b.c:7: Warning:
+ Integer compatibily is machine-dependent : unsigned short and unsigned int
+[kernel:typing:merge-conversion] Warning:
+ Conflicting definitions are between files cpu_a.c and cpu_b.c
/* Generated by Frama-C */
typedef unsigned short DWORD;
DWORD f(void)
diff --git a/tests/cil/oracle/cpu_b.res.oracle b/tests/cil/oracle/cpu_b.res.oracle
index 1567947463f1244480390e2cb5947ab91adeda15..fba20f7512642f74fc2f578704f8261187bdef2a 100644
--- a/tests/cil/oracle/cpu_b.res.oracle
+++ b/tests/cil/oracle/cpu_b.res.oracle
@@ -1,5 +1,9 @@
[kernel] Parsing cpu_b.c (with preprocessing)
[kernel] Parsing cpu_a.c (with preprocessing)
+[kernel:typing:int-conversion] cpu_a.c:6: Warning:
+ Integer compatibily is machine-dependent : unsigned int and unsigned short
+[kernel:typing:merge-conversion] Warning:
+ Conflicting definitions are between files cpu_b.c and cpu_a.c
/* Generated by Frama-C */
typedef unsigned int DWORD;
DWORD f(void);
diff --git a/tests/compliance/sanity-checks.py b/tests/compliance/sanity-checks.py
index 6bc3186325fa5696d73156b34d0c760bb095262d..b081be92ef91417724b3fe06d19a5830c8c560b6 100755
--- a/tests/compliance/sanity-checks.py
+++ b/tests/compliance/sanity-checks.py
@@ -22,7 +22,7 @@ with open(posix_ids_path) as data:
posix_headers = set(js["headers"].keys())
extension_names = set(js["extension_names"].keys())
unique_ids = set()
- for (i, v) in posix_dict.items():
+ for i, v in posix_dict.items():
if i in unique_ids:
sys.exit("duplicate id {i}")
unique_ids.add(i)
@@ -50,7 +50,7 @@ with open(c11_funs_path) as data:
js = json.load(data)
c11_funs = js["data"]
-for (i, v) in c11_funs.items():
+for i, v in c11_funs.items():
header = v["header"]
if header not in c11_headers:
sys.exit(f"error: unknown header {header} for id {i}")
diff --git a/tests/constant_propagation/bts-1787.i b/tests/constant_propagation/bts-1787.i
index 6b534ca4bbdf3057ce5a0049bf682f69faff46eb..5fa026433e9ac44636ade94d789481fcdb9c7f2b 100644
--- a/tests/constant_propagation/bts-1787.i
+++ b/tests/constant_propagation/bts-1787.i
@@ -7,7 +7,7 @@ typedef struct {
int s;
} S1_t;
-typedef struct {
+typedef struct {
const S1_t* p1;
S1_t* p2;
S1_t* p3;
@@ -27,7 +27,7 @@ static S2_t const G2 = {
void g(S2_t const* q) {
S1_t *s1 = (S1_t *)(q->p1); /* incorrect to inline because of const qualifier */
(*(q->p3)).s = (*(q->p1)).s + (*(q->p2)).s ;
- // (*(q->p1)).s += (*(q->p1)).s; /* statement to be rejected by the C typechecker */
+ // (*(q->p1)).s += (*(q->p1)).s; /* statement to be rejected by the C typechecker */
s1->s = 3;
}
@@ -39,5 +39,5 @@ int main(int c) {
g(&G2);
return G1.c3.s;
}
-int a = 0;
+const int a = 0;
int b = a;
diff --git a/tests/constant_propagation/oracle/bts-1787.0.res.oracle b/tests/constant_propagation/oracle/bts-1787.0.res.oracle
index e9f8f0700a6dca77f6113a9584d3a2ceddfbfcb2..c48284fa8e0e5f97ba9f882064a548c764497fc4 100644
--- a/tests/constant_propagation/oracle/bts-1787.0.res.oracle
+++ b/tests/constant_propagation/oracle/bts-1787.0.res.oracle
@@ -53,7 +53,7 @@ int main(int c)
return __retres;
}
-int a = 0;
+int const a = 0;
int b = a;
[scf] constant propagation done
diff --git a/tests/constant_propagation/oracle/bts-1787.1.res.oracle b/tests/constant_propagation/oracle/bts-1787.1.res.oracle
index e9f8f0700a6dca77f6113a9584d3a2ceddfbfcb2..c48284fa8e0e5f97ba9f882064a548c764497fc4 100644
--- a/tests/constant_propagation/oracle/bts-1787.1.res.oracle
+++ b/tests/constant_propagation/oracle/bts-1787.1.res.oracle
@@ -53,7 +53,7 @@ int main(int c)
return __retres;
}
-int a = 0;
+int const a = 0;
int b = a;
[scf] constant propagation done
diff --git a/tests/fc_script/oracle/custom_machdep.yaml b/tests/fc_script/oracle/custom_machdep.yaml
new file mode 100644
index 0000000000000000000000000000000000000000..24f472d19e21723c8f7bf328c8ff0a0bea41a373
--- /dev/null
+++ b/tests/fc_script/oracle/custom_machdep.yaml
@@ -0,0 +1,183 @@
+alignof_aligned: 16
+alignof_double: 8
+alignof_float: 4
+alignof_fun: 4
+alignof_int: 4
+alignof_long: 8
+alignof_longdouble: 16
+alignof_longlong: 8
+alignof_ptr: 8
+alignof_short: 2
+alignof_str: 1
+bufsiz: '8192'
+char_is_unsigned: false
+compiler: clang
+cpp_arch_flags:
+ - --target=x86_64
+eof: (-1)
+errno:
+ e2big: '7'
+ eacces: '13'
+ eaddrinuse: '98'
+ eaddrnotavail: '99'
+ eafnosupport: '97'
+ eagain: '11'
+ ealready: '114'
+ ebade: '52'
+ ebadf: '9'
+ ebadfd: '77'
+ ebadmsg: '74'
+ ebadr: '53'
+ ebadrqc: '56'
+ ebadslt: '57'
+ ebusy: '16'
+ ecanceled: '125'
+ echild: '10'
+ echrng: '44'
+ ecomm: '70'
+ econnaborted: '103'
+ econnrefused: '111'
+ econnreset: '104'
+ edeadlk: '35'
+ edeadlock: '35'
+ edestaddrreq: '89'
+ edom: '33'
+ edquot: '122'
+ eexist: '17'
+ efault: '14'
+ efbig: '27'
+ ehostdown: '112'
+ ehostunreach: '113'
+ eidrm: '43'
+ eilseq: '84'
+ einprogress: '115'
+ eintr: '4'
+ einval: '22'
+ eio: '5'
+ eisconn: '106'
+ eisdir: '21'
+ eisnam: '120'
+ ekeyexpired: '127'
+ ekeyrejected: '129'
+ ekeyrevoked: '128'
+ el2hlt: '51'
+ el2nsync: '45'
+ el3hlt: '46'
+ el3rst: '47'
+ elibacc: '79'
+ elibbad: '80'
+ elibexec: '83'
+ elibmax: '82'
+ elibscn: '81'
+ eloop: '40'
+ emediumtype: '124'
+ emfile: '24'
+ emlink: '31'
+ emsgsize: '90'
+ emultihop: '72'
+ enametoolong: '36'
+ enetdown: '100'
+ enetreset: '102'
+ enetunreach: '101'
+ enfile: '23'
+ enobufs: '105'
+ enodata: '61'
+ enodev: '19'
+ enoent: '2'
+ enoexec: '8'
+ enokey: '126'
+ enolck: '37'
+ enolink: '67'
+ enomedium: '123'
+ enomem: '12'
+ enomsg: '42'
+ enonet: '64'
+ enopkg: '65'
+ enoprotoopt: '92'
+ enospc: '28'
+ enosr: '63'
+ enostr: '60'
+ enosys: '38'
+ enotblk: '15'
+ enotconn: '107'
+ enotdir: '20'
+ enotempty: '39'
+ enotrecoverable: '131'
+ enotsock: '88'
+ enotsup: '95'
+ enotty: '25'
+ enotuniq: '76'
+ enxio: '6'
+ eopnotsupp: '95'
+ eoverflow: '75'
+ eownerdead: '130'
+ eperm: '1'
+ epfnosupport: '96'
+ epipe: '32'
+ eproto: '71'
+ eprotonosupport: '93'
+ eprototype: '91'
+ erange: '34'
+ eremchg: '78'
+ eremote: '66'
+ eremoteio: '121'
+ erestart: '85'
+ erofs: '30'
+ eshutdown: '108'
+ esocktnosupport: '94'
+ espipe: '29'
+ esrch: '3'
+ estale: '116'
+ estrpipe: '86'
+ etime: '62'
+ etimedout: '110'
+ etxtbsy: '26'
+ euclean: '117'
+ eunatch: '49'
+ eusers: '87'
+ ewouldblock: '11'
+ exdev: '18'
+ exfull: '54'
+filename_max: '4096'
+fopen_max: '16'
+has__builtin_va_list: true
+host_name_max: '64'
+int_fast16_t: long
+int_fast32_t: long
+int_fast64_t: long
+int_fast8_t: signed char
+intptr_t: long
+l_tmpnam: '20'
+little_endian: true
+machdep_name: anonymous_machdep
+mb_cur_max: ((size_t)16)
+nsig: (64 + 1)
+path_max: '4096'
+posix_version: 200809L
+ptrdiff_t: long
+rand_max: '2147483647'
+sig_atomic_t: int
+size_t: unsigned long
+sizeof_double: 8
+sizeof_float: 4
+sizeof_fun: 1
+sizeof_int: 4
+sizeof_long: 8
+sizeof_longdouble: 16
+sizeof_longlong: 8
+sizeof_ptr: 8
+sizeof_short: 2
+sizeof_void: 1
+ssize_t: long
+time_t: long
+tmp_max: '238328'
+tty_name_max: '32'
+uint_fast16_t: unsigned long
+uint_fast32_t: unsigned long
+uint_fast64_t: unsigned long
+uint_fast8_t: unsigned char
+uintptr_t: unsigned long
+wchar_t: int
+weof: (0xffffffffu)
+wint_t: int
+wordsize: '64'
diff --git a/tests/fc_script/oracle/find_fun1.res b/tests/fc_script/oracle/find_fun1.res
index 58bf804e3c123e33f21c6761b63dcefa26e2e129..71eea9bdef1d36da92d821b392155e03e811c21e 100644
--- a/tests/fc_script/oracle/find_fun1.res
+++ b/tests/fc_script/oracle/find_fun1.res
@@ -1,4 +1,4 @@
-Looking for 'main2' inside 15 file(s)...
+Looking for 'main2' inside 16 file(s)...
Possible declarations for function 'main2' in the following file(s):
for-find-fun.c
Possible definitions for function 'main2' in the following file(s):
diff --git a/tests/fc_script/oracle/find_fun2.res b/tests/fc_script/oracle/find_fun2.res
index d868795ee4e11b8858e75185cfd91d68ea8a24e7..5c9b9b69b9d58907335997f8db1b440930ca63ef 100644
--- a/tests/fc_script/oracle/find_fun2.res
+++ b/tests/fc_script/oracle/find_fun2.res
@@ -1,4 +1,4 @@
-Looking for 'main3' inside 15 file(s)...
+Looking for 'main3' inside 16 file(s)...
Possible declarations for function 'main3' in the following file(s):
for-find-fun2.c
Possible definitions for function 'main3' in the following file(s):
diff --git a/tests/fc_script/oracle/find_fun3.res b/tests/fc_script/oracle/find_fun3.res
index 00f4bbc10eab9c20620426e670d9d0cf6b715762..67c26fc2681fd115eaca995ff472d4419c48248a 100644
--- a/tests/fc_script/oracle/find_fun3.res
+++ b/tests/fc_script/oracle/find_fun3.res
@@ -1,2 +1,2 @@
-Looking for 'false_positive' inside 15 file(s)...
+Looking for 'false_positive' inside 16 file(s)...
No declaration/definition found for function 'false_positive'
diff --git a/tests/value/oracle_octagon/struct2.res.oracle b/tests/fc_script/oracle/make_machdep.err.log
similarity index 100%
rename from tests/value/oracle_octagon/struct2.res.oracle
rename to tests/fc_script/oracle/make_machdep.err.log
diff --git a/tests/fc_script/test_machdep.i b/tests/fc_script/test_machdep.i
new file mode 100644
index 0000000000000000000000000000000000000000..923485dde8e59c0631db3e506d95a6c23cf4699b
--- /dev/null
+++ b/tests/fc_script/test_machdep.i
@@ -0,0 +1,12 @@
+/* run.config
+ NOFRAMAC: Just test the generation of a custom machdep with the installed script.
+ COMMENT: No C code gets analyzed there. File is empty on purpose
+ COMMENT: be sure to keep the first EXECNOW: it ensures
+ COMMENT: that dune will copy the file regardless of the environment
+ COMMENT: so that other tests whose oracles depend on the number of file in
+ COMMENT: the directory will be stable.
+ EXECNOW: LOG empty.res touch empty.res
+ ENABLED_IF: (and %{bin-available:clang} %{bin-available:yq})
+ FILTER: sed -e '/^version:/d'
+ EXECNOW: LOG custom_machdep.yaml LOG make_machdep.err.log PTESTS_TESTING=1 %{bin:frama-c-script} make-machdep --compiler clang --cpp-arch-flags='--target=x86_64' | yq -Y 'del(.version)|del(.custom_defs)' > custom_machdep.yaml 2> make_machdep.err.log
+*/
diff --git a/tests/float/oracle/alarms.0.res.oracle b/tests/float/oracle/alarms.0.res.oracle
index 8e964fd6c677d12e8068ca89de3c960044b80c11..2772f9227081cba003c033a6a70bb1f32b921e9c 100644
--- a/tests/float/oracle/alarms.0.res.oracle
+++ b/tests/float/oracle/alarms.0.res.oracle
@@ -29,7 +29,12 @@
ull ∈ {0}
rand ∈ [--..--]
l ∈ [--..--]
+ vf ∈ UNINITIALIZED
tmp ∈ UNINITIALIZED
+ vd ∈ UNINITIALIZED
+ i ∈ UNINITIALIZED
+ j ∈ UNINITIALIZED
+ mvd ∈ UNINITIALIZED
l ∈ [--..--]
==END OF DUMP==
[kernel:annot:missing-spec] alarms.i:21: Warning:
diff --git a/tests/float/oracle/alarms.1.res.oracle b/tests/float/oracle/alarms.1.res.oracle
index 95735134c42367149c53c4ba8502e4cc652e78e4..ebe72529a2011e39a98ad6da43b601abc1d697eb 100644
--- a/tests/float/oracle/alarms.1.res.oracle
+++ b/tests/float/oracle/alarms.1.res.oracle
@@ -26,7 +26,12 @@
ull ∈ {0}
rand ∈ [--..--]
l ∈ [--..--]
+ vf ∈ UNINITIALIZED
tmp ∈ UNINITIALIZED
+ vd ∈ UNINITIALIZED
+ i ∈ UNINITIALIZED
+ j ∈ UNINITIALIZED
+ mvd ∈ UNINITIALIZED
l ∈ [--..--]
==END OF DUMP==
[kernel:annot:missing-spec] alarms.i:21: Warning:
diff --git a/tests/float/oracle/alarms.2.res.oracle b/tests/float/oracle/alarms.2.res.oracle
index 6c47a9b44c57b387e173f5f380b9e47c2e794498..99a0bbe07d84ba84ee7a02a5673cff1fa6a6fec2 100644
--- a/tests/float/oracle/alarms.2.res.oracle
+++ b/tests/float/oracle/alarms.2.res.oracle
@@ -23,7 +23,12 @@
ull ∈ {0}
rand ∈ [--..--]
l ∈ [--..--]
+ vf ∈ UNINITIALIZED
tmp ∈ UNINITIALIZED
+ vd ∈ UNINITIALIZED
+ i ∈ UNINITIALIZED
+ j ∈ UNINITIALIZED
+ mvd ∈ UNINITIALIZED
l ∈ [--..--]
==END OF DUMP==
[kernel:annot:missing-spec] alarms.i:21: Warning:
diff --git a/tests/float/oracle/const3.0.res.oracle b/tests/float/oracle/const3.0.res.oracle
index 6f4eaebdd95a561893ca62ee3f8b956e4ad9a93f..7e8f509c45aca4a14fdec29d5924115bdea13517 100644
--- a/tests/float/oracle/const3.0.res.oracle
+++ b/tests/float/oracle/const3.0.res.oracle
@@ -14,6 +14,7 @@
# cvalue:
f1 ∈ {9.99994610111e-41}
d0 ∈ {1e-40}
+ d1 ∈ UNINITIALIZED
__retres ∈ UNINITIALIZED
==END OF DUMP==
[eva] Recording results for main
diff --git a/tests/float/oracle/const3.1.res.oracle b/tests/float/oracle/const3.1.res.oracle
index ade47d3bb883bc01da0dfebb79574f1cae5bd967..989c638425ec23473e424086ff5f18760e214deb 100644
--- a/tests/float/oracle/const3.1.res.oracle
+++ b/tests/float/oracle/const3.1.res.oracle
@@ -16,6 +16,7 @@
# cvalue:
f1 ∈ [0x1.16c2000000000p-133 .. 0x1.16c3000000000p-133]
d0 ∈ [0x1.16c262777579cp-133 .. 0x1.16c262777579dp-133]
+ d1 ∈ UNINITIALIZED
__retres ∈ UNINITIALIZED
==END OF DUMP==
[eva] Recording results for main
diff --git a/tests/float/oracle/const4.1.res.oracle b/tests/float/oracle/const4.1.res.oracle
index 8854b8b2448d6cd9fd7ec98ede98a3d0cbabde8b..90bb991ae7f4df63f44348f6ffc404915867806f 100644
--- a/tests/float/oracle/const4.1.res.oracle
+++ b/tests/float/oracle/const4.1.res.oracle
@@ -18,6 +18,7 @@
# cvalue:
f1 ∈ [3.39999995214e+38 .. 3.40000015497e+38]
f2 ∈ {3.40282346639e+38}
+ d2 ∈ UNINITIALIZED
__retres ∈ UNINITIALIZED
==END OF DUMP==
[eva] Recording results for main
diff --git a/tests/float/oracle_equality/alarms.0.res.oracle b/tests/float/oracle_equality/alarms.0.res.oracle
index c0293cdd68b29be5e867b6afaa1bccb8c09fcc49..e275d378fa4aed2db5affd0abed177d49e5a6ac8 100644
--- a/tests/float/oracle_equality/alarms.0.res.oracle
+++ b/tests/float/oracle_equality/alarms.0.res.oracle
@@ -1,4 +1,4 @@
-137,139c137,138
+142,144c142,143
< u1{.l[bits 0 to 31]; .f; .d[bits 0 to 31]} ∈
< [-3.40282346639e+38 .. 3.40282346639e+38]
< {.l[bits 32 to 63]; .f[bits 32 to 63]; .d[bits 32 to 63]} ∈ [--..--]
diff --git a/tests/float/oracle_equality/alarms.1.res.oracle b/tests/float/oracle_equality/alarms.1.res.oracle
index 1ab35c18d93d2826bb86fc25efd9510bf94f38f1..2e54149d2b56ed8663050f77934d34fdee4b76ab 100644
--- a/tests/float/oracle_equality/alarms.1.res.oracle
+++ b/tests/float/oracle_equality/alarms.1.res.oracle
@@ -1,4 +1,4 @@
-120,121c120,121
+125,126c125,126
< u1{.l[bits 0 to 31]; .f; .d[bits 0 to 31]} ∈ [-inf .. inf]
< {.l[bits 32 to 63]; .f[bits 32 to 63]; .d[bits 32 to 63]} ∈ [--..--]
---
diff --git a/tests/float/oracle_equality/const3.1.res.oracle b/tests/float/oracle_equality/const3.1.res.oracle
index 7de759db47189f2c50ea83d7845623fa5994f43e..f13fa4f815ce32defdc347ec00f3a6b4e6d6f9a8 100644
--- a/tests/float/oracle_equality/const3.1.res.oracle
+++ b/tests/float/oracle_equality/const3.1.res.oracle
@@ -1,4 +1,4 @@
-25c25
+26c26
< d1 ∈ [0x1.16c2000000000p-133 .. 0x1.16c3000000000p-133]
---
> d1 ∈ {0x1.16c2000000000p-133}
diff --git a/tests/libc/check_compliance.ml b/tests/libc/check_compliance.ml
index 63485ebba93189813c0dfd40c83a2aea4d2c1e22..7a13be06edfa6eefa75872796092c46e78abe1f7 100644
--- a/tests/libc/check_compliance.ml
+++ b/tests/libc/check_compliance.ml
@@ -19,7 +19,7 @@ class stdlib_visitor = object
Cil.SkipChildren
| attrparams ->
let when_header = function
- | AStr s when Extlib.string_suffix ".h" s -> Some s
+ | AStr s when String.ends_with ~suffix:".h" s -> Some s
| _ -> None
in
let headers = List.filter_map when_header attrparams
@@ -81,9 +81,9 @@ struct
end
let ident_to_be_ignored id headers =
- Extlib.string_prefix "__" id ||
- Extlib.string_prefix "Frama_C" id ||
- List.filter (fun h -> not (Extlib.string_prefix "__fc" h)) headers = []
+ String.starts_with ~prefix:"__" id ||
+ String.starts_with ~prefix:"Frama_C" id ||
+ List.filter (fun h -> not (String.starts_with ~prefix:"__fc" h)) headers = []
let check_ident c11 posix glibc nonstandard c11_headers id headers =
if ident_to_be_ignored id headers then (* nothing to check *) ()
diff --git a/tests/libc/oracle/poll.res.oracle b/tests/libc/oracle/poll.res.oracle
index 470eb611711b0cc9b9fa4e42581fe3683b321bb1..58d6b858e0834253897e1d3f8413b54bbc2b681b 100644
--- a/tests/libc/oracle/poll.res.oracle
+++ b/tests/libc/oracle/poll.res.oracle
@@ -25,7 +25,7 @@
.events ∈ {3}
.revents ∈ [--..--]
r ∈ {-1; 0; 1}
- can_read ∈ {0; 1}
- can_read_out_of_band ∈ {0; 2}
- invalid_fd ∈ {0; 32}
+ can_read ∈ {0; 1} or UNINITIALIZED
+ can_read_out_of_band ∈ {0; 2} or UNINITIALIZED
+ invalid_fd ∈ {0; 32} or UNINITIALIZED
__retres ∈ [0..127]
diff --git a/tests/libc/oracle/signal_h.res.oracle b/tests/libc/oracle/signal_h.res.oracle
index efade1922a061ad31e4bdcaa1ff5ad0f22ace360..e9c90019070b8c9ab29975147149c33539fd4379 100644
--- a/tests/libc/oracle/signal_h.res.oracle
+++ b/tests/libc/oracle/signal_h.res.oracle
@@ -289,7 +289,7 @@
s ∈ [--..--]
uninit ∈ UNINITIALIZED
old ∈ [--..--] or UNINITIALIZED
- kill_res ∈ {-1; 0}
+ kill_res ∈ {-1; 0} or UNINITIALIZED
sa1 ∈
{{ garbled mix of &{__fc_sigaction}
(origin: Library function {signal_h.c:45}) }} or UNINITIALIZED
diff --git a/tests/libc/oracle/socket.0.res.oracle b/tests/libc/oracle/socket.0.res.oracle
index 99635468b5f16ccf760bd70d5fed0ea3c85f3cd9..d721e0304f9f78829d017736c8c5013885e14fcb 100644
--- a/tests/libc/oracle/socket.0.res.oracle
+++ b/tests/libc/oracle/socket.0.res.oracle
@@ -257,10 +257,10 @@
__fc_socket_counter ∈ [--..--]
fd ∈ [-1..1023]
addr ∈ [--..--] or UNINITIALIZED
- addrlen ∈ {8}
- client_fd ∈ [-1..1023]
+ addrlen ∈ {8} or UNINITIALIZED
+ client_fd ∈ [-1..1023] or UNINITIALIZED
buf[0..63] ∈ [--..--] or UNINITIALIZED
- r ∈ [-1..64]
+ r ∈ [-1..64] or UNINITIALIZED
__retres ∈ {0; 1; 5; 20; 100; 200; 300; 400}
[eva:final-states] Values at end of function main:
__fc_fds[0..1023] ∈ [--..--]
diff --git a/tests/libc/oracle/socket.1.res.oracle b/tests/libc/oracle/socket.1.res.oracle
index 8f908c607936382b0b3797665fb94079fd895b78..543a28a7fba79583e5ea35c553c0c1b21314d5eb 100644
--- a/tests/libc/oracle/socket.1.res.oracle
+++ b/tests/libc/oracle/socket.1.res.oracle
@@ -259,10 +259,10 @@
__fc_socket_counter ∈ [--..--]
fd ∈ [-1..1023]
addr ∈ [--..--] or UNINITIALIZED
- addrlen ∈ {8}
- client_fd ∈ [-1..1023]
+ addrlen ∈ {8} or UNINITIALIZED
+ client_fd ∈ [-1..1023] or UNINITIALIZED
buf[0..63] ∈ [--..--] or UNINITIALIZED
- r ∈ [-1..64]
+ r ∈ [-1..64] or UNINITIALIZED
__retres ∈ {0; 1; 5; 20; 100; 200; 300; 400}
[eva:final-states] Values at end of function main:
__fc_fds[0..1023] ∈ [--..--]
diff --git a/tests/libc/oracle/stdio_c.res.oracle b/tests/libc/oracle/stdio_c.res.oracle
index 102692560dab65fdaa3f49f0015d5f17ea666f2b..3be99d222c709984ed1d9613c00e86b7c5aa5961 100644
--- a/tests/libc/oracle/stdio_c.res.oracle
+++ b/tests/libc/oracle/stdio_c.res.oracle
@@ -108,14 +108,7 @@
Called from FRAMAC_SHARE/libc/stdio.c:82.
[eva] Done for function feof
[eva] FRAMAC_SHARE/libc/stdio.c:84: Reusing old results for call to fgetc
-[eva] FRAMAC_SHARE/libc/stdio.c:84: Reusing old results for call to fgetc
[eva] FRAMAC_SHARE/libc/stdio.c:104: Call to builtin realloc
-[eva] computing for function ferror <- getline <- main.
- Called from FRAMAC_SHARE/libc/stdio.c:82.
-[eva] Done for function ferror
-[eva] computing for function feof <- getline <- main.
- Called from FRAMAC_SHARE/libc/stdio.c:82.
-[eva] Done for function feof
[eva:alarm] FRAMAC_SHARE/libc/stdio.c:93: Warning:
out of bounds write. assert \valid(*lineptr + cur);
[eva] Recording results for getline
@@ -368,7 +361,7 @@
[eva:final-states] Values at end of function fgets:
Frama_C_entropy_source ∈ [--..--]
__fc_errno ∈ [--..--]
- i ∈ [0..9]
+ i ∈ [0..9] or UNINITIALIZED
buf[0..8] ∈ [--..--] or UNINITIALIZED
[9] ∈ {0} or UNINITIALIZED
__retres ∈ {{ NULL ; &buf[0] }}
@@ -396,7 +389,7 @@
__fc_heap_status ∈ [--..--]
Frama_C_entropy_source ∈ [--..--]
__fc_errno ∈ [--..--]
- cur ∈ [0..2147483647]
+ cur ∈ [0..2147483647] or UNINITIALIZED
line ∈
{{ NULL ; &__malloc_w_getline_l73[0] ; &__realloc_w_getline_l104[0] }}
len ∈ [0..2147483647]
@@ -417,10 +410,10 @@
len ∈ [0..2147483647]
total_len ∈ [--..--]
read ∈ {-1} or UNINITIALIZED
- c ∈ [-1..255]
+ c ∈ [-1..255] or UNINITIALIZED
buf[0..8] ∈ [--..--] or UNINITIALIZED
[9] ∈ {0} or UNINITIALIZED
- r_1 ∈ {{ NULL ; &buf[0] }}
+ r_1 ∈ {{ NULL ; &buf[0] }} or UNINITIALIZED
__retres ∈ {0; 1}
__malloc_w_getline_l73[0..1] ∈ [--..--] or UNINITIALIZED
__realloc_w_getline_l104[0..2147483645] ∈ [--..--] or UNINITIALIZED
diff --git a/tests/libc/oracle/stdio_h.res.oracle b/tests/libc/oracle/stdio_h.res.oracle
index 8d5fe316aa1d5626a2165cfa25ecec40bc30f211..1757917375ac3a89a698ac499ebff3729f37a62d 100644
--- a/tests/libc/oracle/stdio_h.res.oracle
+++ b/tests/libc/oracle/stdio_h.res.oracle
@@ -172,14 +172,14 @@
__fc_heap_status ∈ [--..--]
Frama_C_entropy_source ∈ [--..--]
f ∈ {{ NULL ; &__fc_fopen + [0..120],0%8 }}
- r ∈ [--..--]
- tmp_2 ∈ {{ NULL ; &__fc_fopen + [0..120],0%8 }}
- told ∈ [-1..2147483647]
- toldo ∈ [-1..2147483647]
- redirected ∈ {{ NULL ; &__fc_fopen + [0..120],0%8 }}
+ r ∈ [--..--] or UNINITIALIZED
+ tmp_2 ∈ {{ NULL ; &__fc_fopen + [0..120],0%8 }} or UNINITIALIZED
+ told ∈ [-1..2147483647] or UNINITIALIZED
+ toldo ∈ [-1..2147483647] or UNINITIALIZED
+ redirected ∈ {{ NULL ; &__fc_fopen + [0..120],0%8 }} or UNINITIALIZED
fgets_buf0[0] ∈ [--..--] or UNINITIALIZED
- fgets_res ∈ {{ NULL ; &fgets_buf0[0] }}
+ fgets_res ∈ {{ NULL ; &fgets_buf0[0] }} or UNINITIALIZED
pos ∈ [--..--] or UNINITIALIZED
- res_fclose ∈ {-1; 0}
+ res_fclose ∈ {-1; 0} or UNINITIALIZED
__retres ∈ {0; 1; 2; 3}
S___fc_stdout[0..1] ∈ [--..--]
diff --git a/tests/libc/oracle/stdlib_c.0.res.oracle b/tests/libc/oracle/stdlib_c.0.res.oracle
index 276e662d50c399250dce2614e96308566c68c36b..6e7d8414d9bfec2d30151afdd104223983bdef11 100644
--- a/tests/libc/oracle/stdlib_c.0.res.oracle
+++ b/tests/libc/oracle/stdlib_c.0.res.oracle
@@ -256,7 +256,7 @@
resolved_name ∈
{{ NULL ; &__malloc_main_l44[0] ; &__malloc_realpath_l224[0] ;
&__malloc_realpath_l224_0[0] }}
- realpath_len ∈ [1..4096]
+ realpath_len ∈ [1..4096] or UNINITIALIZED
__retres ∈
{{ NULL ; &__malloc_main_l44[0] ; &__malloc_realpath_l224[0] ;
&__malloc_realpath_l224_0[0] }}
@@ -285,8 +285,8 @@
p_memal_res ∈ {0; 12}
p_memal_res2 ∈ {0; 12}
resolved_name ∈ {{ NULL ; &__malloc_main_l44[0] }}
- realpath_res ∈ {{ NULL ; &__malloc_realpath_l224[0] }}
- canon ∈ {{ NULL ; &__malloc_realpath_l224_0[0] }}
+ realpath_res ∈ {{ NULL ; &__malloc_realpath_l224[0] }} or UNINITIALIZED
+ canon ∈ {{ NULL ; &__malloc_realpath_l224_0[0] }} or UNINITIALIZED
__retres ∈ {0; 1}
__calloc_w_main_l33[0..1073741823] ∈ {0; 42}
__malloc_main_l44[0..4095] ∈ [--..--] or UNINITIALIZED
diff --git a/tests/libc/oracle/stdlib_c.1.res.oracle b/tests/libc/oracle/stdlib_c.1.res.oracle
index 95a6a6d6b063be4bf82b8f17affcbf3e9e09f9fe..8268d02f205f892166fe3a4645898cbcf235fc75 100644
--- a/tests/libc/oracle/stdlib_c.1.res.oracle
+++ b/tests/libc/oracle/stdlib_c.1.res.oracle
@@ -274,7 +274,7 @@
resolved_name ∈
{{ NULL ; &__malloc_main_l44[0] ; &__malloc_realpath_l224[0] ;
&__malloc_realpath_l224_0[0] }}
- realpath_len ∈ [1..4096]
+ realpath_len ∈ [1..4096] or UNINITIALIZED
__retres ∈
{{ NULL ; &__malloc_main_l44[0] ; &__malloc_realpath_l224[0] ;
&__malloc_realpath_l224_0[0] }}
diff --git a/tests/libc/oracle/stdlib_c.2.res.oracle b/tests/libc/oracle/stdlib_c.2.res.oracle
index 8090933af98958cc3fd154206444496df7d62a26..2dad09f22b8979bdfa7c27c7d7b0de76d0d17d1d 100644
--- a/tests/libc/oracle/stdlib_c.2.res.oracle
+++ b/tests/libc/oracle/stdlib_c.2.res.oracle
@@ -208,7 +208,7 @@
l ∈ [0..4294967292],0%4
p ∈
{{ NULL ; &__malloc_calloc_l72[0] ; &__malloc_calloc_l72_0[0] ;
- &__malloc_w_calloc_l72_1[0] }}
+ &__malloc_w_calloc_l72_1[0] }} or UNINITIALIZED
__retres ∈
{{ NULL ; (void *)&__malloc_calloc_l72 ;
(void *)&__malloc_calloc_l72_0 ;
@@ -228,7 +228,7 @@
resolved_name ∈
{{ NULL ; &__malloc_main_l44[0] ; &__malloc_realpath_l224[0] ;
&__malloc_realpath_l224_0[0] }}
- realpath_len ∈ [1..4096]
+ realpath_len ∈ [1..4096] or UNINITIALIZED
__retres ∈
{{ NULL ; &__malloc_main_l44[0] ; &__malloc_realpath_l224[0] ;
&__malloc_realpath_l224_0[0] }}
@@ -254,8 +254,8 @@
p_memal_res ∈ {0; 12}
p_memal_res2 ∈ {0; 12}
resolved_name ∈ {{ NULL ; &__malloc_main_l44[0] }}
- realpath_res ∈ {{ NULL ; &__malloc_realpath_l224[0] }}
- canon ∈ {{ NULL ; &__malloc_realpath_l224_0[0] }}
+ realpath_res ∈ {{ NULL ; &__malloc_realpath_l224[0] }} or UNINITIALIZED
+ canon ∈ {{ NULL ; &__malloc_realpath_l224_0[0] }} or UNINITIALIZED
__retres ∈ {0; 1}
__malloc_calloc_l72[0..3] ∈ [--..--] or UNINITIALIZED
__malloc_calloc_l72_0[0..4294967291] ∈ [--..--] or UNINITIALIZED
diff --git a/tests/libc/oracle/stdlib_c_env.res.oracle b/tests/libc/oracle/stdlib_c_env.res.oracle
index 54a82b9cccb4eb9a4b3fdbe277fce4ba362608a6..6c927c63c406cec5304736c2c1d03891621f516a 100644
--- a/tests/libc/oracle/stdlib_c_env.res.oracle
+++ b/tests/libc/oracle/stdlib_c_env.res.oracle
@@ -291,7 +291,7 @@
__fc_env[0..4095] ∈
{{ NULL ; &s[0] ; &__fc_env_strings + [0..63] ; "BLA=1" }}
Frama_C_entropy_source ∈ [--..--]
- namelen ∈ [0..63]
+ namelen ∈ [0..63] or UNINITIALIZED
__fc_env_strings[0..62] ∈ [--..--]
[63] ∈ {0}
__retres ∈ {-1; 0}
@@ -299,7 +299,7 @@
__fc_env[0..4095] ∈
{{ NULL ; &s[0] ; &__fc_env_strings + [0..63] ; "BLA=1" }}
Frama_C_entropy_source ∈ [--..--]
- namelen ∈ [0..63]
+ namelen ∈ [0..63] or UNINITIALIZED
__retres ∈ {-1; 0}
[eva:final-states] Values at end of function main:
__fc_env[0..4095] ∈
diff --git a/tests/libc/oracle/sys_sendfile_h.res.oracle b/tests/libc/oracle/sys_sendfile_h.res.oracle
index a77a6d78706e75bc12d5c497f8ab3a3595aadd83..b214dddf4a669a0b9b00116eb551a3ad6404f598 100644
--- a/tests/libc/oracle/sys_sendfile_h.res.oracle
+++ b/tests/libc/oracle/sys_sendfile_h.res.oracle
@@ -73,8 +73,8 @@
__fc_fds[0..1023] ∈ [--..--]
out_fd ∈ [-1..1023] or UNINITIALIZED
in_fd ∈ [-1..1023]
- offset ∈ [--..--]
+ offset ∈ [--..--] or UNINITIALIZED
r1 ∈ [-1..42] or UNINITIALIZED
r3 ∈ [-1..42] or UNINITIALIZED
- r ∈ {-1; 0}
+ r ∈ {-1; 0} or UNINITIALIZED
__retres ∈ {0; 1}
diff --git a/tests/libc/oracle/sys_socket_h.res.oracle b/tests/libc/oracle/sys_socket_h.res.oracle
index bd668507be702ce8fb2db931063de1a8cea31f2a..916cb12aab73ea390d49446a7d751126a79c1e28 100644
--- a/tests/libc/oracle/sys_socket_h.res.oracle
+++ b/tests/libc/oracle/sys_socket_h.res.oracle
@@ -61,5 +61,5 @@
.msg_iovlen ∈ {5; 6}
{.msg_control; .msg_controllen; .msg_flags} ∈ UNINITIALIZED
sockfd ∈ [-1..1023]
- r ∈ [-1..2147483647]
+ r ∈ [-1..2147483647] or UNINITIALIZED
__retres ∈ {0; 1}
diff --git a/tests/libc/oracle/sys_stat_h.res.oracle b/tests/libc/oracle/sys_stat_h.res.oracle
index edb2f90be28452d72fa2645a8b131995f355ded9..8ee1daff1c0849cf02deee1acf713362f0983e0e 100644
--- a/tests/libc/oracle/sys_stat_h.res.oracle
+++ b/tests/libc/oracle/sys_stat_h.res.oracle
@@ -113,16 +113,16 @@
__fc_fds[0..1023] ∈ [--..--]
fd ∈ [-1..1023]
st ∈ [--..--] or UNINITIALIZED
- r ∈ {-1; 0}
- r_mkdir ∈ {-1; 0}
- old_mask ∈ [--..--]
- r2 ∈ {-1; 0}
- r3 ∈ {-1; 0}
- r4 ∈ {-1; 0}
- r5 ∈ {-1; 0}
- r6 ∈ {-1; 0}
- r7 ∈ {-1; 0}
+ r ∈ {-1; 0} or UNINITIALIZED
+ r_mkdir ∈ {-1; 0} or UNINITIALIZED
+ old_mask ∈ [--..--] or UNINITIALIZED
+ r2 ∈ {-1; 0} or UNINITIALIZED
+ r3 ∈ {-1; 0} or UNINITIALIZED
+ r4 ∈ {-1; 0} or UNINITIALIZED
+ r5 ∈ {-1; 0} or UNINITIALIZED
+ r6 ∈ {-1; 0} or UNINITIALIZED
+ r7 ∈ {-1; 0} or UNINITIALIZED
buf ∈ [--..--] or UNINITIALIZED
- r8 ∈ {-1; 0}
- r9 ∈ {-1; 0}
+ r8 ∈ {-1; 0} or UNINITIALIZED
+ r9 ∈ {-1; 0} or UNINITIALIZED
__retres ∈ {-1; 0; 1; 2; 3}
diff --git a/tests/libc/oracle/sys_uio_h.res.oracle b/tests/libc/oracle/sys_uio_h.res.oracle
index b19e97d241f4703fe0cf1811e4b5e03c67f8b0d2..35c0c56e12390bfb59a0337eef1d87b048eb2d68 100644
--- a/tests/libc/oracle/sys_uio_h.res.oracle
+++ b/tests/libc/oracle/sys_uio_h.res.oracle
@@ -103,6 +103,6 @@
[3].iov_base ∈ {{ (void *)&buf2 }}
[3].iov_len ∈ {14}
fd ∈ [-1..1023]
- w ∈ [-1..2147483647]
- r ∈ [-1..2147483647]
+ w ∈ [-1..2147483647] or UNINITIALIZED
+ r ∈ [-1..2147483647] or UNINITIALIZED
__retres ∈ [-2..2147483647]
diff --git a/tests/libc/oracle/termios.res.oracle b/tests/libc/oracle/termios.res.oracle
index 799c219eaa98136c7c028bfaab8990f86edede99..c37ece069c778bbece4c9d262f1a6c157894df79 100644
--- a/tests/libc/oracle/termios.res.oracle
+++ b/tests/libc/oracle/termios.res.oracle
@@ -70,6 +70,6 @@
fd ∈ [-1..1023]
tio ∈ [--..--] or UNINITIALIZED
res ∈ {-1; 0}
- sp1 ∈ [--..--]
- sp2 ∈ [--..--]
+ sp1 ∈ [--..--] or UNINITIALIZED
+ sp2 ∈ [--..--] or UNINITIALIZED
__retres ∈ {-1; 0; 1; 8}
diff --git a/tests/libc/oracle/time_h.res.oracle b/tests/libc/oracle/time_h.res.oracle
index a32b98d7871f1de7738a4e07da647fc39b86cf35..e2c79167c90417685953eeb91b4ac0efb4f8f344 100644
--- a/tests/libc/oracle/time_h.res.oracle
+++ b/tests/libc/oracle/time_h.res.oracle
@@ -263,12 +263,12 @@
r ∈ {-1; 0; 4; 22}
creq.tv_sec ∈ [--..--] or UNINITIALIZED
.tv_nsec ∈ [0..999999999] or UNINITIALIZED
- tt ∈ {42}
- time_str ∈ {{ &__fc_ctime[0] }}
- mytime ∈ [--..--]
- t ∈ [--..--]
+ tt ∈ {42} or UNINITIALIZED
+ time_str ∈ {{ &__fc_ctime[0] }} or UNINITIALIZED
+ mytime ∈ [--..--] or UNINITIALIZED
+ t ∈ [--..--] or UNINITIALIZED
res_time ∈ {{ NULL ; &mytime2 }} or UNINITIALIZED
mytime2 ∈ [--..--] or UNINITIALIZED
- localp ∈ {{ NULL ; &localr }}
+ localp ∈ {{ NULL ; &localr }} or UNINITIALIZED
localr ∈ [--..--] or UNINITIALIZED
__retres ∈ {0; 1; 2}
diff --git a/tests/libc/oracle/unistd_h.0.res.oracle b/tests/libc/oracle/unistd_h.0.res.oracle
index 69911d84a7244a5f0a797b6dfe46824a5ca3c93b..5290754d8d489a081d47cdd8a12bb28370890be2 100644
--- a/tests/libc/oracle/unistd_h.0.res.oracle
+++ b/tests/libc/oracle/unistd_h.0.res.oracle
@@ -621,24 +621,24 @@
r ∈ {-1; 0}
hostname[0..255] ∈ [--..--] or UNINITIALIZED
fd ∈ [-1..1023]
- offset ∈ [-1..2147483647]
- fd2 ∈ [-1..1023]
- pid ∈ [-1..2147483647]
- l ∈ [--..--]
+ offset ∈ [-1..2147483647] or UNINITIALIZED
+ fd2 ∈ [-1..1023] or UNINITIALIZED
+ pid ∈ [-1..2147483647] or UNINITIALIZED
+ l ∈ [--..--] or UNINITIALIZED
cwd[0..63] ∈ [--..--] or UNINITIALIZED
- res_getcwd ∈ {{ NULL ; &cwd[0] }}
- pconf ∈ [--..--]
+ res_getcwd ∈ {{ NULL ; &cwd[0] }} or UNINITIALIZED
+ pconf ∈ [--..--] or UNINITIALIZED
ruid ∈ [--..--] or UNINITIALIZED
euid ∈ [--..--] or UNINITIALIZED
suid ∈ [--..--] or UNINITIALIZED
rgid ∈ [--..--] or UNINITIALIZED
egid ∈ [--..--] or UNINITIALIZED
sgid ∈ [--..--] or UNINITIALIZED
- p ∈ [--..--]
- tty ∈ {{ NULL ; &__fc_ttyname[0] }}
+ p ∈ [--..--] or UNINITIALIZED
+ tty ∈ {{ NULL ; &__fc_ttyname[0] }} or UNINITIALIZED
halfpipe ∈ UNINITIALIZED
pipefd[0..1] ∈ [0..1023] or UNINITIALIZED
- unslept ∈ [0..42]
+ unslept ∈ [0..42] or UNINITIALIZED
buf[0..4294967294] ∈ [--..--] or UNINITIALIZED
- rread ∈ [--..--]
+ rread ∈ [--..--] or UNINITIALIZED
__retres ∈ {0; 1}
diff --git a/tests/libc/oracle/unistd_h.1.res.oracle b/tests/libc/oracle/unistd_h.1.res.oracle
index 85607de98dd75b610ec922e97d6186922ef614cc..68dbe4ab19c2f105825affd2569f87495687327e 100644
--- a/tests/libc/oracle/unistd_h.1.res.oracle
+++ b/tests/libc/oracle/unistd_h.1.res.oracle
@@ -621,24 +621,24 @@
r ∈ {-1; 0}
hostname[0..255] ∈ [--..--] or UNINITIALIZED
fd ∈ [-1..1023]
- offset ∈ [-1..2147483647]
- fd2 ∈ [-1..1023]
- pid ∈ [-1..2147483647]
- l ∈ [--..--]
+ offset ∈ [-1..2147483647] or UNINITIALIZED
+ fd2 ∈ [-1..1023] or UNINITIALIZED
+ pid ∈ [-1..2147483647] or UNINITIALIZED
+ l ∈ [--..--] or UNINITIALIZED
cwd[0..63] ∈ [--..--] or UNINITIALIZED
- res_getcwd ∈ {{ NULL ; &cwd[0] }}
- pconf ∈ [--..--]
+ res_getcwd ∈ {{ NULL ; &cwd[0] }} or UNINITIALIZED
+ pconf ∈ [--..--] or UNINITIALIZED
ruid ∈ [--..--] or UNINITIALIZED
euid ∈ [--..--] or UNINITIALIZED
suid ∈ [--..--] or UNINITIALIZED
rgid ∈ [--..--] or UNINITIALIZED
egid ∈ [--..--] or UNINITIALIZED
sgid ∈ [--..--] or UNINITIALIZED
- p ∈ [--..--]
- tty ∈ {{ NULL ; &__fc_ttyname[0] }}
+ p ∈ [--..--] or UNINITIALIZED
+ tty ∈ {{ NULL ; &__fc_ttyname[0] }} or UNINITIALIZED
halfpipe ∈ UNINITIALIZED
pipefd[0..1] ∈ [0..1023] or UNINITIALIZED
- unslept ∈ [0..42]
+ unslept ∈ [0..42] or UNINITIALIZED
buf[0..4294967294] ∈ [--..--] or UNINITIALIZED
- rread ∈ [--..--]
+ rread ∈ [--..--] or UNINITIALIZED
__retres ∈ {0; 1}
diff --git a/tests/libc/oracle/wchar_c_h.0.res.oracle b/tests/libc/oracle/wchar_c_h.0.res.oracle
index e9e310ee417d1524c5e016661bcbad7ee654197e..7974bac0fc9ad3f3e83b11495623c5f36d11b5f5 100644
--- a/tests/libc/oracle/wchar_c_h.0.res.oracle
+++ b/tests/libc/oracle/wchar_c_h.0.res.oracle
@@ -307,12 +307,13 @@
r ∈ [--..--] or UNINITIALIZED
i ∈ [--..--]
res ∈ {{ NULL ; &buf[0] ; L"Needle" + [0..--],0%4 }}
- wc_0 ∈ {{ L"ABC" }}
- p ∈ {{ L"ABC" + {4} }}
- wcr ∈ {{ L"ABC" + {8} }}
- wmr1 ∈ {0}
- wmr2 ∈ {{ L"ABC" + {8} }}
- dupbuf ∈ {{ NULL ; &__malloc_wcsdup_l99_0[0] }} or ESCAPINGADDR
+ wc_0 ∈ {{ L"ABC" }} or UNINITIALIZED
+ p ∈ {{ L"ABC" + {4} }} or UNINITIALIZED
+ wcr ∈ {{ L"ABC" + {8} }} or UNINITIALIZED
+ wmr1 ∈ {0} or UNINITIALIZED
+ wmr2 ∈ {{ L"ABC" + {8} }} or UNINITIALIZED
+ dupbuf ∈
+ {{ NULL ; &__malloc_wcsdup_l99_0[0] }} or UNINITIALIZED or ESCAPINGADDR
__retres ∈ {0}
__malloc_wcsdup_l99[0] ∈ {65}
[1] ∈ {66}
diff --git a/tests/libc/oracle/wchar_c_h.1.res.oracle b/tests/libc/oracle/wchar_c_h.1.res.oracle
index 1d03e1b33af9b398bdd1645f1c9b1dac1647cd1a..3c6efb2a6ee2b20d4222a4cb41a63f4a12ffeeb5 100644
--- a/tests/libc/oracle/wchar_c_h.1.res.oracle
+++ b/tests/libc/oracle/wchar_c_h.1.res.oracle
@@ -224,9 +224,9 @@
r ∈ [--..--] or UNINITIALIZED
i ∈ [--..--]
res ∈ {{ NULL ; &buf[0] ; L"Needle" + [0..--],0%4 }}
- wc_0 ∈ {{ L"ABC" }}
- p ∈ {{ L"ABC" + {4} }}
- wcr ∈ {{ L"ABC" + {8} }}
- wmr1 ∈ {0}
- wmr2 ∈ {{ L"ABC" + {8} }}
+ wc_0 ∈ {{ L"ABC" }} or UNINITIALIZED
+ p ∈ {{ L"ABC" + {4} }} or UNINITIALIZED
+ wcr ∈ {{ L"ABC" + {8} }} or UNINITIALIZED
+ wmr1 ∈ {0} or UNINITIALIZED
+ wmr2 ∈ {{ L"ABC" + {8} }} or UNINITIALIZED
__retres ∈ {0}
diff --git a/tests/libc/oracle/wchar_h.res.oracle b/tests/libc/oracle/wchar_h.res.oracle
index a58e0252f356cfb46334eaf577744d07b643d2e9..4e50f74af67f626a0e7ee94e1b57298845c2b7fd 100644
--- a/tests/libc/oracle/wchar_h.res.oracle
+++ b/tests/libc/oracle/wchar_h.res.oracle
@@ -199,14 +199,14 @@
fd ∈ {{ NULL ; &__fc_fopen + [0..120],0%8 }}
buf[0..28] ∈ [--..--] or UNINITIALIZED
[29] ∈ UNINITIALIZED
- res ∈ {{ NULL ; &buf[0] }}
+ res ∈ {{ NULL ; &buf[0] }} or UNINITIALIZED
buf2[0] ∈ {97} or UNINITIALIZED
[1] ∈ {98} or UNINITIALIZED
- r ∈ {{ &wdst[0] }}
- wsrc ∈ {{ L"wide thing" }}
+ r ∈ {{ &wdst[0] }} or UNINITIALIZED
+ wsrc ∈ {{ L"wide thing" }} or UNINITIALIZED
wdst[0..9] ∈ [--..--] or UNINITIALIZED
- wdst2[0..9] ∈ {65}
- [10] ∈ {0}
- [11..19] ∈ [--..--]
- ir ∈ [--..--]
+ wdst2[0..9] ∈ {65} or UNINITIALIZED
+ [10] ∈ {0} or UNINITIALIZED
+ [11..19] ∈ [--..--] or UNINITIALIZED
+ ir ∈ [--..--] or UNINITIALIZED
__retres ∈ {0; 1}
diff --git a/tests/libc/runtime.c b/tests/libc/runtime.c
index 25588a82e04f0833265e745ac70217161f1b0ef7..a99e23548c9e6ac3b88d10d4cc9d93dc25865cf9 100644
--- a/tests/libc/runtime.c
+++ b/tests/libc/runtime.c
@@ -1,5 +1,6 @@
/* run.config*
COMMENT: tests that the runtime can compile without errors (for PathCrawler, E-ACSL, ...)
+ ENABLED_IF: %{bin-available:gcc}
CMD: FRAMAC='@frama-c@' %{dep:@PTEST_DIR@/runtime.sh}
OPT: %{dep:@FRAMAC_SHARE@/libc/__fc_runtime.c}
*/
diff --git a/tests/libc/runtime.sh b/tests/libc/runtime.sh
index aee0cf3d823f1aa61f34db70db8fd8caae2f4239..87893cee2481a134b0f831e3fb8830b974556ebc 100755
--- a/tests/libc/runtime.sh
+++ b/tests/libc/runtime.sh
@@ -3,5 +3,5 @@ set -e
if test -z "$FRAMAC"; then echo "variable FRAMAC must be set"; exit 1; fi
TMPDIR=$(mktemp -d fc_test_libc_XXXXXXXX)
$FRAMAC -print-machdep-header > $TMPDIR/__fc_machdep.h
-gcc -I$TMPDIR -D__FC_MACHDEP_X86_64 $@ -Wno-attributes -std=c99 -Wall -Wwrite-strings -o /dev/null
+gcc -I$TMPDIR -D__FC_MACHDEP_X86_64 $@ -Wno-attributes -std=c99 -Wall -Wwrite-strings -Wno-builtin-macro-redefined -Wno-unknown-warning-option -o /dev/null
rm -fr $TMPDIR
diff --git a/tests/misc/oracle/audit-out.json b/tests/misc/oracle/audit-out.json
index e4a021a87048620e0f9bd7d91b11dd4756052ff7..cc28dd687ce253848bf50fa7d3796621e8a44e03 100644
--- a/tests/misc/oracle/audit-out.json
+++ b/tests/misc/oracle/audit-out.json
@@ -64,7 +64,7 @@
"typing:implicit-function-declaration",
"typing:incompatible-pointer-types",
"typing:incompatible-types-call", "typing:inconsistent-specifier",
- "typing:int-conversion", "typing:no-proto"
+ "typing:int-conversion", "typing:merge-conversion", "typing:no-proto"
],
"disabled": [
"CERT:EXP:10", "acsl-float-compare", "c11", "file:not-found",
diff --git a/tests/misc/oracle/bts0990_link.res.oracle b/tests/misc/oracle/bts0990_link.res.oracle
index 625dcbb43e31d4caf8a33cac763064d95ed6aec4..2b6b54c6daa7dfd4d45df7138029fa826c464c0f 100644
--- a/tests/misc/oracle/bts0990_link.res.oracle
+++ b/tests/misc/oracle/bts0990_link.res.oracle
@@ -1,7 +1,8 @@
[kernel] Parsing bts0990_link.i (no preprocessing)
[kernel] Parsing bts0990_link_1.i (no preprocessing)
[kernel] User Error: Incompatible declaration for s:
- different type constructors: char * vs. char [100]
+ different type constructors:
+ char * and char [100]
First declaration was at bts0990_link.i:8
Current declaration is at bts0990_link_1.i:4
[kernel] Frama-C aborted: invalid user input.
diff --git a/tests/spec/oracle/preprocess_string.res.oracle b/tests/spec/oracle/preprocess_string.res.oracle
index f7ee475466ef243420d1a8429c94b1a4eda9fcd3..ea37c11725bdad4a629e92e33d92c26f9703b091 100644
--- a/tests/spec/oracle/preprocess_string.res.oracle
+++ b/tests/spec/oracle/preprocess_string.res.oracle
@@ -1,4 +1,4 @@
-[kernel] Warning: your preprocessor is not known to handle option `-nostdinc'. If pre-processing fails because of it, please add -no-cpp-frama-c-compliant option to Frama-C's command-line. If you do not want to see this warning again, explicitly use option -cpp-frama-c-compliant.
+[kernel] Warning: your preprocessor is not known to handle option `-nostdinc'. If preprocessing fails because of it, please add -no-cpp-frama-c-compliant option to Frama-C's command-line. If you do not want to see this warning again, explicitly use option -cpp-frama-c-compliant.
[kernel] Parsing preprocess_string.c (with preprocessing)
/* Generated by Frama-C */
/*@ ensures *("/*" + 0) ≡ '/'; */
diff --git a/tests/syntax/clang_redef_warning.c b/tests/syntax/clang_redef_warning.c
new file mode 100644
index 0000000000000000000000000000000000000000..3fab7838c0ac0978340365e4bfeac9706b20a766
--- /dev/null
+++ b/tests/syntax/clang_redef_warning.c
@@ -0,0 +1,8 @@
+/* run.config
+ENABLED_IF: %{bin-available:clang}
+OPT: -cpp-command="clang -C -E -I." -cpp-frama-c-compliant -print
+*/
+
+#include <stddef.h>
+
+void f(void) { }
diff --git a/tests/syntax/conflict.c b/tests/syntax/conflict.c
new file mode 100644
index 0000000000000000000000000000000000000000..dc85f0d78bd1efdb13bc1438f43fc44569db9b1e
--- /dev/null
+++ b/tests/syntax/conflict.c
@@ -0,0 +1,18 @@
+const int a[1] = { 0 };
+int b = a[0];
+
+struct stru {
+ const int c;
+};
+
+const struct stru d = { 0 };
+
+int e = d.c;
+
+struct stru2 {
+ int f;
+};
+
+const struct stru2 g = { 0 };
+
+int h = g.f;
diff --git a/tests/syntax/foo.c b/tests/syntax/foo.c
new file mode 100644
index 0000000000000000000000000000000000000000..ea0d60a5b254a20d72e84e1f4ce3808e7536349e
--- /dev/null
+++ b/tests/syntax/foo.c
@@ -0,0 +1,7 @@
+/* run.config
+EXECNOW: BIN foo".c cp %{dep:./foo.src} foo\".c
+DEPS: ./foo".c
+STDOPT: +"./foo\\\".c"
+*/
+
+extern int test = 1;
diff --git "a/tests/syntax/foo\".c" b/tests/syntax/foo.src
similarity index 51%
rename from "tests/syntax/foo\".c"
rename to tests/syntax/foo.src
index 5933f9603a0e136d34c0680af6714d936839eaa5..0475cdfdd7c810cf0e766dde4c1c950f57a5cd7b 100644
--- "a/tests/syntax/foo\".c"
+++ b/tests/syntax/foo.src
@@ -1,6 +1,6 @@
#include "assert.h"
-int test = 1;
+extern int test; /* initialized into file foo.c */
int main () {
assert(test);
diff --git a/tests/syntax/ghost_cv_incompat.i b/tests/syntax/ghost_cv_incompat.i
index e75186e231c116379b922093101c28ba321fbdfa..89ede27d8fe60412eb3ca078e5af2b7e4a47f699 100644
--- a/tests/syntax/ghost_cv_incompat.i
+++ b/tests/syntax/ghost_cv_incompat.i
@@ -23,12 +23,12 @@ void def_not_ghost(void) /*@ ghost (int * p) */ {}
//
int ng ;
-//@ ghost int * gl_gp ;
+//@ ghost int * const gl_gp = 0;
//@ ghost int \ghost * gl_gpg_1 = &ng ; // error: address of non-ghost integer into pointer to ghost
//@ ghost int \ghost * gl_gpg_2 = gl_gp ; // error: pointer to a non-ghost location into pointer to ghost
-int *gl_p00, *gl_p01 ;
+int * const gl_p00 = 0; int * const gl_p01 = 0 ;
// error: we transform pointer to non-ghost into pointer to ghosts
//@ ghost int \ghost * gl_array[3] = { gl_p00, gl_p00, gl_p01 };
@@ -100,7 +100,7 @@ void call_ng_to_g(void){
//
//@ ghost int g ;
-//@ ghost int \ghost * gl_gpg ;
+//@ ghost int \ghost * const gl_gpg = 0;
//@ ghost int * gl_gp_1 = &g ; // error: address of ghost integer into pointer to non-ghost
//@ ghost int * gl_gp_2 = gl_gpg ; // error: pointer to a ghost location into pointer to non-ghost
diff --git a/tests/syntax/ghost_cv_var_decl.c b/tests/syntax/ghost_cv_var_decl.c
index c407d427b9c4feaaa9c790338a47b8aa8f7da522..b8193afe7da955d98d0ead50c9146d690df4b988 100644
--- a/tests/syntax/ghost_cv_var_decl.c
+++ b/tests/syntax/ghost_cv_var_decl.c
@@ -240,7 +240,7 @@ void reference_functions(){
//@ ghost int x ;
int i ;
-int * p ;
+int * const p = &i;
//@ ghost int * gp1 = &i ;
//@ ghost int * gp2 = p ;
diff --git a/tests/syntax/ko_global.c b/tests/syntax/ko_global.c
new file mode 100644
index 0000000000000000000000000000000000000000..2c61e443df6b3d5166f35a10186bc786e8626a20
--- /dev/null
+++ b/tests/syntax/ko_global.c
@@ -0,0 +1,41 @@
+/* run.config
+ EXIT: 1
+ STDOPT:
+*/
+
+int * const a;
+int * b = a;
+
+struct stru {
+ const int c;
+};
+
+struct stru d = { 0 };
+
+int e = d.c;
+
+const int f = f;
+
+int g = g;
+
+int h = (int) &h;
+
+const int i;
+int j = i;
+
+int k = 1;
+int l = k;
+
+struct stru2 {
+ int m;
+};
+
+int n = 1;
+struct stru2 o = { n };
+
+union unio2 {
+ int p;
+};
+
+int q = 1;
+union unio2 r = {q};
diff --git a/tests/syntax/merge_loc.i b/tests/syntax/merge_loc.i
index 2a93071ea4d794e47a457e2eb32bbca80ddade3f..ed787d3174c9f76065795e4ac716b99774a4dcd8 100644
--- a/tests/syntax/merge_loc.i
+++ b/tests/syntax/merge_loc.i
@@ -20,4 +20,4 @@ extern int baz;
extern int baz;
-int z = (int) &baz;
+long z = (long) &baz;
diff --git a/tests/syntax/ok_globals.c b/tests/syntax/ok_globals.c
new file mode 100644
index 0000000000000000000000000000000000000000..712226b32adb9549dd0f17437d0a146f1c911bdd
--- /dev/null
+++ b/tests/syntax/ok_globals.c
@@ -0,0 +1,34 @@
+const int a = 0;
+const int b = 1;
+int c = a + b;
+
+int d = (int) ((int*)3+5);
+
+const int e = 42;
+int f = (int) ((int*)e);
+
+union uty {
+ int g;
+ float h;
+};
+
+const int i = 1;
+union uty j = {i};
+
+int k;
+int l = sizeof(k);
+
+int m;
+int n = sizeof((int) &m);
+
+struct sty {
+ int o;
+};
+
+const int o = 1;
+struct sty p = { o };
+
+int q;
+unsigned long r = (unsigned long) &q;
+
+long s = (long) &s;
diff --git a/tests/syntax/oracle/clang_redef_warning.res.oracle b/tests/syntax/oracle/clang_redef_warning.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..76e9cbd1a4f3c9d3ecd334881744803c8c4676f1
--- /dev/null
+++ b/tests/syntax/oracle/clang_redef_warning.res.oracle
@@ -0,0 +1,8 @@
+[kernel] Parsing clang_redef_warning.c (with preprocessing)
+/* Generated by Frama-C */
+void f(void)
+{
+ return;
+}
+
+
diff --git a/tests/syntax/oracle/conflict.res.oracle b/tests/syntax/oracle/conflict.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..c6efc60b067cd8c106f9281e4ad7b573f739e0b5
--- /dev/null
+++ b/tests/syntax/oracle/conflict.res.oracle
@@ -0,0 +1,15 @@
+[kernel] Parsing conflict.c (with preprocessing)
+/* Generated by Frama-C */
+struct stru {
+ int const c ;
+};
+struct stru2 {
+ int f ;
+};
+int const a[1] = {0};
+int b = a[0];
+struct stru const d = {.c = 0};
+int e = d.c;
+struct stru2 const g = {.f = 0};
+int h = g.f;
+
diff --git a/tests/syntax/oracle/cpp-command.4.res.oracle b/tests/syntax/oracle/cpp-command.4.res.oracle
index e42375af42082ed6fd520737d8a4bde16a1b9289..8a7eb85e889dcb788b90ebf762e3df7deaf6cfad 100644
--- a/tests/syntax/oracle/cpp-command.4.res.oracle
+++ b/tests/syntax/oracle/cpp-command.4.res.oracle
@@ -1,2 +1,2 @@
[kernel] Preprocessing command:
- gcc -E -C -I. -ITMP_MACHDEP -IFRAMAC_SHARE/libc -D__FRAMAC__ -dD -nostdinc 'cpp-command.c' -o 'TMPDIR/FILE.i'
+ gcc -E -C -I. -ITMP_MACHDEP -IFRAMAC_SHARE/libc -D__FRAMAC__ -dD -nostdinc -Wno-builtin-macro-redefined -Wno-unknown-warning-option 'cpp-command.c' -o 'TMPDIR/FILE.i'
diff --git a/tests/syntax/oracle/cpp-command.6.res.oracle b/tests/syntax/oracle/cpp-command.6.res.oracle
index ef44555760ec5721b7f94c555e0d657fec0858f6..f59eb94c447c1a9fd2659acc3d1381c13055312d 100644
--- a/tests/syntax/oracle/cpp-command.6.res.oracle
+++ b/tests/syntax/oracle/cpp-command.6.res.oracle
@@ -1,5 +1,5 @@
-[kernel] Warning: your preprocessor is not known to handle option `-nostdinc'. If pre-processing fails because of it, please add -no-cpp-frama-c-compliant option to Frama-C's command-line. If you do not want to see this warning again, explicitly use option -cpp-frama-c-compliant.
-[kernel] Warning: your preprocessor is not known to handle option `-dD'. If pre-processing fails because of it, please add -no-cpp-frama-c-compliant option to Frama-C's command-line. If you do not want to see this warning again, explicitly use option -cpp-frama-c-compliant.
+[kernel] Warning: your preprocessor is not known to handle option `-nostdinc'. If preprocessing fails because of it, please add -no-cpp-frama-c-compliant option to Frama-C's command-line. If you do not want to see this warning again, explicitly use option -cpp-frama-c-compliant.
+[kernel] Warning: your preprocessor is not known to handle option `-dD'. If preprocessing fails because of it, please add -no-cpp-frama-c-compliant option to Frama-C's command-line. If you do not want to see this warning again, explicitly use option -cpp-frama-c-compliant.
[kernel] Parsing cpp-command.c (with preprocessing)
extra_args: -ITMP_MACHDEP -IFRAMAC_SHARE/libc -D__FRAMAC__ -dD -nostdinc file_extra global_extra
[kernel] Warning: trying to preprocess annotation with an unknown preprocessor.
diff --git "a/tests/syntax/oracle/foo\".res.oracle" b/tests/syntax/oracle/foo.res.oracle
similarity index 83%
rename from "tests/syntax/oracle/foo\".res.oracle"
rename to tests/syntax/oracle/foo.res.oracle
index 9f5882a42c2c4e3d16b531b691bd653e12692639..eeb62ed6225a63a85031c308b31b799dc95b2420 100644
--- "a/tests/syntax/oracle/foo\".res.oracle"
+++ b/tests/syntax/oracle/foo.res.oracle
@@ -1,3 +1,4 @@
+[kernel] Parsing foo.c (with preprocessing)
[kernel] Parsing foo".c (with preprocessing)
/* Generated by Frama-C */
#include "assert.h"
diff --git a/tests/syntax/oracle/incompatible_qualifiers.1.res.oracle b/tests/syntax/oracle/incompatible_qualifiers.1.res.oracle
index 04b6994f796649ce89915dec160a82cb41cdf68c..6b65e9711ffe6feed2d14a9d675bcd1812a2324a 100644
--- a/tests/syntax/oracle/incompatible_qualifiers.1.res.oracle
+++ b/tests/syntax/oracle/incompatible_qualifiers.1.res.oracle
@@ -17,7 +17,7 @@ void k(int *(*f)(int volatile ));
fp1 *l(int *(*f)(int ));
-int (***m(int *(*f)(int volatile )))(char const );
+fp1 **m(int *(*f)(int volatile ));
fp1 * const *n(int *(*f)(int , fp1 **));
diff --git a/tests/syntax/oracle/inconsistent_decl.0.res.oracle b/tests/syntax/oracle/inconsistent_decl.0.res.oracle
index eea070edfc9f3c5daef68bce71e4c3ef7b17c4e8..60a0afd4ee07928001aac592f0aa2e0f13a1c0bc 100644
--- a/tests/syntax/oracle/inconsistent_decl.0.res.oracle
+++ b/tests/syntax/oracle/inconsistent_decl.0.res.oracle
@@ -3,7 +3,8 @@
Calling undeclared function f. Old style K&R code?
[kernel] Parsing inconsistent_decl_2.i (no preprocessing)
[kernel] User Error: Incompatible declaration for f:
- different type constructors: int vs. double
+ different type constructors:
+ int and double
First declaration was at inconsistent_decl.c:12
Current declaration is at inconsistent_decl_2.i:5
[kernel] Frama-C aborted: invalid user input.
diff --git a/tests/syntax/oracle/inconsistent_decl.1.res.oracle b/tests/syntax/oracle/inconsistent_decl.1.res.oracle
index eb9aa0b900887f8afea5a0ef86454c756de545ee..1520423b3fd7653ab6085347fd4f4f4053d63578 100644
--- a/tests/syntax/oracle/inconsistent_decl.1.res.oracle
+++ b/tests/syntax/oracle/inconsistent_decl.1.res.oracle
@@ -4,7 +4,8 @@
Its formals will be inferred from actual arguments
[kernel] Parsing inconsistent_decl_2.i (no preprocessing)
[kernel] User Error: Incompatible declaration for f:
- different type constructors: int vs. double
+ different type constructors:
+ int and double
First declaration was at inconsistent_decl.c:8
Current declaration is at inconsistent_decl_2.i:5
[kernel] Frama-C aborted: invalid user input.
diff --git a/tests/syntax/oracle/ko_global.res.oracle b/tests/syntax/oracle/ko_global.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..204f067a98c9e43a28e94eeca8b36ecd7581e598
--- /dev/null
+++ b/tests/syntax/oracle/ko_global.res.oracle
@@ -0,0 +1,11 @@
+[kernel] Parsing ko_global.c (with preprocessing)
+[kernel] ko_global.c:7: User Error: a is not a compile-time constant
+[kernel] ko_global.c:17: User Error: f is not a compile-time constant
+[kernel] ko_global.c:19: User Error: g is not a compile-time constant
+[kernel] ko_global.c:24: User Error: i is not a compile-time constant
+[kernel] ko_global.c:27: User Error: k is not a compile-time constant
+[kernel] ko_global.c:34: User Error: n is not a compile-time constant
+[kernel] ko_global.c:41: User Error: q is not a compile-time constant
+[kernel] User Error: stopping on file "ko_global.c" that has errors. Add '-kernel-msg-key pp'
+ for preprocessing command.
+[kernel] Frama-C aborted: invalid user input.
diff --git a/tests/syntax/oracle/merge_loc.res.oracle b/tests/syntax/oracle/merge_loc.res.oracle
index 9bf94a39b9416e64ec39f835a1d4d7476f809a5b..c80e91140f9ed8e5041a02c0feed29e406670d65 100644
--- a/tests/syntax/oracle/merge_loc.res.oracle
+++ b/tests/syntax/oracle/merge_loc.res.oracle
@@ -12,5 +12,5 @@ extern int baz;
//#line 23 "merge_loc.i"
-int z = (int)(& baz);
+long z = (long)(& baz);
diff --git a/tests/syntax/oracle/ok_globals.res.oracle b/tests/syntax/oracle/ok_globals.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..f614876f4d1b8db31029adcdde09b697f72cbe5a
--- /dev/null
+++ b/tests/syntax/oracle/ok_globals.res.oracle
@@ -0,0 +1,27 @@
+[kernel] Parsing ok_globals.c (with preprocessing)
+/* Generated by Frama-C */
+union uty {
+ int g ;
+ float h ;
+};
+struct sty {
+ int o ;
+};
+int const a = 0;
+int const b = 1;
+int c = a + b;
+int d = (int)((int *)3 + 5);
+int const e = 42;
+int f = (int)((int *)e);
+int const i = 1;
+union uty j = {.g = i};
+int k;
+int l = (int)sizeof(k);
+int m;
+int n = (int)sizeof((int)(& m));
+int const o = 1;
+struct sty p = {.o = o};
+int q;
+unsigned long r = (unsigned long)(& q);
+long s = (long)(& s);
+
diff --git a/tests/value/from_call.i b/tests/value/from_call.i
index 7e979f0b83d058231cb0c433e14b7f9528d06077..ff5f6045e01a6e21c252c47bb95e2e928698434e 100644
--- a/tests/value/from_call.i
+++ b/tests/value/from_call.i
@@ -67,9 +67,9 @@ int access_tab(int ind)
}
int AA,AR,AS;
-int At[2]={(int)&AA};
-int Ar[2]={(int)&AA};
-int *Ap=At;
+long At[2]={(long)&AA};
+long Ar[2]={(long)&AA};
+long *Ap=At;
/*@ assigns AR \from Ap[..] ;
assigns AS \from Ar[..] ;
diff --git a/tests/value/goto.i b/tests/value/goto.i
index 9a2430a1ea5d4a1b921525accb73c3fdead213bb..d4f59d0f5f204915b4a34d746c742d066a7661a2 100644
--- a/tests/value/goto.i
+++ b/tests/value/goto.i
@@ -1,6 +1,28 @@
+/* run.config*
+ STDOPT: +""
+*/
+
+volatile int nondet;
+
int stop () {
L: goto L;
+}
+void skip_declaration(void) {
+ int y, r;
+ if (nondet) {
+ goto l; // This goto skips the declaration of variable x below.
+ }
+ int x = 1;
+ y = 2;
+ l: // x and y are both uninitialized when coming from the goto
+ //@ check unknown: \initialized(&x);
+ //@ check unknown: x > 0;
+ //@ check unknown: \initialized(&y);
+ //@ check unknown: y > 0;
+ r = x + 1; // An initialization alarm must be emitted.
+ r = y + 1; // An initialization alarm must be emitted.
+ return;
}
int main() {
@@ -9,4 +31,5 @@ int main() {
if (c) stop ();
+ skip_declaration ();
}
diff --git a/tests/value/non_iso_initializer.i b/tests/value/non_iso_initializer.i
index c7059e95a9abaae748580c553986cba5b9db09cd..27bf94c012b7369459bcea9c91efbba78d7fc117 100644
--- a/tests/value/non_iso_initializer.i
+++ b/tests/value/non_iso_initializer.i
@@ -1,5 +1,5 @@
-int G0 = 42;
-int G1 = G0>>1;
+const int G0 = 42;
+const int G1 = G0>>1;
int G2 = G0 ^ G1 ;
int G3 = -1;
void main (void) {
diff --git a/tests/value/oracle/assigns.res.oracle b/tests/value/oracle/assigns.res.oracle
index a845b332c3d8c1a328e54a8b64e3e814a4d309b0..8f2d62128ef0016364b2525f7b5ac1e09a553f6e 100644
--- a/tests/value/oracle/assigns.res.oracle
+++ b/tests/value/oracle/assigns.res.oracle
@@ -66,10 +66,10 @@
[eva] Done for function h
[eva] computing for function j <- main1 <- main.
Called from assigns.i:54.
+[eva] using specification for function j
[eva] assigns.i:32:
Cannot evaluate range bound foo(*p)
(unsupported ACSL construct: logic function foo). Approximating
-[eva] using specification for function j
[eva] Done for function j
[eva] computing for function assigns_post <- main1 <- main.
Called from assigns.i:56.
@@ -140,11 +140,11 @@
Called from assigns.i:113.
[eva] computing for function f_main4_1 <- main4 <- main.
Called from assigns.i:104.
-[kernel] assigns.i:104:
- more than 200(1000) elements to enumerate. Approximating.
[eva] using specification for function f_main4_1
[kernel] assigns.i:104:
more than 200(1000) locations to update in array. Approximating.
+[kernel] assigns.i:104:
+ more than 200(1000) elements to enumerate. Approximating.
[eva] Done for function f_main4_1
[eva] computing for function f_main4_2 <- main4 <- main.
Called from assigns.i:105.
diff --git a/tests/value/oracle/from_call.0.res.oracle b/tests/value/oracle/from_call.0.res.oracle
index 101005bed38dbefde5ee3959f528076e5d542172..e8e374f9be8208104d40d0e6b79b78640bde6635 100644
--- a/tests/value/oracle/from_call.0.res.oracle
+++ b/tests/value/oracle/from_call.0.res.oracle
@@ -36,9 +36,9 @@
AA ∈ {0}
AR ∈ {0}
AS ∈ {0}
- At[0] ∈ {{ (int)&AA }}
+ At[0] ∈ {{ (long)&AA }}
[1] ∈ {0}
- Ar[0] ∈ {{ (int)&AA }}
+ Ar[0] ∈ {{ (long)&AA }}
[1] ∈ {0}
Ap ∈ {{ &At[0] }}
f_previous ∈ {{ &a }}
diff --git a/tests/value/oracle/from_call.1.res.oracle b/tests/value/oracle/from_call.1.res.oracle
index 14097263afd44b7dd97bc7fa346a82925f1cd965..60886fe4c870b421d9f775f05ff32df1fb96e7a1 100644
--- a/tests/value/oracle/from_call.1.res.oracle
+++ b/tests/value/oracle/from_call.1.res.oracle
@@ -36,9 +36,9 @@
AA ∈ {0}
AR ∈ {0}
AS ∈ {0}
- At[0] ∈ {{ (int)&AA }}
+ At[0] ∈ {{ (long)&AA }}
[1] ∈ {0}
- Ar[0] ∈ {{ (int)&AA }}
+ Ar[0] ∈ {{ (long)&AA }}
[1] ∈ {0}
Ap ∈ {{ &At[0] }}
f_previous ∈ {{ &a }}
diff --git a/tests/value/oracle/goto.res.oracle b/tests/value/oracle/goto.res.oracle
index 0a9dd76826c68ef0f40dc613d3f63b92164468c9..d258a57ce28334b1b75d3f60ccc672bdaa19745f 100644
--- a/tests/value/oracle/goto.res.oracle
+++ b/tests/value/oracle/goto.res.oracle
@@ -3,19 +3,37 @@
[eva] Computing initial state
[eva] Initial state computed
[eva:initial-state] Values of globals at initialization
-
+ nondet ∈ [--..--]
[eva] computing for function stop <- main.
- Called from goto.i:10.
+ Called from goto.i:32.
[eva] Recording results for stop
[eva] Done for function stop
+[eva] computing for function skip_declaration <- main.
+ Called from goto.i:34.
+[eva:alarm] goto.i:19: Warning: check 'unknown' got status unknown.
+[eva:alarm] goto.i:20: Warning: check 'unknown' got status unknown.
+[eva:alarm] goto.i:21: Warning: check 'unknown' got status unknown.
+[eva:alarm] goto.i:22: Warning: check 'unknown' got status unknown.
+[eva:alarm] goto.i:23: Warning:
+ accessing uninitialized left-value. assert \initialized(&x);
+[eva:alarm] goto.i:24: Warning:
+ accessing uninitialized left-value. assert \initialized(&y);
+[eva] Recording results for skip_declaration
+[eva] Done for function skip_declaration
[eva] Recording results for main
[eva] done for function main
[eva] ====== VALUES COMPUTED ======
+[eva:final-states] Values at end of function skip_declaration:
+ y ∈ {2}
+ r ∈ {3}
+ x ∈ {1}
[eva:final-states] Values at end of function stop:
NON TERMINATING FUNCTION
[eva:final-states] Values at end of function main:
c ∈ [--..--]
__retres ∈ {0}
+[from] Computing for function skip_declaration
+[from] Done for function skip_declaration
[from] Computing for function stop
[from] Non-terminating function stop (no dependencies)
[from] Done for function stop
@@ -23,11 +41,17 @@
[from] Done for function main
[from] ====== DEPENDENCIES COMPUTED ======
These dependencies hold at termination for the executions that terminate:
+[from] Function skip_declaration:
+ NO EFFECTS
[from] Function stop:
NON TERMINATING - NO EFFECTS
[from] Function main:
\result FROM \nothing
[from] ====== END OF DEPENDENCIES ======
+[inout] Out (internal) for function skip_declaration:
+ y; r; x
+[inout] Inputs for function skip_declaration:
+ nondet
[inout] Out (internal) for function stop:
\nothing
[inout] Inputs for function stop:
@@ -35,4 +59,4 @@
[inout] Out (internal) for function main:
c; __retres
[inout] Inputs for function main:
- \nothing
+ nondet
diff --git a/tests/value/oracle/ilevel.1.res.oracle b/tests/value/oracle/ilevel.1.res.oracle
index af0704f7b5dc3605bcf5703ca05d7133098127fb..ed394c4de8468cfab8e6a4af5a3a2f280c3e1747 100644
--- a/tests/value/oracle/ilevel.1.res.oracle
+++ b/tests/value/oracle/ilevel.1.res.oracle
@@ -27,23 +27,23 @@
i_0 ∈ [0..10]
j_0 ∈ [-25..-15] ∪ [0..10]
k_0 ∈ [100..200]
- a[0] ∈ {53}
- [1] ∈ {17}
- [2] ∈ {64}
- [3] ∈ {99}
- [4] ∈ {25}
- [5] ∈ {12}
- [6] ∈ {72}
- [7] ∈ {81}
- [8] ∈ {404}
- [9] ∈ {303}
- [10] ∈ {-101}
- s2 ∈ {40; 41; 42}
- s1 ∈ {-101; 12; 17; 25; 53; 64; 72; 81; 99; 303; 404}
+ a[0] ∈ {53} or UNINITIALIZED
+ [1] ∈ {17} or UNINITIALIZED
+ [2] ∈ {64} or UNINITIALIZED
+ [3] ∈ {99} or UNINITIALIZED
+ [4] ∈ {25} or UNINITIALIZED
+ [5] ∈ {12} or UNINITIALIZED
+ [6] ∈ {72} or UNINITIALIZED
+ [7] ∈ {81} or UNINITIALIZED
+ [8] ∈ {404} or UNINITIALIZED
+ [9] ∈ {303} or UNINITIALIZED
+ [10] ∈ {-101} or UNINITIALIZED
+ s2 ∈ {40; 41; 42} or UNINITIALIZED
+ s1 ∈ {-101; 12; 17; 25; 53; 64; 72; 81; 99; 303; 404} or UNINITIALIZED
x ∈
{-101} ∪ [-25..-15] ∪ [0..10]
∪ {12; 17; 25; 40; 41; 42; 53; 64; 72; 81} ∪ [99..127] ∪ [129..200]
- ∪ {303; 404}
+ ∪ {303; 404} or UNINITIALIZED
[from] Computing for function large_ilevel
[from] Computing for function Frama_C_interval <-large_ilevel
[from] Done for function Frama_C_interval
diff --git a/tests/value/oracle/initialized.res.oracle b/tests/value/oracle/initialized.res.oracle
index 28313721c94409af21b570e0a043955e260d67e3..14418e31e5dafb8f716f7f0f49cebd248900d4a4 100644
--- a/tests/value/oracle/initialized.res.oracle
+++ b/tests/value/oracle/initialized.res.oracle
@@ -103,6 +103,7 @@
{[12][bits 24 to 31]#; [13][bits 0 to 23]#} ∈
{0x11111111; 0x22222222} or UNINITIALIZED
[13][bits 24 to 31] ∈ {0} or UNINITIALIZED
+ p_0 ∈ UNINITIALIZED
v1 ∈ {0}
i6 ∈ [--..--]
__retres ∈ UNINITIALIZED
diff --git a/tests/value/oracle/narrow_behaviors.res.oracle b/tests/value/oracle/narrow_behaviors.res.oracle
index 32fe99abc39f02de30c9f3480ff73dc9abb0f8f7..c7c34ba693151038032e7c479139f683623e7897 100644
--- a/tests/value/oracle/narrow_behaviors.res.oracle
+++ b/tests/value/oracle/narrow_behaviors.res.oracle
@@ -14,6 +14,7 @@
nondet ∈ [--..--]
p.x ∈ {2}
.y ∈ {1; 2}
+ q ∈ UNINITIALIZED
__retres ∈ UNINITIALIZED
==END OF DUMP==
[eva] narrow_behaviors.i:56:
@@ -21,6 +22,7 @@
# cvalue:
nondet ∈ {0}
p{.x; .y} ∈ {1}
+ q ∈ UNINITIALIZED
__retres ∈ UNINITIALIZED
==END OF DUMP==
[eva] computing for function f2 <- main.
@@ -83,6 +85,7 @@
# cvalue:
nondet ∈ {0}
r{.x; .y} ∈ {1}
+ s ∈ UNINITIALIZED
__retres ∈ UNINITIALIZED
==END OF DUMP==
[eva] narrow_behaviors.i:62:
@@ -90,6 +93,7 @@
# cvalue:
nondet ∈ {1}
r{.x; .y} ∈ {2}
+ s ∈ UNINITIALIZED
__retres ∈ UNINITIALIZED
==END OF DUMP==
[eva] computing for function f2 <- main.
diff --git a/tests/value/oracle/octagons-pointers-intermediate.res.oracle b/tests/value/oracle/octagons-pointers-intermediate.res.oracle
index f6f6928d4db7af08f6ab5ce3c73d7c426302cd10..cc794d3b969e2f6126394b392c2518ba8fdc2b25 100644
--- a/tests/value/oracle/octagons-pointers-intermediate.res.oracle
+++ b/tests/value/oracle/octagons-pointers-intermediate.res.oracle
@@ -30,10 +30,10 @@
elt1 ∈ {{ &buffer + [6..436] }}
elt2 ∈ {{ &buffer + [10..440] }}
elt3 ∈ {{ &buffer + [12..442] }}
- c ∈ [--..--]
- e1 ∈ [--..--]
- e2 ∈ [--..--]
- e3 ∈ [--..--]
+ c ∈ [--..--] or UNINITIALIZED
+ e1 ∈ [--..--] or UNINITIALIZED
+ e2 ∈ [--..--] or UNINITIALIZED
+ e3 ∈ [--..--] or UNINITIALIZED
[eva:final-states] Values at end of function init:
buffer[0..435] ∈ [--..--]
i ∈ {436}
diff --git a/tests/value/oracle/octagons-pointers-simple.res.oracle b/tests/value/oracle/octagons-pointers-simple.res.oracle
index b4ac5a0756733ff58a4a12d5a53b72dca2edf3a6..6051c069e6ad5299c640ecef86b415c4a847ff2e 100644
--- a/tests/value/oracle/octagons-pointers-simple.res.oracle
+++ b/tests/value/oracle/octagons-pointers-simple.res.oracle
@@ -46,10 +46,10 @@
elt1 ∈ {{ &buffer + [6..436] }}
elt2 ∈ {{ &buffer + [10..440] }}
elt3 ∈ {{ &buffer + [12..442] }}
- c ∈ [--..--]
- e1 ∈ [--..--]
- e2 ∈ [--..--]
- e3 ∈ [--..--]
+ c ∈ [--..--] or UNINITIALIZED
+ e1 ∈ [--..--] or UNINITIALIZED
+ e2 ∈ [--..--] or UNINITIALIZED
+ e3 ∈ [--..--] or UNINITIALIZED
[eva:final-states] Values at end of function init:
buffer[0..435] ∈ [--..--]
i ∈ {436}
diff --git a/tests/value/oracle/octagons-pointers.res.oracle b/tests/value/oracle/octagons-pointers.res.oracle
index dcc4c9fa9e70f408240e63200520b112956ebb1c..b3c686962e27573ab9306764637f890142d99ee8 100644
--- a/tests/value/oracle/octagons-pointers.res.oracle
+++ b/tests/value/oracle/octagons-pointers.res.oracle
@@ -90,10 +90,10 @@
elt1 ∈ {{ &buffer + [6..436] }}
elt2 ∈ {{ &buffer + [10..440] }}
elt3 ∈ {{ &buffer + [12..442] }}
- c ∈ [--..--]
- e1 ∈ [--..--]
- e2 ∈ [--..--]
- e3 ∈ [--..--]
+ c ∈ [--..--] or UNINITIALIZED
+ e1 ∈ [--..--] or UNINITIALIZED
+ e2 ∈ [--..--] or UNINITIALIZED
+ e3 ∈ [--..--] or UNINITIALIZED
[eva:final-states] Values at end of function init:
buffer[0..435] ∈ [--..--]
i ∈ {436}
diff --git a/tests/value/oracle/period.res.oracle b/tests/value/oracle/period.res.oracle
index 06bf41e67c2931c7ede6b776b660b06d2063853d..ffabad17985bafe2217dd6eaae24b6ad5f976aa4 100644
--- a/tests/value/oracle/period.res.oracle
+++ b/tests/value/oracle/period.res.oracle
@@ -77,6 +77,8 @@
Ft ∈ {2}
Gt ∈ {12}
Ht ∈ {1}
+ p ∈ UNINITIALIZED
+ vg ∈ UNINITIALIZED
==END OF DUMP==
[eva:alarm] period.c:51: Warning:
pointer downcast. assert (unsigned int)(&g) ≤ 2147483647;
diff --git a/tests/value/oracle/recursion.1.res.oracle b/tests/value/oracle/recursion.1.res.oracle
index fe28d193e06ce292c499fce259f11e0b4712d798..60fb835c758c13364113c0d52a999029bdfc65d5 100644
--- a/tests/value/oracle/recursion.1.res.oracle
+++ b/tests/value/oracle/recursion.1.res.oracle
@@ -127,7 +127,7 @@
[eva] done for function main
[eva] ====== VALUES COMPUTED ======
[eva:final-states] Values at end of function alarm:
- res ∈ [2..2147483647]
+ res ∈ [2..2147483647] or UNINITIALIZED
__retres ∈ [1..2147483647]
[eva:final-states] Values at end of function decr:
@@ -147,7 +147,7 @@
x ∈ {0; 1}
b ∈ {0; 1}
[eva:final-states] Values at end of function factorial:
- res ∈ {2; 6; 24; 120}
+ res ∈ {2; 6; 24; 120} or UNINITIALIZED
__retres ∈ {1; 2; 6; 24; 120}
[eva:final-states] Values at end of function factorial_ptr:
y ∈ {91; 120}
@@ -179,7 +179,7 @@
[eva:final-states] Values at end of function precond:
y ∈ [-100..-6]
[eva:final-states] Values at end of function sum:
- res ∈ [3..91]
+ res ∈ [3..91] or UNINITIALIZED
__retres ∈ [1..91]
[eva:final-states] Values at end of function sum_and_fact:
x ∈ {11; 36}
diff --git a/tests/value/oracle/recursion.2.res.oracle b/tests/value/oracle/recursion.2.res.oracle
index 84f55cfe2e5abfe7f85dd8bc16592c62502637d0..a77a482b7f5837fed43cec25cb2e14fc1e4a543e 100644
--- a/tests/value/oracle/recursion.2.res.oracle
+++ b/tests/value/oracle/recursion.2.res.oracle
@@ -21,7 +21,7 @@
[eva] done for function main_fail
[eva] ====== VALUES COMPUTED ======
[eva:final-states] Values at end of function sum_nospec:
- res ∈ [--..--]
+ res ∈ [--..--] or UNINITIALIZED
__retres ∈ [--..--]
[eva:final-states] Values at end of function main_fail:
Frama_C_entropy_source ∈ [--..--]
diff --git a/tests/value/oracle/relations2.res.oracle b/tests/value/oracle/relations2.res.oracle
index 528534268000a5c8e8b2f177a4622b261ec7b417..30bebcad81d04ad51e45060c24564c5bf948459a 100644
--- a/tests/value/oracle/relations2.res.oracle
+++ b/tests/value/oracle/relations2.res.oracle
@@ -57,6 +57,7 @@
t ∈ [0..511]
n ∈ [0..512]
s ∈ {0}
+ b3 ∈ UNINITIALIZED
T[0] ∈ {0}
[1] ∈ {1}
[2] ∈ {42}
@@ -78,6 +79,7 @@
t ∈ [0..511]
n ∈ [0..512]
s ∈ {0; 1}
+ b3 ∈ UNINITIALIZED
T[0] ∈ {0}
[1] ∈ {1}
[2] ∈ {42}
@@ -95,6 +97,7 @@
t ∈ [0..511]
n ∈ [0..512]
s ∈ {0; 1; 2}
+ b3 ∈ UNINITIALIZED
T[0] ∈ {0}
[1] ∈ {1}
[2] ∈ {42}
@@ -112,6 +115,7 @@
t ∈ [0..511]
n ∈ [0..512]
s ∈ [0..2147483647]
+ b3 ∈ UNINITIALIZED
T[0] ∈ {0}
[1] ∈ {1}
[2] ∈ {42}
diff --git a/tests/value/oracle/struct_array.res.oracle b/tests/value/oracle/struct_array.res.oracle
index 5d52686c112607372e4c0fc385c3550a1d6e73cf..e3c8fe1473c06e3b5a1878987aa6244889eb08d6 100644
--- a/tests/value/oracle/struct_array.res.oracle
+++ b/tests/value/oracle/struct_array.res.oracle
@@ -21,11 +21,11 @@
[0].b ∈ {2}
[0].pp ∈ {0}
[0].p ∈ {{ &x }}
- [1].a ∈ {{ (int)&z1 }}
- [1].b ∈ {{ (int)&z2 }}
+ [1].a ∈ {{ (long)&z1 }}
+ [1].b ∈ {{ (long)&z2 }}
[1].pp ∈ {{ &z3 }}
[1].p ∈ {{ &y }}
- [2].a ∈ {{ (int)&z4 }}
+ [2].a ∈ {{ (long)&z4 }}
[2].b ∈ {2}
[2].pp ∈ {0}
[2].p ∈ {{ &x }}
@@ -260,11 +260,11 @@
[0].b ∈ {2}
[0].pp ∈ {0}
[0].p ∈ {{ &x }}
- [1].a ∈ {{ (int)&z1 }}
- [1].b ∈ {{ (int)&z2 }}
+ [1].a ∈ {{ (long)&z1 }}
+ [1].b ∈ {{ (long)&z2 }}
[1].pp ∈ {{ &z3 }}
[1].p ∈ {{ &y }}
- [2].a ∈ {{ (int)&z4 }}
+ [2].a ∈ {{ (long)&z4 }}
[2].b ∈ {2}
[2].pp ∈ {0}
[2].p ∈ {{ &x }}
diff --git a/tests/value/oracle_apron/relations2.res.oracle b/tests/value/oracle_apron/relations2.res.oracle
index 826838be9fa828494778a91aa0b0b45ae7026db1..529a4f0974996512fd0f6d58ff7601c9c945a29e 100644
--- a/tests/value/oracle_apron/relations2.res.oracle
+++ b/tests/value/oracle_apron/relations2.res.oracle
@@ -6,26 +6,26 @@
< [eva] relations2.i:17: Frama_C_show_each_end: [0..4294967295], [0..64]
---
> [eva] relations2.i:17: Frama_C_show_each_end: [0..1023], [0..64]
-68,70d67
+69,71d68
< [eva:alarm] relations2.i:34: Warning:
< accessing out of bounds index.
< assert (unsigned int)(i - (unsigned int)(t + 1)) < 514;
-123,124d119
+127,128d123
< [eva:alarm] relations2.i:35: Warning:
< signed overflow. assert s + b3 ≤ 2147483647;
-139c134
+143c138
< len ∈ [--..--]
---
> len ∈ [0..1023]
-182c177
+186c181
< \result FROM a[0..513]
---
> \result FROM a[0..511]
-198c193
+202c197
< a[0..513]
---
> a[0..511]
-202c197
+206c201
< sv; a[0..513]; T[0..6]
---
> sv; a[0..511]; T[0..6]
diff --git a/tests/value/oracle_bitwise/addition.res.oracle b/tests/value/oracle_bitwise/addition.res.oracle
index 5bf7aa4f39c61e0f2a36094f97327d3f11610ef7..729310a2affcab008aba9cbf34a61e8629f09d58 100644
--- a/tests/value/oracle_bitwise/addition.res.oracle
+++ b/tests/value/oracle_bitwise/addition.res.oracle
@@ -4,9 +4,9 @@
< The imprecision originates from Arithmetic {addition.i:52}
---
> [eva] addition.i:52: Assigning imprecise value to p10.
-163a162
+162a161
> {{ garbled mix of &{p1} (origin: Misaligned {addition.i:52}) }}
-165a165
+163a163
> {{ garbled mix of &{p2} (origin: Misaligned {addition.i:56}) }}
186c186
< p10 ∈ {{ garbled mix of &{p1} (origin: Arithmetic {addition.i:52}) }}
diff --git a/tests/value/oracle_equality/assigns.res.oracle b/tests/value/oracle_equality/assigns.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..89732d3f90926bdcdf9d8146fa6b17595b8aa727
--- /dev/null
+++ b/tests/value/oracle_equality/assigns.res.oracle
@@ -0,0 +1,6 @@
+145,146d144
+< more than 200(1000) locations to update in array. Approximating.
+< [kernel] assigns.i:104:
+147a146,147
+> [kernel] assigns.i:104:
+> more than 200(1000) locations to update in array. Approximating.
diff --git a/tests/value/oracle_equality/period.res.oracle b/tests/value/oracle_equality/period.res.oracle
index 208bb785c666f3d05fd6161dba406ac1cf4ae010..3cc5b3eeaf65b71667a3736906ec69e7ac2eedb5 100644
--- a/tests/value/oracle_equality/period.res.oracle
+++ b/tests/value/oracle_equality/period.res.oracle
@@ -1,9 +1,9 @@
-87,92d86
+89,94d88
< [eva:alarm] period.c:53: Warning:
< pointer downcast. assert (unsigned int)(&g) ≤ 2147483647;
< [eva] period.c:53:
< Assigning imprecise value to p.
< The imprecision originates from Arithmetic {period.c:53}
< [eva:alarm] period.c:54: Warning: out of bounds read. assert \valid_read(p);
-97d90
+99d92
< [scope:rm_asserts] removing 1 assertion(s)
diff --git a/tests/value/oracle_equality/relations2.res.oracle b/tests/value/oracle_equality/relations2.res.oracle
index f28c7db295829a43b3ea15839fda057ad54c22b5..c4950d71433bcd95ffcca1ceb9f583bab746e94c 100644
--- a/tests/value/oracle_equality/relations2.res.oracle
+++ b/tests/value/oracle_equality/relations2.res.oracle
@@ -2,5 +2,5 @@
< n ∈ [0..512]
---
> n ∈ [1..512]
-132d131
+136d135
< [eva] relations2.i:57: Frama_C_show_each_NO2:
diff --git a/tests/value/oracle_octagon/assigns.res.oracle b/tests/value/oracle_octagon/assigns.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..89732d3f90926bdcdf9d8146fa6b17595b8aa727
--- /dev/null
+++ b/tests/value/oracle_octagon/assigns.res.oracle
@@ -0,0 +1,6 @@
+145,146d144
+< more than 200(1000) locations to update in array. Approximating.
+< [kernel] assigns.i:104:
+147a146,147
+> [kernel] assigns.i:104:
+> more than 200(1000) locations to update in array. Approximating.
diff --git a/tests/value/oracle_octagon/relations2.res.oracle b/tests/value/oracle_octagon/relations2.res.oracle
index a250063ee008db59cb92ba3ce23ff4eb5bfd0ad8..8f7073190ffa96e9117aa9e657a6bbae0ccc8a3b 100644
--- a/tests/value/oracle_octagon/relations2.res.oracle
+++ b/tests/value/oracle_octagon/relations2.res.oracle
@@ -10,35 +10,35 @@
< n ∈ [0..512]
---
> n ∈ [1..512]
-68,70d67
+69,71d68
< [eva:alarm] relations2.i:34: Warning:
< accessing out of bounds index.
< assert (unsigned int)(i - (unsigned int)(t + 1)) < 514;
-79c76
+80c77
< n ∈ [0..512]
---
> n ∈ [1..512]
-96c93
+98c95
< n ∈ [0..512]
---
> n ∈ [1..512]
-113c110
+116c113
< n ∈ [0..512]
---
> n ∈ [1..512]
-139c136
+143c140
< len ∈ [--..--]
---
> len ∈ [0..1023]
-182c179
+186c183
< \result FROM a[0..513]
---
> \result FROM a[0..511]
-198c195
+202c199
< a[0..513]
---
> a[0..511]
-202c199
+206c203
< sv; a[0..513]; T[0..6]
---
> sv; a[0..511]; T[0..6]
diff --git a/tests/value/oracle_symblocs/assigns.res.oracle b/tests/value/oracle_symblocs/assigns.res.oracle
new file mode 100644
index 0000000000000000000000000000000000000000..89732d3f90926bdcdf9d8146fa6b17595b8aa727
--- /dev/null
+++ b/tests/value/oracle_symblocs/assigns.res.oracle
@@ -0,0 +1,6 @@
+145,146d144
+< more than 200(1000) locations to update in array. Approximating.
+< [kernel] assigns.i:104:
+147a146,147
+> [kernel] assigns.i:104:
+> more than 200(1000) locations to update in array. Approximating.
diff --git a/tests/value/oracle_symblocs/relations2.res.oracle b/tests/value/oracle_symblocs/relations2.res.oracle
index c58e8b748b82010d71f12f9f376e3ff067b60777..5c2ddb21fb2be059c5739d24c65a1b29be90b79c 100644
--- a/tests/value/oracle_symblocs/relations2.res.oracle
+++ b/tests/value/oracle_symblocs/relations2.res.oracle
@@ -1,2 +1,2 @@
-132d131
+136d135
< [eva] relations2.i:57: Frama_C_show_each_NO2:
diff --git a/tests/value/struct_array.i b/tests/value/struct_array.i
index cfe0e9ab48851779b00a9a9d50ac6d8f47cab6b8..898aa91752d5add3109cfbdf907146ed35899e2b 100644
--- a/tests/value/struct_array.i
+++ b/tests/value/struct_array.i
@@ -5,14 +5,14 @@
volatile v;
struct st1 {
- int a;
- int b;
+ long a;
+ long b;
int *pp;
int *p;
};
int *outp;
int x,y,z1,z2,z3,z4;
-struct st1 T[22] = { {1,2,0,&x}, {(int)&z1,(int)&z2,&z3,&y},{(int)&z4,2,0,&x},{1,2,0,&x} };
+struct st1 T[22] = { {1,2,0,&x}, {(long)&z1,(long)&z2,&z3,&y},{(long)&z4,2,0,&x},{1,2,0,&x} };
struct S {
int a;
diff --git a/tests/value/traces/oracle/test1.res.oracle b/tests/value/traces/oracle/test1.res.oracle
index 687a3a1ceb615c098323649f6003c3d1315af5fd..ee037639517bec64c830931a00dcb666a0177f18 100644
--- a/tests/value/traces/oracle/test1.res.oracle
+++ b/tests/value/traces/oracle/test1.res.oracle
@@ -27,11 +27,11 @@ c -> 5
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
+ 11 -> EnterScope: i -> 13
+ 12 -> initialize variable: i -> 14
+ 13 -> initialize variable: i -> 16
+ 14 -> Assign: i = 0 -> 15
+ 15 -> enter_loop -> 19
16 -> Assign: i = 0 -> 17
17 -> enter_loop -> 18
18 -> Assume: i < 3 true -> 20
diff --git a/tests/value/traces/oracle/test2.res.oracle b/tests/value/traces/oracle/test2.res.oracle
index 05f84f4a876a3eb4e55d1c37823889630a3d12fa..95d7f650c02064982af9ea1947fb863ebe62726e 100644
--- a/tests/value/traces/oracle/test2.res.oracle
+++ b/tests/value/traces/oracle/test2.res.oracle
@@ -54,7 +54,7 @@ c -> 1
35 -> finalize_call: loop -> 36
36 -> Assign: tmp = \result<loop> -> 37
37 -> LeaveScope: \result<loop> -> 38
- 38 -> EnterScope: \result<main> -> 78
+ 38 -> EnterScope: \result<main> -> 79
39 -> EnterScope: j -> 40
40 -> Assign: j = tmp -> 41
41 -> EnterScope: i -> 43
@@ -74,15 +74,15 @@ c -> 1
56 -> LeaveScope: i -> 57
57 -> EnterScope: \result<loop> -> 58
58 -> Assign: \result<loop> = j -> 59
- 59 -> LeaveScope: j -> 74
- 74 -> finalize_call: loop -> 75
- 75 -> Assign: tmp = \result<loop> -> 76
- 76 -> LeaveScope: \result<loop> -> 77
- 77 -> EnterScope: \result<main> -> 80
- 78 -> Assign: \result<main> = tmp -> 79
- 79 -> join -> 82
- 80 -> Assign: \result<main> = tmp -> 81
- 81 -> join -> 82 ]} at 82
+ 59 -> LeaveScope: j -> 75
+ 75 -> finalize_call: loop -> 76
+ 76 -> Assign: tmp = \result<loop> -> 77
+ 77 -> LeaveScope: \result<loop> -> 78
+ 78 -> EnterScope: \result<main> -> 81
+ 79 -> Assign: \result<main> = tmp -> 80
+ 80 -> join -> 83
+ 81 -> Assign: \result<main> = tmp -> 82
+ 82 -> join -> 83 ]} at 83
[from] Computing for function loop
[from] Done for function loop
[from] Computing for function main
diff --git a/tests/value/traces/oracle/test3.res.oracle b/tests/value/traces/oracle/test3.res.oracle
index a8c3a78127eeeda83fc76a2c424715167708af8b..5b4cec9510857974d3dd70e8bcc965871eb4e2ac 100644
--- a/tests/value/traces/oracle/test3.res.oracle
+++ b/tests/value/traces/oracle/test3.res.oracle
@@ -17,15 +17,14 @@
{[ 0 -> initialize variable: g -> 1
1 -> initialize formal variable using type
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
+ 2 -> EnterScope: __retres tmp -> 3
+ 3 -> initialize variable: tmp -> 4
+ 4 -> Assign: tmp = 4 -> 5
+ 5 -> Assume: tmp true -> 6
+ 6 -> Assign: g = tmp -> 7
+ 7 -> Assign: __retres = g + 1 -> 8
+ 8 -> EnterScope: \result<main> -> 9
+ 9 -> Assign: \result<main> = __retres -> 10 ]} at 10
[from] Computing for function main
[from] Done for function main
[from] ====== DEPENDENCIES COMPUTED ======
@@ -55,17 +54,15 @@ int main(int c)
int __traces_domain_return;
{
int __retres;
+ int tmp;
+ tmp = 4;
+ /*@ assert tmp ≢ 0; */
+ g = tmp;
+ __retres = g + 1;
{
- int tmp;
- tmp = 4;
- /*@ assert tmp ≢ 0; */
- g = tmp;
- __retres = g + 1;
- {
- int _result_main_;
- _result_main_ = __retres;
- __traces_domain_return = __retres;
- }
+ int _result_main_;
+ _result_main_ = __retres;
+ __traces_domain_return = __retres;
}
}
return __traces_domain_return;
diff --git a/tests/value/traces/oracle/test5.res.oracle b/tests/value/traces/oracle/test5.res.oracle
index 65e159b215ac3cdbfd7881b377f7c6fac1cd2d06..d80a1a070d8d66e05423708b843895fcffcf12e0 100644
--- a/tests/value/traces/oracle/test5.res.oracle
+++ b/tests/value/traces/oracle/test5.res.oracle
@@ -443,7 +443,7 @@ c -> 1
264 -> Assign: i = i + 1 -> 265
265 -> Assume: i < 10 true -> 266; join -> 278
266 -> EnterScope: j -> 267; join -> 280
- 267 -> initialize variable: j -> 268
+ 267 -> initialize variable: j -> 268; join -> 282
268 -> Assign: j = 0 -> 269
269 -> enter_loop -> 270
270 -> join -> 271
@@ -458,20 +458,21 @@ c -> 1
157 -> Assign: tmp = tmp_0 + tmp -> 159
159 -> LeaveScope: tmp_0 -> 160
160 -> Assign: j = j + 1 -> 162 ]} -> 273;
- join -> 285
+ join -> 286
273 -> Assume: j < 10 false -> 274
274 -> leave_loop -> 275
- 275 -> LeaveScope: j -> 276; join -> 290
- 276 -> Assign: i = i + 1 -> 277; join -> 292
+ 275 -> LeaveScope: j -> 276; join -> 291
+ 276 -> Assign: i = i + 1 -> 277; join -> 293
277 -> join -> 278
- 278 -> Assume: i < 10 true -> 279; join -> 294
+ 278 -> Assume: i < 10 true -> 279; join -> 295
279 -> join -> 280
- 280 -> EnterScope: j -> 281; join -> 296
- 281 -> initialize variable: j -> 282
- 282 -> Assign: j = 0 -> 283
- 283 -> enter_loop -> 284
- 284 -> join -> 285
- 285 -> Loop(16) 148 {[ 148 -> Assume: j < 10 true -> 149
+ 280 -> EnterScope: j -> 281; join -> 297
+ 281 -> join -> 282
+ 282 -> initialize variable: j -> 283; join -> 299
+ 283 -> Assign: j = 0 -> 284
+ 284 -> enter_loop -> 285
+ 285 -> join -> 286
+ 286 -> Loop(16) 148 {[ 148 -> Assume: j < 10 true -> 149
149 -> EnterScope: tmp_0 -> 151
151 -> EnterScope: \result<my_switch> -> 153
153 -> CallDeclared:
@@ -481,23 +482,24 @@ c -> 1
156 -> LeaveScope: \result<my_switch> -> 157
157 -> Assign: tmp = tmp_0 + tmp -> 159
159 -> LeaveScope: tmp_0 -> 160
- 160 -> Assign: j = j + 1 -> 162 ]} -> 287;
- join -> 301
- 287 -> Assume: j < 10 false -> 288
- 288 -> leave_loop -> 289
- 289 -> join -> 290
- 290 -> LeaveScope: j -> 291; join -> 306
- 291 -> join -> 292
- 292 -> Assign: i = i + 1 -> 293; join -> 308
- 293 -> join -> 294
- 294 -> Assume: i < 10 true -> 295; join -> 310
- 295 -> join -> 296
- 296 -> EnterScope: j -> 297; join -> 313
- 297 -> initialize variable: j -> 298
- 298 -> Assign: j = 0 -> 299
- 299 -> enter_loop -> 300
- 300 -> join -> 301
- 301 -> Loop(16) 148 {[ 148 -> Assume: j < 10 true -> 149
+ 160 -> Assign: j = j + 1 -> 162 ]} -> 288;
+ join -> 303
+ 288 -> Assume: j < 10 false -> 289
+ 289 -> leave_loop -> 290
+ 290 -> join -> 291
+ 291 -> LeaveScope: j -> 292; join -> 308
+ 292 -> join -> 293
+ 293 -> Assign: i = i + 1 -> 294; join -> 310
+ 294 -> join -> 295
+ 295 -> Assume: i < 10 true -> 296; join -> 312
+ 296 -> join -> 297
+ 297 -> EnterScope: j -> 298; join -> 315
+ 298 -> join -> 299
+ 299 -> initialize variable: j -> 300; join -> 317
+ 300 -> Assign: j = 0 -> 301
+ 301 -> enter_loop -> 302
+ 302 -> join -> 303
+ 303 -> Loop(16) 148 {[ 148 -> Assume: j < 10 true -> 149
149 -> EnterScope: tmp_0 -> 151
151 -> EnterScope: \result<my_switch> -> 153
153 -> CallDeclared:
@@ -507,25 +509,26 @@ c -> 1
156 -> LeaveScope: \result<my_switch> -> 157
157 -> Assign: tmp = tmp_0 + tmp -> 159
159 -> LeaveScope: tmp_0 -> 160
- 160 -> Assign: j = j + 1 -> 162 ]} -> 303;
- join -> 318
- 303 -> Assume: j < 10 false -> 304
- 304 -> leave_loop -> 305
- 305 -> join -> 306
- 306 -> LeaveScope: j -> 307; join -> 323
+ 160 -> Assign: j = j + 1 -> 162 ]} -> 305;
+ join -> 321
+ 305 -> Assume: j < 10 false -> 306
+ 306 -> leave_loop -> 307
307 -> join -> 308
- 308 -> Assign: i = i + 1 -> 309; join -> 325
+ 308 -> LeaveScope: j -> 309; join -> 326
309 -> join -> 310
- 310 -> join -> 313
- 313 -> join -> 318
- 318 -> join -> 323
- 323 -> join -> 325
- 325 -> Loop(10) 311 {[ 311 -> Assume: i < 10 true -> 312
- 312 -> EnterScope: j -> 314
- 314 -> initialize variable: j -> 315
- 315 -> Assign: j = 0 -> 316
- 316 -> enter_loop -> 317
- 317 -> Loop(16) 148 {[ 148 -> Assume:
+ 310 -> Assign: i = i + 1 -> 311; join -> 328
+ 311 -> join -> 312
+ 312 -> join -> 315
+ 315 -> join -> 317
+ 317 -> join -> 321
+ 321 -> join -> 326
+ 326 -> join -> 328
+ 328 -> Loop(10) 313 {[ 313 -> Assume: i < 10 true -> 314
+ 314 -> EnterScope: j -> 316
+ 316 -> initialize variable: j -> 318
+ 318 -> Assign: j = 0 -> 319
+ 319 -> enter_loop -> 320
+ 320 -> Loop(16) 148 {[ 148 -> Assume:
j < 10 true
-> 149
149 -> EnterScope:
@@ -551,16 +554,16 @@ c -> 1
160 -> Assign:
j = j + 1
-> 162 ]}
- -> 320
- 320 -> Assume: j < 10 false -> 321
- 321 -> leave_loop -> 322
- 322 -> LeaveScope: j -> 324
- 324 -> Assign: i = i + 1 -> 326 ]} -> 329
- 329 -> Assume: i < 10 false -> 330
- 330 -> leave_loop -> 331
- 331 -> LeaveScope: i -> 332
- 332 -> EnterScope: \result<main> -> 333
- 333 -> Assign: \result<main> = tmp -> 334 ]} at 334
+ -> 323
+ 323 -> Assume: j < 10 false -> 324
+ 324 -> leave_loop -> 325
+ 325 -> LeaveScope: j -> 327
+ 327 -> Assign: i = i + 1 -> 329 ]} -> 332
+ 332 -> Assume: i < 10 false -> 333
+ 333 -> leave_loop -> 334
+ 334 -> LeaveScope: i -> 335
+ 335 -> EnterScope: \result<main> -> 336
+ 336 -> Assign: \result<main> = tmp -> 337 ]} at 337
[from] Computing for function main
[from] Computing for function my_switch <-main
[from] Done for function my_switch
diff --git a/tools/hdrck/frama-c-hdrck.opam b/tools/hdrck/frama-c-hdrck.opam
index acd43dffc4a7122b1a70a7ed71d9f1d2835a920b..f536d2fc26c201858ee02052f6b7c5d88a5673ce 100644
--- a/tools/hdrck/frama-c-hdrck.opam
+++ b/tools/hdrck/frama-c-hdrck.opam
@@ -1,7 +1,7 @@
opam-version: "2.0"
name: "frama-c-hdrck"
synopsis: "Frama-C header check tool"
-version: "27.0+dev"
+version: "27.1+dev"
description:"""
Performs all checks related to file headers as required by the Frama-C
continuous integration.
diff --git a/tools/hdrck/hdrck.ml b/tools/hdrck/hdrck.ml
index 409c06b32eae15abcc0a3a12f0c83cc9ac908841..3a093fa251800ff103c60ae1cdebfc0558890815 100644
--- a/tools/hdrck/hdrck.ml
+++ b/tools/hdrck/hdrck.ml
@@ -104,6 +104,11 @@ let debug fmt =
let has_no_warning_nor_error = ref true
+let info fmt =
+ pp_job_first_line ();
+ Format.printf "- [info] ";
+ Format.printf fmt
+
let warn fmt =
pp_job_first_line ();
if !exit_on_warning then
@@ -137,11 +142,7 @@ let error ~exit_value =
in the header_spec.txt files.
*)
let path_concat p1 p2 =
- (* Note: use String.ends_with when minimum OCaml version is 4.13 *)
- if String.length p1 > 0 && String.get p1 (String.length p1 - 1) = '/' then
- p1 ^ p2
- else
- p1 ^ "/" ^ p2
+ if String.ends_with ~suffix:"/" p1 then p1 ^ p2 else p1 ^ "/" ^ p2
(* Temporary directory management (cont.) *)
let get_tmp_dirname () = match !tmp_dirname with
@@ -355,10 +356,10 @@ let get_header_files ?directories:(dirs=(get_header_dirs ())) () :
(* Ctrl+C pressed; abort execution *)
exit 255
else
- warn "%s: duplicated license name (same contents as file: %s)@." filepath previous_entry
+ error ~exit_value:7
+ "%s: duplicated license name (contents differs to file: %s)@." filepath previous_entry
else
- error ~exit_value:7
- "%s: duplicated license name (contents differs to file: %s)@." filepath previous_entry
+ info "%s: duplicated license name (same contents as file: %s)@." filepath previous_entry
with Not_found -> ());
Hashtbl.add license_path_tbl license_name filepath;
)
@@ -713,9 +714,8 @@ let _ =
| Update ->
update_headers ~config_file_opts specified_files;
end;
- if !exit_on_warning && not !has_no_warning_nor_error then
- exit 8 ;
+ if !exit_on_warning && not !has_no_warning_nor_error then exit 8
- (* Local Variables: *)
- (* compile-command: "ocamlc -o hdrck unix.cma str.cma hdrck.ml" *)
- (* End: *)
+(* Local Variables: *)
+(* compile-command: "ocamlc -o hdrck unix.cma str.cma hdrck.ml" *)
+(* End: *)
diff --git a/tools/lint/frama-c-lint.opam b/tools/lint/frama-c-lint.opam
index 08041265966df4bcb34b87e4a768a7faad40342b..8b70df8d1ef65a0b9e546f58f3c42090dbe48ba0 100644
--- a/tools/lint/frama-c-lint.opam
+++ b/tools/lint/frama-c-lint.opam
@@ -1,7 +1,7 @@
opam-version: "2.0"
name: "frama-c-lint"
synopsis: "Frama-C lint tool"
-version: "27.0+dev"
+version: "27.1+dev"
description:"""
Performs all checks related to source code formatting as required by the Frama-C
continuous integration. Namely: OCP-indent for ML files, clang-format for E-ACSL
diff --git a/tools/lint/lint.ml b/tools/lint/lint.ml
index 37e26caba6b8786785e2ad289c0c5a95a4c99642..c0a576b75d00ab2ad223adea7e09a4286a989f79 100644
--- a/tools/lint/lint.ml
+++ b/tools/lint/lint.ml
@@ -24,9 +24,10 @@ type tool_cmds =
{ kind: (string [@default "Misc"]) ;
extensions: (string list [@default []]);
name: string ;
- available_cmd: (string [@default ""]) ; (* leaves it empty to set it as unavailable *)
- check_cmd: (string [@default ""]) ; (* leaves it empty if there is no check command *)
- update_cmd: (string [@default ""]) (* leaves it empty if there is no updating command *)
+ available_cmd: (string [@default ""]) ; (* leave it empty to set it as unavailable *)
+ check_cmd: (string [@default ""]) ; (* leave it empty if there is no check command *)
+ update_cmd: (string [@default ""]) ; (* leave it empty if there is no updating command *)
+ version_cmd: (string [@default ""]) (* leave it empty if there is no version check command *)
}
[@@deriving yojson]
@@ -40,7 +41,8 @@ let external_formatters = [
name = "clang-format";
available_cmd = "clang-format --version > /dev/null 2> /dev/null";
check_cmd = "clang-format --dry-run -Werror" ;
- update_cmd = "clang-format -i"
+ update_cmd = "clang-format -i" ;
+ version_cmd = ""
}
;
{ kind = "Python";
@@ -48,7 +50,8 @@ let external_formatters = [
name = "black";
available_cmd = "black --version > /dev/null 2> /dev/null";
check_cmd = "black --quiet --line-length 100 --check" ;
- update_cmd = "black --quiet --line-length 100"
+ update_cmd = "black --quiet --line-length 100" ;
+ version_cmd = "black --version | grep black | grep -E '23\\.[0-9]+\\.[0-9]+' > /dev/null 2> /dev/null"
}
]
@@ -328,8 +331,12 @@ let check_ml_indent ~update file =
(* C/H *)
(* returns true if the string command is empty *)
-let cmd_result ~file cmd =
- (cmd = "") || (0 = Sys.command (Format.sprintf "%s \"%s\"" cmd file))
+let cmd_result ?file cmd =
+ let command = match file with
+ | None -> cmd
+ | Some file -> Format.sprintf "%s \"%s\"" cmd file
+ in
+ (cmd = "") || (0 = Sys.command command)
let is_formatter_available ~file indent_formatter =
match indent_formatter.is_available with
@@ -338,14 +345,22 @@ let is_formatter_available ~file indent_formatter =
(indent_formatter.tool_cmds.update_cmd <> "") ||
(indent_formatter.tool_cmds.check_cmd <> "")
in
- let is_available = is_enabled && (cmd_result ~file indent_formatter.tool_cmds.available_cmd) in
+ let is_available =
+ is_enabled
+ && (cmd_result indent_formatter.tool_cmds.available_cmd)
+ && (cmd_result indent_formatter.tool_cmds.version_cmd)
+ in
indent_formatter.is_available <- Some is_available;
if not is_enabled then
(* [check_cmd] and [update_cmd] fields are empty *)
- warn "%s is disabled for checking/updating indentation of some %s files (i.e. %s)@."
+ warn
+ "%s is disabled for checking/updating indentation of \
+ some %s files (i.e. %s)@."
indent_formatter.tool_cmds.name indent_formatter.tool_cmds.kind file
else if not is_available then
- warn "%s is unavailable for checking/updating indentation of some %s files (i.e. %s)@."
+ warn
+ "%s is unavailable (or with incompatible version) for checking/updating \
+ indentation of some %s files (i.e. %s)@."
indent_formatter.tool_cmds.name indent_formatter.tool_cmds.kind file;
is_available
| Some is_available -> is_available
diff --git a/tools/ptests/ptests.ml b/tools/ptests/ptests.ml
index 583ffe77da92b3b8a59257ae7e37d53259eb0e4f..4d1178925e63237b512ff43158d4324c99ae0070 100644
--- a/tools/ptests/ptests.ml
+++ b/tools/ptests/ptests.ml
@@ -202,7 +202,6 @@ let example_msg =
STDOPT: #<extra> @[<v 0># Defines a sub-test and prepend the extra to the current option.@]@ \
PLUGIN: <plugin>... @[<v 0># Adds a dependency and set the macro @@PTEST_PLUGIN@@ defining the '-load-plugins' option used in the macro @@PTEST_LOAD_OPTIONS@@.@]@ \
LIBRARY: <pkg.lib>... @[<v 0># Adds a dependency and set the macro @@PTEST_LIBRARY@@ defining the '-load-library' option used in the macro @@PTEST_LOAD_OPTIONS@@.@]@ \
- CMXS: <module>... @[<v 0># Defines dune targets without dependency to tests so use '-load-module %%{dep:<module>.cmxs}' into the test options.@]@ \
MODULE: <module>... @[<v 0># Adds a dependency and adds the corresponding '-load-module' option into the macro @@PTEST_LOAD_OPTIONS@@.@]@ \
SCRIPT: <module>... @[alias 'MODULE' directive.@]@ \
LIBS: <module>... @[<v 0># Like 'MODULE' directive but for modules that can be shared between several test files.@]@ \
@@ -762,7 +761,7 @@ end = struct
aux { s with ex_cmd = cmd; ex_log = name :: s.ex_log })
with Scanf.Scan_failure _ ->
try
- Scanf.sscanf s.ex_cmd "%_[ ]BIN%_[ ]%[A-Za-z0-9_.\\-@@]%_[ ]%s@\n"
+ Scanf.sscanf s.ex_cmd "%_[ ]BIN%_[ ]%[A-Za-z0-9_.\\\"-@@]%_[ ]%s@\n"
(fun name cmd ->
if name = "" then fail (file ^": EXEC"^ (if once then "NOW" else "") ^ " directive with an invalid BIN filename: " ^ s.ex_cmd);
aux { s with ex_cmd = cmd; ex_bin = name :: s.ex_bin })
@@ -1978,11 +1977,15 @@ let warn_if_not_enabled =
let dune_cond_regexp = Str.regexp "^(\\(.*\\))" in
let doublequote_regexp = Str.regexp "\"" in
let dune_var_regexp = Str.regexp "%{" in
+ let paren_regexp = Str.regexp "[()]" in
let dune_cond_item s = Str.global_replace dune_cond_regexp "\\1" s in
let escaped_cond s =
let s = Str.global_replace dune_var_regexp "\\%{" s in
Str.global_replace doublequote_regexp "\\\"" s
in
+ let safe_cond s =
+ Str.global_replace paren_regexp "\"\\0\"" s
+ in
fun ~env ~suite fmt enabled_if ->
if not (StringSet.is_empty enabled_if) then begin
Format.fprintf fmt
@@ -2001,7 +2004,7 @@ let warn_if_not_enabled =
let pp_enabled fmt cond =
let cond = dune_cond_item cond in
Format.fprintf fmt " (echo \"- %s: \" %s \"\\n\")\n "
- (escaped_cond cond) cond
+ (escaped_cond cond) (safe_cond cond)
in
let conds = StringSet.elements enabled_if in
Format.fprintf fmt
diff --git a/tools/ptests/wtests.ml b/tools/ptests/wtests.ml
index 9d4d84f9e74d96532ac1f6bc62d9aebbd8aaab5d..6c68edae0becccf09ef34ad4a4bcba4f69a66901 100644
--- a/tools/ptests/wtests.ml
+++ b/tools/ptests/wtests.ml
@@ -211,7 +211,8 @@ let wrapper json test =
let error = ret_code <> test.ret_code in
if error || !verbosity > 0 then begin
if test.out <> "" then print_file test.dir (if test.tmpout = "" then test.out else test.tmpout) ;
- if test.err <> "" then print_file test.dir (if test.tmperr = "" then test.err else test.tmperr)
+ if test.err <> "" then print_file test.dir (if test.tmperr = "" then test.err else test.tmperr) ;
+ List.iter (print_file test.dir) test.log
end;
if error then begin
Format.printf "%a: return code (%d) differs from the requested code (%d) for the command:%s@."